C***********************************************************************
C
C                     HFODD Main Source
C
C***********************************************************************
C
      BLOCK DATA List_of_modules
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER NAMODU*16,NAMMOD*16
      COMMON /LIMODU/ MODORD(NDMODU),NAMODU(NDMODU),MODVER(NDMODU),
     *                MODTOT
      COMMON /VERMOD/ NAMMOD(NDMODU),MODUVE(NDMODU),MODSET(NDMODU)
      DATA  MODTOT /18/
      DATA (MODORD(NUMODU),NAMODU(NUMODU),MODVER(NUMODU),
     *      NUMODU=1,NDMODU)
C
C***********************************************************************
C    This version requires the following versions of modules:
C***********************************************************************
C                    Module number, Module name      , Module version
     *              /      1      ,'hfodd_sizes     ',    9  ,
     *                     2      ,'hfodd_modules   ',    69 ,
     *                     3      ,'hfodd_hfbtho    ',    201,
     *                     4      ,'hfodd_interface ',    5  ,
     *                     5      ,'hfodd_functional',    5  ,
     *                     6      ,'hfodd_mpiio     ',    6  ,
     *                     7      ,'hfodd_mpimanager',    6  ,
     *                     8      ,'hfodd_shell     ',    6  ,
     *                     9      ,'hfodd_SLsiz     ',    4  ,
     *                    10      ,'hfodd_fission   ',    23 ,
     *                    11      ,'hfodd_pairs     ',    2  ,
     *                    12      ,'hfodd_pnp       ',    16 ,
     *                    13      ,'hfodd_fits      ',    16 ,
     *                    14      ,'hfodd_lipcorr   ',    54 ,
     *                    15      ,'hfodd_tgrad     ',    25 ,
     *                    16      ,'hfodd_wigner    ',    6  ,
     *                    17      ,'hfodd_adiabatic ',    22 ,
     *                    18,      'hfodd_twocen    ',    56 ,
     *                    19,      '                ',    0  ,
     *                    20,      '                ',    0  /
C
      END BLOCK DATA List_of_modules
C
C***********************************************************************
C
C    Copyright 2021, J. Dobaczewski, P. Baczyk, P. Becker, M. Bender,
C                    K. Bennaceur, J. Bonnard, Y. Gao, A. Idini,
C                    M. Konieczka, M. Kortelainen, L. Prochniak,
C                    A.M. Romero, W. Satula, Y. Shi, T.R. Werner, and
c                    L.F. Yu
C    Copyright 2016, N. Schunck, J. Dobaczewski, W. Satula, P. Baczyk,
C                    J. Dudek, Y. Gao, M. Konieczka, K. Sato, Y. Shi,
C                    X.B. Wang, T.R. Werner
C    Copyright 2012, N. Schunck, J. Dobaczewski, J. McDonnell,
C                    W. Satula, J.A. Sheikh, A. Staszczak,
C                    M. Stoitsov, P. Toivanen
C    Copyright 2009, J. Dobaczewski, W. Satula, B.G. Carlsson, J. Engel,
C                    P. Olbratowski, P. Powalowski, M. Sadziak,
C                    J. Sarich, N. Schunck, A. Staszczak, M. Stoitsov,
C                    M. Zalewski, H. Zdunczuk
C    Copyright 2004, 2005, J. Dobaczewski, P. Olbratowski
C    Copyright 1997, 2000, J. Dobaczewski, J. Dudek
C
C    This file is part of HFODD.
C
C    HFODD is free software: you can redistribute it and/or modify it
C    under the terms of the GNU General Public License as published by
C    the Free Software Foundation, either version 3 of the License, or
C    (at your option) any later version.
C
C    HFODD is distributed in the hope that it will be useful, but
C    WITHOUT ANY WARRANTY; without even the implied warranty of
C    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C    GNU General Public License for more details.
C
C    You should have received a copy of the GNU General Public License
C    along with HFODD. If not, see <http://www.gnu.org/licenses/>.
C
C***********************************************************************
C                                                                      !
C Authors:                                                             !
C                                                                      !
C   J. Dobaczewski, P. Baczyk, P. Becker, M. Bender,                   !
C   K. Bennaceur, J. Bonnard, B.G. Carlsson, J. Dudek,                 !
C   J. Engel, Y. Gao, A. Idini, M. Konieczka,                          !
C   M. Kortelainen, T. Lesinski, J. Mcdonnell,                         !
C   P. Olbratowski, P. Powalowski, L. Prochniak,                       !
C   A.M. Romero, M. Sadziak, J. Sarich, K. Sato,                       !
C   A. Sanchez Fernandez, W. Satula, N. Schunck,                       !
C   J.A. Sheikh, Y. Shi, A. Staszczak, M. Stoitsov,                    !
C   X. Sun, P. Toivanen, B.C. Tumelero Backes,                         !
C   X.B. Wang, T.R. Werner, H. Wibowo, L.F. Yu,                        !
C   M. Zalewski, and H. Zdunczuk                                       !
C                                                                      !
C Publications:                                                        !
C                                                                      !
C  [1] J. Dobaczewski and J. Dudek,                                    !
C      Comput. Phys. Commun. 102, 166 (1997).                          !
C  [2] J. Dobaczewski and J. Dudek,                                    !
C      Comput. Phys. Commun. 102, 183 (1997).                          !
C  [3] J. Dobaczewski and J. Dudek,                                    !
C      Comput. Phys. Commun. 131, 164 (2000).                          !
C  [4] J. Dobaczewski and P. Olbratowski,                              !
C      Comput. Phys. Commun. 158, 158 (2004).                          !
C  [5] J. Dobaczewski and P. Olbratowski,                              !
C      Comput. Phys. Commun. 167, 214 (2005).                          !
C  [6] J. Dobaczewski, W. Satula, B.G. Carlsson, J. Engel,             !
C      P. Olbratowski, P. Powalowski, M. Sadziak, J. Sarich,           !
C      N. Schunck, A. Staszczak, M. Stoitsov, M. Zalewski,             !
C      and H. Zdunczuk,                                                !
C      Comput. Phys. Commun. 180, 2361 (2009).                         !
C  [7] N. Schunck, J. Dobaczewski, J. McDonnell, W. Satula,            !
C      J.A. Sheikh, A. Staszczak, M. Stoitsov, and P. Toivanen,        !
C      Comput. Phys. Commun. 183, 166 (2012).                          !
C  [8] N. Schunck, J. Dobaczewski, W. Satula, P. Baczyk, J. Dudek,     !
C      Y. Gao, M. Konieczka, K. Sato, Y. Shi, X.B. Wang, T.R. Werner,  !
C      Comput. Phys. Commun. 216, 145 (2017).                          !
C  [9] J. Dobaczewski, P. Baczyk, P. Becker, M. Bender, K. Bennaceur,  !
C      J. Bonnard, Y. Gao, A. Idini, M. Konieczka, M. Kortelainen,     !
C      L. Prochniak, A.M. Romero, W. Satula, Y. Shi, T.R. Werner,      !
C      L.F. Yu, submitted to J. Phys. G, arXiv:2104.08255              !
C                                                                      !
C User's Guide (v.240h)                                                !
C                                                                      !
C      J. Dobaczewski, W. Satula, B.G. Carlsson, J. Engel,             !
C      P. Olbratowski, P. Powalowski, M. Sadziak, J. Sarich,           !
C      N. Schunck, A. Staszczak, M. Stoitsov, M. Zalewski, and         !
C      H. Zdunczuk, HFODD (v2.40h) User's Guide: arXiv:0909.3626 (2009)!
C                                                                      !
C=======================================================================
C      HFODD     HFODD     HFODD     HFODD     HFODD     HFODD     HFODD
C=======================================================================
C
C      HFODD  SOLVES THE NUCLEAR HARTREE-FOCK OR HARTREE-FOCK-BOGOLYUBOV
C             PROBLEM WITHOUT ASSUMING PLANE-REFLECTION OR TIME-REVERSAL
C             SYMMETRIES
C
C=======================================================================
C
C         HFODD - HISTORY OF DEVELOPMENT
C
C         WERSJA118.DATA0212 - NAGRANA PRZED WYJAZDEM ZE STRASBURGA
C         WERSJA119.DATA0221 - ROZNE DROBNE POPRAWKI
C         WERSJA120.DATA0225 - URUCHOMIENIE SPIN-ORBITY
C         WERSJA121.DATA0228 - CALKOWANIE Z KWADRATURA RZEDU 2*N+2
C         WERSJA122.DATA0311 - ELEMENTY MACIERZOWE KULOMBA
C         WERSJA123.DATA0320 - CZLON POWIERZCHNIOWY KULOMBA
C         WERSJA124.DATA0604 - ZMIANA ORGANIZACJI ITERACJI ORAZ JY
C         WERSJA125.DATA0605 - KRECENIE W BLOKU "+"
C         WERSJA126.DATA0608 - POCZATEK PROGRAMOWANIA DWU BLOKOW "T"
C         WERSJA127.DATA0626 - PRZENIESIENIE NA CRAYA I WEKTORYZACJA
C         WERSJA128.DATA0702 - URUCHOMIENIE PELNEGO HF ODDT
C         WERSJA129.DATA0822 - WERSJA POSREDNIA UZYWANA W OAK RIDGE
C         WERSJA130.DATA1028 - LICZENIE MOMENTOW MULTIPOLOWYCH
C         WERSJA131.DATA1105 - MULTIPOLE W KULOMBIE NA POWIERZCHNI PUDLA
C         WERSJA132.DATA1110 - PRZETESTOWANIE KULOMBA
C         WERSJA133.DATA1120 - SREDNI JOT I PELNA SAMOZGODNOSC ODD-T
C
C                             N O W Y    R O K    1 9 9 4
C
C         WERSJA134.DATA0113 - CZYTANIE DANYCH I ROZPEMPIENIE ENERGII
C         WERSJA135.DATA0120 - KWADRATOWY WIONZ NA SPIN I LICZNE WYDRUKI
C         WERSJA136.DATA0122 - WYDRUK ALIGNMENTOW
C         WERSJA137.DATA0123 - POPRAWIENIE WEKTORYZACJI SKFILD I DENMAT
C         WERSJA138.DATA0126 - WPROWADZENIE OPCJI BEZROTACYJNEJ
C         WERSJA139.DATA0130 - URUCHOMIENIE PAIRINGU
C         WERSJA140.DATA0131 - WYPUSZCZANIE WYNIKOW NA REVIEW FILE
C         WERSJA141.DATA0215 - LABELKI NILSONA I WYLONCZANIE CZLONOW ODD
C         WERSJA142.DATA0608 - BLOKOWANIE KONFIGURACJI W BLOKACH P-S
C         WERSJA143.DATA0613 - WYDRUK ENERGII S-P W JEDNYM FLAKU
C         WERSJA144.DATA0624 - KOPIOWANIE GESTOSCI W PUDLE 1/8 NA 7/8
C         WERSJA145.DATA0625 - WYDRUK I ZAPIS W REVIEW LABELEK "SPORDE"
C         WERSJA146.DATA0714 - ZMIANA NAZWY NA HFODD I INNE MALE ZMIANY
C
C                             N O W Y    R O K    1 9 9 5
C
C         PROGRAM BYL TAK DOBRY, ZE A.D. 1995 NICZEGO NIE ZMIENIONO!
C
C                             N O W Y    R O K    1 9 9 6
C
C         WERSJA147.DATA0112 - UNIFIKACJA OKTUPOLA Z NIEOKTUPOLEM
C         WERSJA148.DATA0123 - SYMETRYZACJA PUDLA DLA ROZNYCH SYMETRII
C         WERSJA149.DATA0124 - DODANIE PIONTEGO MULTIPOLA
C         WERSJA150.DATA0129 - DODANIE SREDNICH PROMIENI I XYZ-ROZMIAROW
C         WERSJA151.DATA0131 - WEKTORYZACJA PROCEDUR INTCEN, INTSOR, ...
C         WERSJA152.DATA0202 - BLOKOWANIE HAMILTONIANU DLA ISIGNY=1
C         WERSJA153.DATA0204 - PORZONDNE WYDRUKI CZASOW CPU
C         WERSJA154.DATA0208 - WSTAWIENIE PREDEFINICJI DO SUBRUTYNY
C         WERSJA155.DATA0215 - START Z POTENCJALU NILSSONA
C         WERSJA156.DATA0303 - ZMNIEJSZENIE PAMIECI
C         WERSJA157.DATA0320 - ROZPEMPIENIE TRZECH LICZB MULTIPOLI
C         WERSJA158.DATA0322 - WCZYTYWANIE PARAMETROW NILSSONA (JACEK)
C         WERSJA158.DATA0322 - LICZENIE MULTIPOLI DO RZENDU=9 (JUREK)
C         WERSJA160.DATA0412 - UZGODNIENIE DWU WERSJI 1.58
C         WERSJA161.DATA???? - TEJ WERSJI NIKT NIGDY NIGDZIE NIE WIDZIAL
C         WERSJA162.DATA???? - POPRAWIANIE WIENZOW METODOM NEWTONA
C         WERSJA163.DATA1117 - WERSJA Z FAJLU Cray_hf/hf63.vect.big.f
C         WERSJA164.DATA1119 - WERSJA ROBOCZA UZGADNIANA Z CPC HF60P.F
C         WERSJA165.DATA1210 - WERSJA UZGODNIONA Z CPC HF60P.F & CLEANED
C         WERSJA166.DATA1214 - WERSJA REFERENCE PRZED HFB I/LUB TILTED J
C
C                             N O W Y    R O K    1 9 9 7
C
C         WERSJA167.DATA0102 - ZAPIS FAJLU FILCOU+ZAPIS DP_RHO NA FILREC
C         WERSJA168.DATA0517 - UNIKANIE PING-PONGU I DIABATYCZNOSC
C         WERSJA169.DATA0523 - LICZENIE G-PAIRING JAK W FUNNY HILLS
C         WERSJA170.DATA0527 - ZBIEZNOSC SRODKOW MASY I Q21 DO ZERA
C
C         BIFURKACJA WERSJI !!!!!
C
C         WERSJA170A.DATA0829- DIABATYCZNOSC Z OKTUPOLEM
C         WERSJA170D.DATA0901- DIABATYCZNOSC WE WSZYSTKICH BLOKACH NARAZ
C         WERSJA170E.DATA0903- REDUKCJA LICZBY WYWOLAN ANGYSP
C         WERSJA170F.DATA1020- JEDNOCZASTKOWE MOMENTY I PROMIENIE
C         WERSJA170G.DATA1021- BEZPIECZNIK NA OBSERWABLE W DIA-BLOKCKING
C         WERSJA170H.DATA1031- SKROCENIE LINII NA FAJLU FILREV
C         WERSJA170I.DATA1112- POPRAWIENIE BYKA W LICZENIU DENLPS
C         WERSJA170J.DATA1129- DODANIE ZHPEV Z NETLIB
C         WERSJA170K.DATA1202- UNIKANIE CHAOTYCZNEJ NIEZBIEZNOSCI
C
C                             N O W Y    R O K    1 9 9 8
C
C         WERSJA175F.DATA0725- OPARTA NA 1.77D, DO PUBLIKACJI W CPC
C
C         WERSJA175.DATA0709 - OPARTA NA 1.70K, DO PUBLIKACJI W CPC
C         WERSJA176.DATA0709 - IDENTYCZNA Z 1.75, PRZED ZROBIENIEM HFB
C         WERSJA177.DATA0714 - POPRAWIENIE "PHASES" I ZROBIENIE "DIAMAT"
C         WERSJA178.DATA0723 - URUCHOMIENIE HFB
C
C                             N O W Y    R O K    1 9 9 9
C
C         WERSJA175I.DATA0702- WYDRUK BET
C         WERSJA175L.DATA0903- POPRAWIENIE WOLANIA MACIERZY PRZEZ GLOWE
C         WERSJA175M.DATA0915- POPRAWIENIE BYKA W SKALOWANIU
C         WERSJA175N.DATA1126- UAKTUALNIENIE ZAPISOW W RECORD
C         WERSJA175O.DATA1214- USUNIECIE NEWTONA
C         WERSJA175P.DATA1216- USUNIECIE FILNEW I FILQLM
C
C         WERSJA179.DATA0702 - WYDRUK BET
C         WERSJA180.DATA1015 - UZGODNIONA Z WERSJA 1.75M
C         WERSJA181.DATA1127 - USUNIECIE MACIERZY IPHASE
C         WERSJA182.DATA1216 - USUNIECIE NEWTONA
C
C                             N O W Y    R O K    2 0 0 0
C
C         WERSJA183.DATA0211 - POCHYLENIE OSI
C         WERSJA184.DATA0304 - PELNE ZLAMANIE WSZYSTKICH SYMETRII
C         WERSJA185.DATA0703 - MULTIPOLE W UKLADZIE SRODKA MASY
C         WERSJA186.DATA0704 - MOMENTY PEDU W UKLADZIE SRODKA MASY
C         WERSJA187.DATA0710 - USUNIECIE BYKOW W LAMANIU SYMPLEKSU
C         WERSJA188.DATA1221 - MULTIPOLE W UKLADZIE WEWNETRZNYM
C
C                             N O W Y    R O K    2 0 0 1
C
C         WERSJA189.DATA0717 - MOMENTY SCHIFFA
C         WERSJA190.DATA0718 - CALKI GESTOSCI LAMIACYCH SYMETRIE
C         WERSJA191.DATA0722 - BETY W UKLADZIE SRODKA MASY I WEWNETRZNYM
C         WERSJA192.DATA1126 - ZACHOWANA TYLKO PARZYSTOSC - KADLUBEK
C         WERSJA193.DATA1220 - PELNA SPIN-ORBITA ORAZ PARAMETRY LANDAUA
C         WERSJA194.DATA1220 - MASA HBMASS ROZNA DLA ROZNYCH SIL SKYRMA
C         WERSJA195.DATA1228 - DWUCIALOWA POPRAWKA NA SRODEK MASY
C         WERSJA196.DATA1228 - KWADRATOWE WIENZY NA SPIN W 3 KIERUNKACH
C
C                             N O W Y    R O K    2 0 0 2
C
C         WERSJA197.DATA0122 - ZACHOWANA TYLKO PARZYSTOSC - PELNA WERSJA
C         WERSJA198.DATA0430 - ROZNE POPRAWKI I PRZEROBIENIE LANDAUA
C         WERSJA199.DATA0625 - CUTOFF PAIRINGU HFB W WIDMIE ROWNOWAZNYM
C         WERSJA200.DATA0711 - 8 NOWYCH OBSERWABLI W DIABATIC I HFBSIG
C         WERSJA201.DATA1108 - WIONZ NA OMEGA TIMES SPIN
C
C                             N O W Y    R O K    2 0 0 3
C
C         WERSJA202.DATA0113 - MOMENTY MAGNETYCZNE
C         WERSJA203.DATA0314 - WERSJA ZBIFURKOWANA OD WERSJI 2.02
C         WERSJA204.DATA0322 - PRZEORGANIZOWANIE PAMIECI NA F90
C         WERSJA205.DATA0407 - DODANIE ZHPEVX Z NETLIB
C         WERSJA206.DATA1219 - ZACHOWANIE SYGNATURY W COPDEN
C
C                             N O W Y    R O K    2 0 0 4
C
C         WERSJA207.DATA0102 - RUCHOMA OMEGA - OPCJA "IMOVAX"
C         WERSJA208.DATA0206 - OPARTA NA 2.07J, DO PUBLIKACJI W CPC
C         WERSJA209.DATA0211 - ELEMENTY MACIERZOWE POTENCJALU YUKAWY
C         WERSJA210.DATA0311 - WIENZY SKALARNE
C         WERSJA211.DATA0715 - LICZENIE ELEMENTOW MACIERZOWYCH PAIRINGU
C         WERSJA212.DATA1202 - LICZENIE 1D ELEMENTOW MACIERZOWYCH GOGNY
C         WERSJA213.DATA1226 - ENERGIA WPROST I WYMIENNA YUKAWY
C
C                             N O W Y    R O K    2 0 0 5
C
C         WERSJA214.DATA0126 - DELTY PAIRINGOWE ZALEZNE OD STANU
C         WERSJA215.DATA0208 - OBRACANIE FUNKCJI FALOWYCH
C         WERSJA216.DATA0322 - PENSURFACE MOMENTS OBLICZANE DLA IDOPLM=1
C         WERSJA217.DATA0407 - HFB BEZ ZADNYCH ZACHOWANYCH SYMETRII
C         WERSJA218.DATA0520 - OBRACANIE MOMENTOW I MOMENTOW PEDU
C         WERSJA219.DATA0522 - DOKLADNE DEFORAMCJE BETA BOHRA
C         WERSJA220.DATA1027 - WIENZY NA MOMENTY SCHIFFA
C         WERSJA221.DATA1215 - RZUTOWANIE NA MOMENT PEDU
C
C                             N O W Y    R O K    2 0 0 6
C
C         WERSJA222.DATA0203 - ZREDUKOWANE ELEMENTY MACIERZOWE PRZEJSC
C         WERSJA223.DATA0217 - TRANSFORMACJE D2H FUNKCJI FALOWYCH
C         WERSJA224.DATA0224 - ROWNOLEGLE OBLICZENIA KERNELI
C         WERSJA225.DATA0330 - MIESZANIE K
C
C                             N O W Y    R O K    2 0 0 7
C
C         WERSJA226.DATA0226 - BLOKOWANIE KWAZICZASTEK W WERSJI SIMPLEKS
C         WERSJA227.DATA0322 - BLOKOWANIE I HFB WE WSZYSTKICH SYMETRIACH
C         WERSJA228.DATA0619 - IMPLEMENTACJA PROCEDUR BLAS==JASON SARICH
C         WERSJA229.DATA0628 - WPROWADZENIE NUMEROW FAJLI INPUT I OUTPUT
C         WERSJA230.DATA0803 - POPRAWKI LIPKINA-NOGAMI
C         WERSJA231.DATA0808 - IMPLEMENTACJA ZHEEVR, AUTOR==JASON SARICH
C         WERSJA232.DATA1119 - FILLING APPROXIMATION
C
C                             N O W Y    R O K    2 0 0 8
C
C         WERSJA233.DATA0207 - REDUCED MATRIX ELEMENTS OF SCHIFF MOMENTS
C         WERSJA234.DATA0321 - DOKLADNA WYMIANA KULOMBOWSKA PROGRAMOWANA
C         WERSJA235.DATA0322 - BROYDEN METHOD==N. SCHUNCK & M. STOITSOV
C         WERSJA236.DATA0929 - DOKLADNA WYMIANA KULOMBOWSKA  WYTESTOWANA
C         WERSJA237.DATA1018 - BLOKOWANIE WZGL USTALONEJ FUNKCJI FALOWEJ
C         WERSJA238.DATA1216 - PRZYSPIESZENIE DELT  ZALEZNYCH  OD  STANU
C
C                             N O W Y    R O K    2 0 0 9
C
C         WERSJA239.DATA0306 - IDENTYCZNA Z 2.38J, POSLANA DO PUBLIKACJI
C         WERSJA240.DATA0611 - BROYDEN METHOD DEBUGGED FOR LIPKIN-NOGAMI
C         WERSJA241.DATA0813 - IDENTYCZNA Z 2.40H, POSLANA DO PUBLIKACJI
C         WERSJA242.DATA0816 - USUNIETA  MOZLIWOSC  UZYWANIA  FORTRAN-77
C         WERSJA243.DATA1020 - METODA DWU BAZ (TWO-BASIS) W HFB NO--SYMM
C         WERSJA244.DATA1109 - AUGMENTED LAGRANGIAN (STOITSOV&STASZCZAK)
C         WERSJA245.DATA1225 - POPRAWIONE PARAMETRY SIL SLY4, SLY5, SLY7
C
C                             N O W Y    R O K    2 0 1 0
C
C         WERSJA246.DATA0310 - OAK RIDGE FEATURES ADDED, NICOLAS SCHUNCK
C         WERSJA247.DATA0314 - CoM CORRECTIONS WITH PAIRING, P. TOIVANEN
C         WERSJA248.DATA0507 - ROTATIONAL CORRECTION - PROGRAMING STARTD
C         WERSJA249.DATA0720 - OAK RIDGE FEATURES ADDED, NICOLAS SCHUNCK
C
C                             N O W Y    R O K    2 0 1 1
C
C         WERSJA250.DATA0625 - IDENTYCZNA Z OPUBLIKOWANA 249S 26/02/2011
C         WERSJA251.DATA0830 - THE PROTON-NEUTRON MIXING WITHOUT PAIRING
C         WERSJA252.DATA1216 - THE PROTON-NEUTRON MIXING &SIMPLEX BROKEN
C
C                             N O W Y    R O K    2 0 1 2
C
C         WERSJA253.DATA0320 - URUCHOMIENIE I WYTESTOWANIE SIL GOGNY'EGO
C         WERSJA254.DATA0520 - ZAKODOWANIE REGULARYZOWANYCH SIL SKYRME'A
C         WERSJA255.DATA0716 - TROJWYMIAROWE RZUTOWANIE NA DOBRY IZOSPIN
C         WERSJA256.DATA1107 - TESTOWANIE RZUTOWANIA 3D NA DOBRY IZOSPIN
C
C                             N O W Y    R O K    2 0 1 3
C
C         WERSJA265.DATA0620 - FULL NLO REGULARIZED INTERACTION EXCPT SO
C         WERSJA266.DATA0714 - FULL N2LO REGULARIZED INTERACTION & NO SO
C         WERSJA267.DATA0809 - PARTICLE NUMBER PROJECTION BY T. LESINSKI
C         WERSJA268.DATA0815 - AVERAGE VALUES OF THE ISOSPINS BY K. SATO
C         WERSJA269.DATA1207 - ROTATIONAL AND TRANSLAT. CORR. BY Y.  GAO
C
C                             N O W Y    R O K    2 0 1 4
C
C         WERSJA270.DATA1002 - HIGHER-ORDER LIPKIN CORRECTIONS, X.B.WANG
C
C                             N O W Y    R O K    2 0 1 5
C
C         WERSJA271.DATA0113 - PRZYGOTOWYWANA DO PUBLIKACJI,  270V+270AD
C         WERSJA272.DATA0419 - CHARGE SYMMETRY BREAKING,BACZYK-KONIECZKA
C         WERSJA273.DATA0504 - PAIRING CHANNEL  FOR  REGULARIZED  FORCES
C         WERSJA274.DATA0509 - PFAFFIAN PROJECTION OF HFB STATES, Y. GAO
C         WERSJA275.DATA0606 - SKYRME TENSOR INTERACTION AND "F" DENSITY
C
C                             N O W Y    R O K    2 0 1 6
C
C         WERSJA276.DATA0316 - PAIRING FOR REGULARIZED  FORCES  DEBUGGED
C         WERSJA277.DATA0320 - SKYRME TENSOR DEBUGGED BACZYK & KONIECZKA
C         WERSJA278.DATA1011 - PAIRING FOR NO SYMMETR. AND REGUL. FORCES
C
C                             N O W Y    R O K    2 0 1 7
C
C         WERSJA279.DATA0408 - TESTING THE SKYRME - PAIRING  BY  LINGFEI
C         WERSJA280.DATA0415 - SUM OF PROTON AND NEUTRON MAGNETIC MOMENT
C         WERSJA281.DATA0701 - REDUCED SCHIFF ME'S FOR PROJECTED  STATES
C         WERSJA282.DATA0717 - KARIM'S QUASPARTCLE FORMULA FOR STABILITY
C         WERSJA283.DATA0729 - VERSNS. 248WF AND 282 SUCCESSFULLY MERGED
C         WERSJA284.DATA1212 - ALIGNMENT OCCUPATIONS AND PARITY OVERLAPS
C
C                             N O W Y    R O K    2 0 1 8
C
C         WERSJA285.DATA0416 - AXIALIZATION OF THE CODE BY PIERRE BECKER
C         WERSJA286.DATA0916 - 3-BODY GRADIENTS AND ISB NLO SKYRME TERMS
C         WERSJA287.DATA1126 - PROJECTION OF BLOCKED HFB STATE, YUAN GAO
C
C                             N O W Y    R O K    2 0 1 9
C
C         WERSJA288.DATA0215 - BETAS IN REVIEW FILE, NON-DOMINANT LABELS
C         WERSJA289.DATA0310 - SEPARABLE GENERATORS WITH  ANTONIO ROMERO
C         WERSJA290.DATA0426 - WIGNER D FUNCTIONS BY Y.SHI&PRE 92,043307
C         WERSJA291.DATA0709 - WIGNER AND SEPARABLE GENERATORS  DEBUGGED
C         WERSJA292.DATA1123 - MULTI-GAUSS SEPARAB FORCE & BASIS(CONSTR)
C
C                             N O W Y    R O K    2 0 2 0
C
C         WERSJA293.DATA0212 - POCZATEK PRACY NAD  PN-MIXING FOR PAIRING
C         WERSJA294.DATA0328 - WIECEJ   PRACY NAD  PN-MIXING FOR PAIRING
C         WERSJA295.DATA0406 - PLUS WIECEJ PRACY W PN-MIXING FOR PAIRING
C         WERSJA296.DATA0608 - PROJEKTY ROZWIJANE: PN-MIX, J2, AMP4BLOCK
C         WERSJA297.DATA0713 - SKONCZONE J2 PO RZUTOWANIU NA MOMENT PEDU
C         WERSJA298.DATA0803 - HFB/HF JEDYNIE DLA NEUTRONOW LUB PROTONOW
C         WERSJA299.DATA0813 - PNP (TOTAL) IN PROANG WITH JEREMY BONNARD
C         WERSJA300.DATA1007 - MULTI-QUASIP BLOCKING WITH JEREMY BONNARD
C         WERSJA301.DATA1125 - PRZYGOTOWYWANA DO PUBLIKACJI, KOPIA 3.00U
C
C                             N O W Y    R O K    2 0 2 1
C
C         WERSJA302.DATA0118 - PNP (TOTAL) IN PROANG DEBUGGED & FINISHED
C         WERSJA303.DATA0124 - ZAPIS/CZYTANIE DEFORMACJI BAZY NA/Z DYSKU
C         WERSJA304.DATA0316 - NIEDIAGONALNY KERNEL/BLOCKING (J.BONNARD)
C         WERSJA305.DATA0513 - PRZYGOTOWYWANA DO PUBLIKACJI, KOPIA 3.04S
C         WERSJA306.DATA0517 - PRZYGOTOWYWANA DO PUBLIKACJI, KOPIA 3.05E
C         WERSJA307.DATA0908 - KOPIA OMYLKOWO WERSJI 3.06A ZAMIAST 3.06H
C         WERSJA308.DATA1127 - ZGRANIE 3.07U Z ROZNICAMI 3.06A --- 3.06H
C         WERSJA309.DATA1212 - PRZYSPIESZENIE AXIALIZACJI: CZYNNIK OSIEM
C
C                             N O W Y    R O K    2 0 2 2
C
C         WERSJA310.DATA0108 - MOMENTY MAGNETYZACJI >HYPERFINE SPLITTING
C         WERSJA311.DATA0125 - DIAGONALIZACJA MULTI-REFERENCE(J.BONNARD)
C         WERSJA312.DATA0422 - PFAFFIANS FOR CONSERVED PARITY(J.BONNARD)
C         WERSJA313.DATA0516 - CONSTRAINTS ON ISOVECT. MULTIPOLE MOMENTS
C         WERSJA314.DATA0823 - MULTI-REFERENCE MIXING (1) WITH J.BONNARD
C         WERSJA315.DATA1019 - BEGIN TWO-CENTRE WORK W/ A. SANCHEZ ET AL
C         WERSJA316.DATA1202 - BEGIN ADIABATIC WORK  WITH  X. SUN  ET AL
C
C                             N O W Y    R O K    2 0 2 3
C
C         WERSJA317.DATA0203 - THE TWO-CENTRE & ADIABATIC WORK CONTINUES
C         WERSJA318.DATA0307 - INTRINSIC & SPECT. SPIN-ASYMMETRY MOMENTS
C         WERSJA319.DATA0525 - THE TWO-CENTRE & ADIABATIC WORK CONTINUES
C         WERSJA320.DATA0731 - MULTI-REFERENCE MIXING (2) WITH J.BONNARD
C         WERSJA321.DATA1030 - THE 3D-AMP AND <J_Y> BUGS HAVE BEEN FIXED
C         WERSJA322.DATA1127 - NEW GOGNY & PAIRING NO-SIMPLEX B.T.BACKES
C
C                             N O W Y    R O K    2 0 2 4
C
C         WERSJA323.DATA0207 - INTRINSIC TWO-BODY-CURRENTS WIBOWO&BACKES
C         WERSJA324.DATA0221 - FINITE-RANGE SO&TENSOR ENERGY K.BENNACEUR
C         WERSJA325.DATA0428 - NILSSON LABELS  FOR  QUASIPARTICLE STATES
C         WERSJA326.DATA0621 - COAXIAL TWO-CENTER HO A.SANCHEZ-FERNANDEZ
C         WERSJA327.DATA0627 - QUADRUPLE PRECISION FOR GOGNY N0>20 CALC.
C         WERSJA328.DATA0823 - COMPLETE  TWO-BODY CURRENTS WIBOWO&BACKES
C         WERSJA329.DATA1020 - MULTI-REFERENCE MIXING DEBUGGED BY  X.SUN
C         WERSJA330.DATA1123 - FINITE-RANGE SPIN-ORBIT&TENSOR PROGRAMMED
C         WERSJA331.DATA1127 - FINITE-RANGE SPIN-ORBIT & TENSOR DEBUGGED
C         WERSJA332.DATA1206 - TWO-BODY CURRENTS DEBUGGED  WIBOWO&BACKES
C
C                             N O W Y    R O K    2 0 2 5
C
C         WERSJA333.DATA0215 - TWO-BODY CURRENTS FINAL HAN&WIBOWO&BACKES
C
C=======================================================================
C         ATTENTION: BUGS KNOWN IN THE PUBLISHED VERSION HF306H
C=======================================================================
C                 1. BETWEEN  VERSIONS  (3.00K)  AND  (3.07),  CHARACTER
C                    VARIABLES  "ERRSTR"  WERE  WRITTEN   WITH   STRINGS
C                    CONTAINING "FIXED/INITLZD" THAT  WERE  69-CHARACTER
C                    LONG WHILE "ERRSTR" WAS DECLARED 68-CHARACTER LONG.
C                    THIS WAS CRASHING  THE  CODE  WHEN  THESE  SPECIFIC
C                    ERROR MESSAGES WERE SUPPOSED TO BE PRINTED. THE BUG
C                    WAS CORRECTED ON 09/09/2021 IN VERSION (3.07A).
C                    MORE SIMILAR BUGS WERE  CORRECTED  ON  27/01/24  IN
C                    VERSION (3.22P).
C
C                 2. BETWEEN VERSIONS (2.97J) AND (3.07B), THE CONDITION
C                    TO CALL  "SAVLIP"  DID  NOT  INCLUDE  THE  TEST  OF
C                    "MPAHFB".  AS  A  RESULT,  AFTER  IMPLEMENTING  THE
C                    DYNAMIC DOWNGRADE OF HFB TO HF, "SAVLIP"  COULD  BE
C                    CALLED IN AN HF RUN, WHICH WAS CAUSING THE CODE  TO
C                    CRASH  ON  THE  SEGMENTATION  FAULT. THIS  BUG  WAS
C                    CORRECTED ON 25/09/2021 IN VERSIONS (3.07C).
C
C                 3. BETWEEN VERSIONS (2.97J) AND (3.07B), THE CONDITION
C                    BELOW TO  GRAB  THE  LIKIN-NOGAMI  ARRAYS  DID  NOT
C                    INCLUDE THE TEST OF "MPAHFB". AS  A  RESULT,  AFTER
C                    IMPLEMENTING THE DYNAMIC DOWNGRADE OF  HFB  TO  HF,
C                    IN AN HF RUN THE CODE WAS  STOPPING. THIS  BUG  WAS
C                    PRESENT IN SEVEN INSTANCES HERE AND BELOW, AND  WAS
C                    CORRECTED ON 25/09/2021 IN VERSIONS (3.07C).
C
C                 4. BETWEEN VERSIONS (2.83G) AND (3.07C), ARRAY  M_OCCU
C                    WAS OVERWRITEN IN CONSIZ AFTER THE CALL TO  AXISIZ.
C                    THIS COULD HAVE CAUSED  PROBLEMS  WHEN  M_OCCU  WAS
C                    USED AGAIN IN AXISIZ IN THE NEXT ITERATION. THE BUG
C                    WAS CORRECTED ON 19/10/2021 IN VERSION (3.07D).
C
C                 5. BETWEEN VERSIONS (2.80B) AND (3.07C), ARRAY  K_OCCU
C                    WAS OVERWRITEN IN CONSIQ AFTER THE CALL TO  AXISIQ.
C                    THIS COULD HAVE CAUSED  PROBLEMS  WHEN  K_OCCU  WAS
C                    USED AGAIN IN AXISIQ IN THE NEXT ITERATION. THE BUG
C                    WAS CORRECTED ON 19/10/2021 IN VERSION (3.07D).
C
C                 6. THE PUBLICATION OF VERSION (3.06H) IN J.  Phys.  G:
C                    Nucl. Part. Phys. 48 102001 CONTAINS ON PAGE 41  AN
C                    INCORRECT DESCRIPTION OF  THE  KERNEL  FILE  NAMES,
C                    WHICH SHOULD READ:
C                    For ISAKER = 2 and IPAKER = 1 (see section VI-3.2
C                    [6]), for all values of indices 't' the code
C                    attempts to read the kernel files
C                    Nxxxxxt-LyyRzz-//FILKER,
C                    where // denotes concatenated strings. The one-,
C                    two- or five-digit indices are:
C                    > 'xxxxx' is the consecutive index of the kernel
C                      file, which is equal to KFIKER (see section
C                      VII-3.2 [7]).
C                    > 't' is the number from 0 to 9 of the consecutive
C                      file having the given index 'xxxxx'.
C                    > 'yy' is the number of the  left wave function.
C                    > 'zz' is the number of the right wave function.
C
C                 7. AFTER THE  MAGNETIC  MOMENTS  WERE  INPLEMENTED  IN
C                    VERSION (2.02), VARIABLE "NMUPOW" WAS NOT  PROPERLY
C                    UPDATED AND IT WAS LEFT  EQUAL  TO  THE  NUMBER  OF
C                    MULTIPOLE MOMENTS "NMUMAX",  WHEREAS  TO  DETERMINE
C                    THE ORBITAL ANGULAR MOMENTUM IN "INTORB", IT SHOULD
C                    HAVE BEEN EQUAL TO AT LEAST "NMAMAX"+1.  THEREFORE,
C                    FOR "NMUMAX"<="NMAMAX"  THE  CODE  COULD  NOT  WORK
C                    CORRECTLY. THIS BUG WAS CORRECTED ON 15/12/2021  IN
C                    VERSION (3.09H).
C
C                 8. UP TO VERSION (3.10B), FOR PARITY  PROJECTION,  THE
C                    REDUCED MATRIX ELEMENTS OF THE PARITY-ODD MULTIPOLE
C                    AND SURFACE OPERATORS (THOSE FOR THE ODD VALUES  OF
C                    LAMBDA), AND  THOSE  OF  THE  PARITY-EVEN  MAGNETIC
C                    OPERATORS (THOSE FOR THE EVEN  VALUES  OF  LAMBDA),
C                    WERE INCORRECTLY CALCULATED INSTEAD  OF  BEING  SET
C                    TO ZERO. THIS BUG WAS CORRECTED  ON  25/01/2022  IN
C                    VERSION (3.10C).
C
C                 9. BETWEEN VERSIONS (3.06A) AND (3.10K), SAVING OF THE
C                    DATA UNDER KEYWORD 'GYROSC' IN SUBROUTINE  'REVIEW'
C                    WAS  CORRUPTING  THE  DATA  SAVED   UNDER   KEYWORD
C                    'QMULTI'. THIS BUG WAS CORRECTED ON  10/02/2022  IN
C                    VERSION (3.10L).
C
C                10. BETWEEN VERSIONS (2.49T) AND  (3.12A),  CALCULATION
C                    OF THE TRANSITION MATRIX ELEMENTS  OF  THE  SURFACE
C                    MOMENTS FOR LAMBDA=0 WAS  IMPLEMENTED  INCORRECTLY,
C                    BECAUSE SUBROUTINE MOMSIF WAS NOT SET TO  CALCULATE
C                    THEM. THIS  BUG  WAS  CORRECTED IN VERSION  (3.12D)
C                    ON 24/04/2022.
C
C                11. BETWEEN VERSIONS (3.06A) AND  (3.13N),  INFORMATION
C                    ON THE EFFECTIVE G-FACTORS  ("IGYROS")  USED  IN  A
C                    GIVEN RUN WAS NOT STORED ON THE KERNEL FILE.  AS  A
C                    CONSEQUENCE, THE FOLLOWING RUN THAT WAS READING THE
C                    THE KERNEL FILE AND USING DIFFERENT VALUES  OF  THE
C                    G-FACTORS WAS GIVING THE  PREVIOUS  VALUES  OF  THE
C                    MAGNETIC MOMENTS WITHOUT NOTIFYING  THE  USER. THIS
C                    BUG WAS CORRECTED ON 02/08/2022 IN VERSION (3.13O).
C
C                12. BETWEEN VERSIONS (2.99R) AND (3.15P), THE TREATMENT
C                    OF "NUQUVE" IN "QUABCS" WAS ACTIVE FOR ITWOBA=1 TOO
C                    AND ACTED ON TOP OF THAT IMPLEMENTED IN HFBSI_ WHEN
C                    THE TWO-BASIS METHOD WAS ACTIVE. ON  RARE  ANNOYING
C                    OCCASIONS, THIS WAS  CAUSING  PROBLEMS  IN  PROANG.
C                    THIS BUG WAS CORRECTED  ON  29/11/2022  IN  VERSION
C                    (3.15Q) WHEN THE ADDITIONAL "OCCLIM" CUTOFF WAS FOR
C                    ITWOBA=1 SWITCHED OFF ENTIRELY.  IN  ADDITION,  FOR
C                    ITWOBA=0, THE TREATMENT OF "NUQUVE" IN "QUABCS"  IS
C                    NOW  PERFORMED  INDEPENDENTLY  OF  "IPRGCM",  WHICH
C                    ENSURES A SMOOTH CONTINUATION BETWEEN THE RUNS WITH
C                    AND WITHOUT PROJECTION. THIS LATTER CORRECTION  MAY
C                    BECOME  RELEVANT  ONLY  IF  PROJECTIONS  COULD   BE
C                    PERFORMED WITHOUT THE TWO-BASIS METHOD.
C
C                13. BETWEEN VERSIONS (3.04Q) AND (3.16M), THE TREATMENT
C                    OF "NUQUVE" IN "HFBSIQ" WAS IMPLEMENTED  SO  AS  TO
C                    ENSURE AN EVEN TOTAL NUMBER  OF  STATES,  WITH  THE
C                    CASE OF ODD NUMBERS OF STATES IN BOTH PARITY BLOCKS
C                    LEFT TO BE ALLOWED. THAT CASE WAS  CAUSING  STRANGE
C                    WRONG RESULTS FOR THE PFAFFIAN NORMS OF AN  UNKNOWN
C                    ETIOLOGY. THIS BUG WAS CORRECTED ON  28/12/2022  IN
C                    VERSION (3.16N).
C
C                14. BETWEEN VERSIONS (2.50J) AND (3.18E),  THE  INDICES
C                    "IREVER" (THE THIRD INDICES) OF "BIG_PM" BELOW WERE
C                    ERRONOUSLY EXCHANGED. THIS BUG  WAS  AFFECTING  THE
C                    PROTON-NEUTRON-MIXING  CALCULATIONS  PERFORMED  FOR
C                    THE BROKEN SIMPLEX SYMMETRY. THIS BUG WAS FOUND  BY
C                    ADRIAN SANCHEZ AND CORRECTED IN VERSION (3.18F)  ON
C                    31/03/2023.
C
C                15. BETWEEN VERSIONS 3.04K AND  3.18U,  THE  TRUE-SPACE
C                    POSITIONS DEFINED IN  SUBROUTINE  "REVIEW"  IN  THE
C                    VARIABLES "POSIT." WERE INCORRECTLY DIVIDED BY  THE
C                    FACTOR OF SQRT(2), WHILE THIS  FACTOR  HAS  ALREADY
C                    BEEN INCLUDED IN ARRAYS  "FOURPT"  DEFINED IN ARRAY
C                    "PNTACT" OF SUBROUTINE "DEFINT" FOR NOBODY=2.  THIS
C                    BUG WAS CORRECTED IN VERSION 3.18V ON 19/05/2023.
C
C                16. BETWEEN VERSIONS (2.98B) AND (3.20S), FOR IPAKER=1,
C                    AND AFTER READING THE KERNEL FILES IN "PROANG", THE
C                    KERNEL ARRAYS WERE NOT ZEROED.  HOWEVER,  BEGINNING
C                    WITH VERSION (2.98B), THE KERNELS WERE NOT  DEFINED
C                    BUT ADDITIONALLY SUMMED UP, SO AS TO INTEGRATE OVER
C                    THE PARTICLE NUMBERS AND PARITY. AS A  RESULT,  FOR
C                    IPAKER=1, THEIR VALUES STORED AT M=1 AND  K=1  WERE
C                    ERRONOUSLY PILING UP. THIS BUG WENT UNDETECTED  FOR
C                    A LONG TIME BECAUSE FOR THE  IPAKER=1  CALCULATIONS
C                    PERFORMED FOR SEPARATE VALUES OF M AND K,  THE  BUG
C                    WAS NOT  SHOWING  UP.  THE  BUG  WAS  CORRECTED  ON
C                    28/10/2023 IN VERSION (3.20T).
C
C                17. BETWEEN VERSIONS (2.78H) AND (3.22S), BUT  ALSO  IN
C                    THE PUBLISHED VERSION (2.73Y), SUBROUTINE ZDOTU  IN
C                    MODULES  "HFODD_LIPCORR_NN.F90"  WAS  CALLED   WITH
C                    INCORRECT ARGUMENTS AND THUS  COULD  WORK  PROPERLY
C                    ONLY FOR LDBASE=NDBASE. THIS  BUG  WAS  ERRATICALLY
C                    CAUSING SEGMENTATION FAULT FOR CALCULATIONS DONE IN
C                    SUBROUTINES  "LINAVR"  AND  "ROTAVR"  BELOW.  AFTER
C                    REMOVING ALL CALLS TO ZDOTU, THIS BUG WAS CORRECTED
C                    ON  06/02/2024  IN  VERSION  (3.22T),  WHICH   USES
C                    MODULE HFODD_LIPCORR_53.F90.
C
C                18. BETWEEN VERSIONS (1.91Z) AND (3.27L), THAT IS, ALSO
C                    IN ALL PUBLISHED VERSIONS AFTER (1.75R), THERE  WAS
C                    A POSSIBLE CONFLICT IN READING THE  SPIN-CONSTRAINT
C                    DATA FOR THE Y DIRECTION  (KARTEZ=2)  AS  THE  SAME
C                    DATA WERE READ UNDER  TWO  DIFFERENT  KEYWORDS.  IN
C                    ADDITION, UNDER BOTH KEYWORDS, THE VALUES WERE READ
C                    INDEPENDENTLY OF WHETHER THE CONSTRAINT WAS  ACTIVE
C                    OR NOT. THOSE  INCONSISTENCIES  WERE  CORRECTED  ON
C                    20/07/2024  IN  VERSION  (3.27M)  BY  REMOVING  THE
C                    POSSIBILITY TO USE KEYWORDS SPINCONSTR & SPICON_XYZ
C                    FOR KARTEZ=2 SIMULTANEOUSLY.
C
C                19. BETWEEN VERSIONS (2.87C) AND (3.33),  THERE  WAS  A
C                    BUG IN SAVING ON THE REVIEW FILE THE NILSSON LABELS
C                    FOR NON-DOMINATING NILSSON COMPONENTS, SEE  KEYWORD
C                    "ALLNILABS"
C                    THIS BUG WAW CORRECTED  ON
C                    15/02/2025  IN  VERSION  (3.33A).
C
C                20. BETWEEN VERSIONS (2.87C) AND (3.33),  THERE  WAS  A
C                    BUG IN SAVING ON THE REVIEW FILE THE NILSSON LABELS
C                    FOR NON-DOMINATING NILSSON COMPONENTS, SEE  KEYWORD
C                    "ALLNILABS". THE BUG WAS  IN  SUBROUTINE  "NILASP",
C                    WHERE THOSE LABELS WERE  INCORRECTLY  STORED.  THIS
C                    BUG WAS CORRECTED ON 15/02/2025 IN VERSION (3.33A).
C=======================================================================
C
#if(USE_FITS==1)
      SUBROUTINE HF_ODD(PARINP,NUMINP,PAROUT,NUMOUT, JADRO_NAME,
     *                  I_TYPE, DAT_SUFFIX)
      USE HFODD_FITS
#else
      PROGRAM HF_ODD
#endif
C=======================================================================
#if(USE_OPENMP==1)
      USE omp_lib
#endif
C=======================================================================
#if(USE_MPI==1)
      USE hfodd_mpiio
      USE hfodd_mpiManager
#endif
C=======================================================================
      USE hfodd_sizes
      USE HE_DEN
      USE FRAGFL
      USE WAVR_L
      USE SAVRIG
      USE hfodd_interface
      USE hfodd_hfbtho
      USE hfodd_fission_fragments
      USE hfodd_fission_interaction
      USE hfodd_fission_rotated_qp
      USE hfodd_fission_print
      USE hfodd_fission_version
      USE hfodd_pnp
      USE hfodd_tgrad
      USE hfodd_twocen
      USE BLOSAV
      USE colcoord
C=======================================================================
      PARAMETER (NDMORD=3)
      PARAMETER (NDF2BC=5)
      PARAMETER (NDFANL=2)
      PARAMETER (NDFSTA=3)
C=======================================================================
#if(USE_SCALAPACK==1)
      USE hfodd_SLsiz
#endif
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL(A-H,O-Z)
C=======================================================================
C
      CHARACTER
     *          SKYRME*4,GOGNAM*4,VERSIO*5
      CHARACTER
     *          FILREP*68,FILREC*68,FILWOO*68,
     *          FILREV*68,FILCOU*68,FILISO*68,FILWAV*68,FILKER*68,
     *          FILYUP*68,FILYUC*68,
     *          FILGOP*68,FILGOC*68,
     *          FILGPP*68,FILGPC*68,
     *          FILROP*68,FILROC*68,
     *          FILLIP*68,FILLIC*68,
     *          FILFIP*68,FILFIC*68,
     *          FILFER*68,FILQUA*68,
     *          FILBAP*68,FILBAC*68,
     *          FILRED*68
      CHARACTER
     *          NAMMUL*45,NAMSIF*45,NAMSUR*45,NAMSCH*45,
     *          NAMPLM*45,NAMMAG*45,NAMASM*45
      CHARACTER
     *          NAMHAR*17,NAMSHI*17,NAMROT*17
      CHARACTER
     *          NAMEPN*8
      CHARACTER
     *          SPMODL*14,ANGLEC*8,ESTABC*12,QROT2C*8
      CHARACTER
     *          MYDATE*8,MYTIME*10,MYZONE*5
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
      CHARACTER
     *          FILTHO*30
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C
      LOGICAL
     *          PRINIT,PRIYUK,PRIBET
      LOGICAL
     *          TERMNT,COR_CM,CORROT
      LOGICAL
     *          DOPUSH,DOSYMM,do_debug,name_file,do_symmetrize
      LOGICAL
     *          REA2PP
C
      COMPLEX
     *          ALPHAC(0:NDLAMB,-NDLAMB:+NDLAMB)
      COMPLEX
     *          EKEKIN,EKEPAI,EKESKY,EKECOD,EKECOE,EKESCA,EKEVEC,EKEGOG,
     *          EKEREG,EKESEP,EKPSCA,EKPVEC,EKEFSO,EKEFTO,EKEFTE
      COMPLEX
     *          QMUT_N,QMUT_P,QMUT_T
      COMPLEX
     *          AMUT_N,AMUT_P,AMUT_T
      COMPLEX
     *          SMUT_N,SMUT_P,SMUT_T
      COMPLEX
     *          WMUT_N,WMUT_P,WMUT_T
      COMPLEX
     *          A2BCIN,A2BCSA
      COMPLEX
     *          ANLJSQ,ANLTOT
      COMPLEX
     *          QMUT_I
      COMPLEX
     *          CERMTS,CHRMTS,CDHRMT
      COMPLEX
     *          DKINSN,DKINSP,DKINST,
     *          EKINSN,EKINSP,EKINST,
     *          PKINSN,PKINSP,PKINST,
     *          TKINSN,TKINSP,TKINST,
     *          AKINLN,AKINLP,AKINLT,
     *          PKINLN,PKINLP,PKINLT,
     *          PKINKN,PKINKP,PKINKT
      COMPLEX
     *          DKOTSN,DKOTSP,DKOTST,
     *          EKOTSN,EKOTSP,EKOTST,
     *          PKOTSN,PKOTSP,PKOTST,
     *          TKOTSN,TKOTSP,TKOTST,
     *          AKOTLN,AKOTLP,AKOTLT,
     *          PKOTLN,PKOTLP,PKOTLT,
     *          PKOTKN,PKOTKP,PKOTKT
      COMPLEX
     *          EGOGSP,EGOGVP
      COMPLEX
     *          EREGSP,EREGVP
      COMPLEX
     *          ESEPSP,ESEPVP
      COMPLEX
     *          EFSOSP,EFTOSP,EFTESP
      COMPLEX
     *          E3BEVE,E3BODD
      COMPLEX
     *          E4BEVE,E4BODD
      COMPLEX
     *          FR2CBR,FS2CBR,FR3CBR,FS3CBR,
     *          FT2CBR,FK2CBR,FT3CBR,FK3CBR,
     *          FL2CBR,FP2CBR,FL3CBR,FP3CBR,
     *          FC2CBR,FJ2CBR,FC3CBR,FJ3CBR
      COMPLEX
     *          F_KT_L,F_KT_R,C_KT_L
      COMPLEX
     *          C_ZERO
C
      DIMENSION
     *          QMUT_I(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          QMUL_I(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          MYVALU(8)
      DIMENSION
     *          IN_EXC(ND_EXC)
      DIMENSION
     *          Q_COPY(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          QACTUA(0:NDMULT,-NDMULT:NDMULT),
     *          QORIGI(0:NDMULT,-NDMULT:NDMULT),
     *          QINCRE(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          IND2HF(0:NDISOS)
      DIMENSION
     *          INSIZN(1:NDBLOC),IDSIZN(1:NDBLOC),
     *          INSIZP(1:NDBLOC),IDSIZP(1:NDBLOC)
      DIMENSION
     *          INSIQN(1:NDBLOC),IPSIQN(1:NDBLOC),IDSIQN(1:NDBLOC),
     *          INSIQP(1:NDBLOC),IPSIQP(1:NDBLOC),IDSIQP(1:NDBLOC)
      DIMENSION
     *          INMIZA(1:NDBLOC),IDMIZA(1:NDBLOC)
      DIMENSION
     *          INMIQA(1:NDBLOC),IPMIQA(1:NDBLOC),IDMIQA(1:NDBLOC)
      DIMENSION
     *          IREMQB(1:NDBLOC),INUMQB(1:NDBLOC),JNUMQB(1:NDBLOC)
      DIMENSION
     *          KPAHFB(0:NDISOS)
C=======================================================================
      allocatable SFACTO(:,:)
C=======================================================================
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
      DIMENSION
     *          IZNUCL(1:NDNUCL),INNUCL(1:NDNUCL)
      DIMENSION
     *          DSHELP(1:NDNUCL),DSHELN(1:NDNUCL)
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
      Logical :: initial_pair_THO, set_temper_THO, force_parity_THO,
     *           HFODD_to_HFBTHO
C
      Integer :: Nshell_THO, neutron_THO, proton_THO, type_THO,
     *           niter_THO, restart_THO, coulomb_THO, useTHO_THO,
     *           gauge_THO, projection_THO, dN_THO, dZ_THO, output_THO,
     *           numGauss_THO, numLaguerre_THO, numLegendre_THO,
     *           nstate_THO, unit_tho
      Integer :: n_blocking_THO(1:5), p_blocking_THO(1:5),
     *           lambda_THO(1:8), active_THO(1:8)
C
      Real :: b0_THO, bz_THO, bp_THO, beta0_THO,
     *        accuracy_THO, VpairN_THO, VpairP_THO,
     *        temper_THO, b2_THO, b4_THO, Ecut_THO,
     *        V1_THO
      Real :: expect_THO(1:8), multLag_tho(1:8)
C
      Character(Len=30) :: functional_THO
C
      Character(Len=30) :: file_THO
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C@@@ OPENMP - OPENMP - OPENMP - OPENMP - OPENMP - OPENMP - OPENMP
#if(USE_OPENMP==1)
      integer :: numThreads
#endif
C@@@ OPENMP - OPENMP - OPENMP - OPENMP - OPENMP - OPENMP - OPENMP
C=======================================================================
C@@@ MPI - MPI - MPI - MPI - MPI - MPI - MPI - MPI - MPI - MPI - MPI
C
      integer, dimension(:), pointer :: LAMPUS, MIUPUS
C
      REAL, dimension(:), pointer :: QMOPUS
C
      integer, dimension(:), pointer :: LAM_WS, MIU_WS
      integer, dimension(:), pointer :: L_COLL, M_COLL
C
#if(USE_MPI==1)
      integer :: mpi_err, n_proc, mpi_activ
      integer :: color, intkey, printTopology
      integer :: escapeSignal
      integer :: batch_init
C
      integer :: worldGroup, groupMasters, mastersCOMM,
     *                       groupSlaves, slavesCOMM, tribeCOMM
      integer :: tribeRank, slaveRank, masterRank, worldRank
      integer :: tribeSize, slaveSize, masterSize, worldSize
      integer :: counter_eval, syst_cnt, syst_rate
C
      integer, dimension(:), pointer :: LAMBAS, MIUBAS
C
      integer, dimension(:), allocatable :: my_evals, all_evals
      integer, dimension(:), allocatable :: rankMasters
#if(USE_SCALAPACK==1)
      integer :: n_tribe, n_color
      integer, dimension(:), allocatable :: all_tribeRank, all_color,
     *                                      all_worldRank
#endif
C
      Real :: cput_start, cput_end, syst_start, syst_end
      Real, dimension(:), allocatable ::
     *                  my_cputime, all_cputimes
C
      Real, dimension(:), pointer :: BETBAS
C
      character(len=16) :: FILOUT
      character(len=18) :: filsum
      character(len=68) :: optimal, courant
      character(len=150) :: commande
C
      COMMON
     *       /MPICOM/ worldGroup, groupMasters, groupSlaves,
     *                mastersCOMM, slavesCOMM, tribeCOMM
      COMMON
     *       /MPIPRO/ numberMasters, numberHFODDproc, color,
     *                tribeRank, slaveRank, masterRank, worldRank,
     *                tribeSize, slaveSize, masterSize, worldSize
#endif
C@@@  - MPI - MPI - MPI - MPI - MPI - MPI - MPI - MPI - MPI - MPI
C=======================================================================
C
#if(USE_FITS==1)
      DIMENSION :: PARINP(NUMINP),PAROUT(NUMOUT)
      CHARACTER :: JADRO_NAME*5
      CHARACTER :: DAT_SUFFIX*7
      INTEGER :: I_TYPE
#endif
      DIMENSION
     *          GOG_SD(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_VD(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_SE(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_VE(NDGOGA,0:NDISOS,0:NDISOS)
      COMMON
     *       /GOGFOR/ GOGSTR(NDGOGA,NDFORC),GOGWID(NDGOGA),NUGOGA
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /HERSTO/ HERMTS(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /HERMEM/ HERONE(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /DIVSTO/ DHRMTS(0:ND2MAX,1:NDGAUS,1:NDKART),
     *                DDHRMT(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /DIVMEM/ DHRONE(0:ND2MAX,1:NDGAUS,1:NDKART),
     *                DDHONE(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /HERCOM/ CERMTS(0:ND2MAX,1:NDGAUS,1:NDKART),
     *                CHRMTS(0:ND2MAX,1:NDGAUS,1:NDKART),
     *                CDHRMT(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /INTMEM/ TWOWGT(1:NDGAUS,1:NDKART),
     *                TWOPNT(1:NDGAUS,1:NDKART)
      COMMON
     *       /RMSRAD/ RADI_N(0:NDKART),
     *                RADI_P(0:NDKART),
     *                RADI_T(0:NDKART)
      COMMON
     *       /RMSRAH/ RMSRAN(1:NDMORD),
     *                RMSRAP(1:NDMORD),
     *                RMSRAT(1:NDMORD)
      COMMON
     *       /RMSSHI/ RSHI_N(0:NDKART),
     *                RSHI_P(0:NDKART),
     *                RSHI_T(0:NDKART)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /FRAMUL/ QLMNEU(0:NDMULT,-NDMULT:NDMULT,0:1),
     *                QLMPRO(0:NDMULT,-NDMULT:NDMULT,0:1),
     *                QLMTOT(0:NDMULT,-NDMULT:NDMULT,0:1)
      COMMON
     *       /FRAORI/ QORNEU(0:NDMULT,-NDMULT:NDMULT,0:1),
     *                QORPRO(0:NDMULT,-NDMULT:NDMULT,0:1),
     *                QORTOT(0:NDMULT,-NDMULT:NDMULT,0:1)
      COMMON
     *       /QMUTTI/ QMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BMULTI/ BMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                BMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                BMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMUTTI/ SMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /PMULTI/ PMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                PMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                PMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VMULTI/ VMUL_N(0:NDMULT,-NDMULT:NDMULT,1:NDKART),
     *                VMUL_P(0:NDMULT,-NDMULT:NDMULT,1:NDKART),
     *                VMUL_T(0:NDMULT,-NDMULT:NDMULT,1:NDKART)
      COMMON
     *       /QSHIFT/ QSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BSHIFT/ BSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                BSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                BSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SSHIFT/ SSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                SSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                SSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QROTAT/ QROT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QROT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QROT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BROTAT/ BROT_N(0:NDMULT,-NDMULT:NDMULT),
     *                BROT_P(0:NDMULT,-NDMULT:NDMULT),
     *                BROT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SROTAT/ SROTNN(0:NDMULT,-NDMULT:NDMULT),
     *                SROTNP(0:NDMULT,-NDMULT:NDMULT),
     *                SROTNT(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /AROTAT/ AROTNN(0:NDMULT,-NDMULT:NDMULT),
     *                AROTNP(0:NDMULT,-NDMULT:NDMULT),
     *                AROTNT(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /AROTXX/ AROTXN(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AROTXP(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AROTXT(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /AMUTTI/ AMUT_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUT_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUT_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /AMULTI/ AMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /ASHIFT/ ASHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                ASHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                ASHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ASHIXX/ ASHIXN(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                ASHIXP(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                ASHIXT(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /WMUTTI/ WMUT_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUT_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUT_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /WMULTI/ WMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /A2BCTI/ A2BCIN(-1:+1),A2BCSA(-1:+1)
      COMMON
     *       /ANLDIP/ ANLJSQ(-1:+1,NDFANL),ANLTOT(-1:+1)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /RLASTR/ RALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                RALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                RALMUV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /JLASTR/ RALSPI(1:NDKART)
      COMMON
     *       /ULASTR/ RALISO(1:NDKART)
      COMMON
     *       /TSTQPR/ ISQPRO
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /SIFUNI/ SUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /CONVER/ ETOTFI(1:NDITER+1),ETOTSI(1:NDITER+1),
     *                                   ESTABI(1:NDITER+1),
     *                QUA20I(1:NDITER+1),QUA22I(1:NDITER+1),
     *                ANGUTI(1:NDITER+1)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /ANGSPI/ SPIN_N(1:NDKART),SPIN_P(1:NDKART),SPIN_T(1:NDKART)
      COMMON
     *       /LINMOM/ DLINSN(0:NDKART),DLINSP(0:NDKART),DLINST(0:NDKART)
     *               ,ELINSN(0:NDKART),ELINSP(0:NDKART),ELINST(0:NDKART)
     *               ,TLINSN(0:NDKART),TLINSP(0:NDKART),TLINST(0:NDKART)
     *               ,ALINLN(0:NDKART),ALINLP(0:NDKART),ALINLT(0:NDKART)
      COMMON
     *       /KINMOM/ DKINSN(0:NDKART),DKINSP(0:NDKART),DKINST(0:NDKART)
     *               ,EKINSN(0:NDKART),EKINSP(0:NDKART),EKINST(0:NDKART)
     *               ,TKINSN(0:NDKART),TKINSP(0:NDKART),TKINST(0:NDKART)
     *               ,AKINLN(0:NDKART),AKINLP(0:NDKART),AKINLT(0:NDKART)
      COMMON
     *       /LINPAI/ PLINSN(0:NDKART),PLINSP(0:NDKART),PLINST(0:NDKART)
     *               ,PLINLN(0:NDKART),PLINLP(0:NDKART),PLINLT(0:NDKART)
     *               ,PLINKN(0:NDKART),PLINKP(0:NDKART),PLINKT(0:NDKART)
      COMMON
     *       /KINPAI/ PKINSN(0:NDKART),PKINSP(0:NDKART),PKINST(0:NDKART)
     *               ,PKINLN(0:NDKART),PKINLP(0:NDKART),PKINLT(0:NDKART)
     *               ,PKINKN(0:NDKART),PKINKP(0:NDKART),PKINKT(0:NDKART)
      COMMON
     *       /ROTMOM/ DROTSN(0:NDKART),DROTSP(0:NDKART),DROTST(0:NDKART)
     *               ,EROTSN(0:NDKART),EROTSP(0:NDKART),EROTST(0:NDKART)
     *               ,TROTSN(0:NDKART),TROTSP(0:NDKART),TROTST(0:NDKART)
     *               ,AROTLN(0:NDKART),AROTLP(0:NDKART),AROTLT(0:NDKART)
      COMMON
     *       /KOTMOM/ DKOTSN(0:NDKART),DKOTSP(0:NDKART),DKOTST(0:NDKART)
     *               ,EKOTSN(0:NDKART),EKOTSP(0:NDKART),EKOTST(0:NDKART)
     *               ,TKOTSN(0:NDKART),TKOTSP(0:NDKART),TKOTST(0:NDKART)
     *               ,AKOTLN(0:NDKART),AKOTLP(0:NDKART),AKOTLT(0:NDKART)
      COMMON
     *       /ROTPAI/ PROTSN(0:NDKART),PROTSP(0:NDKART),PROTST(0:NDKART)
     *               ,PROTLN(0:NDKART),PROTLP(0:NDKART),PROTLT(0:NDKART)
     *               ,PROTKN(0:NDKART),PROTKP(0:NDKART),PROTKT(0:NDKART)
      COMMON
     *       /KOTPAI/ PKOTSN(0:NDKART),PKOTSP(0:NDKART),PKOTST(0:NDKART)
     *               ,PKOTLN(0:NDKART),PKOTLP(0:NDKART),PKOTLT(0:NDKART)
     *               ,PKOTKN(0:NDKART),PKOTKP(0:NDKART),PKOTKT(0:NDKART)
      COMMON
     *       /SHIANG/ ANGS_N(1:NDKART),ANGS_P(1:NDKART),ANGS_T(1:NDKART)
      COMMON
     *       /ROTANG/ ANGR_N(1:NDKART),ANGR_P(1:NDKART),ANGR_T(1:NDKART)
      COMMON
     *       /ROTSPI/ SPIR_N(1:NDKART),SPIR_P(1:NDKART),SPIR_T(1:NDKART)
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
     *       /DATPAA/               EFERMA,DELTAA
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /CCPRHD/ PRHD_N,PRHDDN,PRHDSN,POWDRN,
     *                PRHD_P,PRHDDP,PRHDSP,POWDRP
      COMMON
     *       /PAIINI/ FERINI(0:NDISOS),DELINI(0:NDISOS),FE2INI(0:NDISOS)
      COMMON
     *       /ISOFER/ FERISO(0:NDKART)
      COMMON
     *       /MOVFER/ FERMOV(0:NDKART)
      COMMON
     *       /ISOTOT/ TOTISO(0:NDKART),TOTIS2(0:NDKART)
      COMMON
     *       /ISOFE_/ FE_RAD,FE_THE,FE_PHI,FE_OFF
      COMMON
     *       /ALLENE/ EKIN_N,EKIN_P,EKIN_T,
     *                EPOT_N,EPOT_P,EPOT_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *                EREA_N,EREA_P,EREA_T,
     *                ELIP_N,ELIP_P,ELIP_T,
     *
     *                ECOULD,ECOULE,ECOULT,
     *                       ECOULS,ECOULV,
     *
     *                EMULCO,EMUSLO,EMUREA,
     *                ESIFCO,ESISLO,ESIREA,
     *                ESPICO,ESPSLO,ESPREA,
     *
     *                ENREAR,ECORCM,ECOR_R,
     *
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
      COMMON
     *       /ISOENE/ EISOCO,EISSLO,EISREA
      COMMON
     *       /EYUKTT/ EYUKDT,EYUKD0,EYUKD1,EYUKD2,
     *                EYUKET,EYUKE0,EYUKE1,EYUKE2
      COMMON
     *       /EGOGTT/ EGOGDT,EGOGET
      COMMON
     *       /PN_GOG/ EGOGSP(0:NDISOS),EGOGVP(0:NDISOS)
      COMMON
     *       /EREGTT/ EREGDT,EREGET
      COMMON
     *       /ESEPTT/ ESEPDT,ESEPET
      COMMON
     *       /EFSOTT/ EFSODT,EFSOET
      COMMON
     *       /EFTOTT/ EFTODT,EFTOET
      COMMON
     *       /EFTETT/ EFTEDT,EFTEET
      COMMON
     *       /PN_REG/ EREGSP(0:NDISOS),EREGVP(0:NDISOS)
      COMMON
     *       /PN_SEP/ ESEPSP(0:NDISOS),ESEPVP(0:NDISOS)
      COMMON
     *       /PN_COU/ EKPSCA,EKPVEC
      COMMON
     *       /PN_FST/ EFSOSP(0:NDISOS),EFTOSP(0:NDISOS),EFTESP(0:NDISOS)
      COMMON
     *       /ITERTS/ ITESTA,ITESTO,NOITER,NUMITE
      COMMON
     *       /IPRITE/ PRINIT
      COMMON
     *       /SIZNVA/ NVASIZ(0:NDISOS)
      COMMON
     *       /SIZMVA/ MVASIZ(0:NDISOS)
      COMMON
     *       /SIZKVA/ KVASIZ(                  0:NDISOS)
      COMMON
     *       /MIZNVA/ NVAMIZ
      COMMON
     *       /N_FLIG/ NPFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFLIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIM/ NPFLIM(         0:NDREVE,0:NDISOS),
     *                NHFLIM(         0:NDREVE,0:NDISOS),
     *                NOFLIM(         0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIQ/ NPFLIQ(0:NDPARI,         0:NDISOS),
     *                NHFLIQ(0:NDPARI,         0:NDISOS),
     *                NOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /N_FLIZ/ NPFLIZ(                  0:NDISOS),
     *                NHFLIZ(                  0:NDISOS),
     *                NOFLIZ(                  0:NDISOS)
      COMMON
     *       /N_MLIG/ NPMLIG(0:NDPARI,0:NDREVE),
     *                NHMLIG(0:NDPARI,0:NDREVE),
     *                NOMLIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MLIM/ NPMLIM(0:NDREVE),
     *                NHMLIM(0:NDREVE),
     *                NOMLIM(0:NDREVE)
      COMMON
     *       /N_MLIQ/ NPMLIQ(0:NDPARI),
     *                NHMLIQ(0:NDPARI),
     *                NOMLIQ(0:NDPARI)
      COMMON
     *       /N_MLIZ/ NPMLIZ,
     *                NHMLIZ,
     *                NOMLIZ
      COMMON
     *       /OMEGAS/ OMEGAX,OMEGAY,OMEGAZ
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /EANGLE/ ALPEUL,BETEUL,GAMEUL
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /ETHREE/ E3BEVE,E3BODD
      COMMON
     *       /ETHRGR/ ETGRAF,ETGRAP
      COMMON
     *       /EFOURB/ E4BEVE,E4BODD
      COMMON
     *       /PAIBOD/ EPAI3N,EPAI3P,EPAI4N,EPAI4P
      COMMON
     *       /RENORM/ HBMREN(NDKART)
      COMMON
     *       /RENROT/ ROTREN(NDKART)
      COMMON
     *       /RINORM/ HBMRIN(NDKART)
      COMMON
     *       /RINROT/ ROTRIN(NDKART)
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMIX/ ALPHAM,BROTRI
     *       /BROMAT/ NOIINP,MIXMAT
      COMMON
     *       /HEREPS/ EPSHER
      COMMON
     *       /CFIREA/ NFIREA
      COMMON
     *       /CFIPRI/ NFIPRI
C@@@ MULTIPOLE - MULTIPOLE - MULTIPOLE - MULTIPOLE
      COMMON
     *       /CNSOLD/ VECOLD(1:NDCONS)
      COMMON
     *       /CNSCOR/ LAMCNS(1:NDCONS),MIUCNS(1:NDCONS)
     *       /CNSNUM/ NOFCNS
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /READAL/ ALPHRE(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
C@@@ MULTIPOLE - MULTIPOLE - MULTIPOLE - MULTIPOLE
C SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL
      COMMON
     *       /SCALAPACK_INP/ NBLOCK,MBLOCK,NPGRID,MPGRID,KZHPEV
C SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /STRUTI_PARAMS/ GSTRUN,GSTRUP,HOMFAC,EPSRTN
     *       /STRUTI_POLYNO/ NPOLYN
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /T_FLAG/ IFTEMP
      COMMON
     *       /GCTEMP/ TEMP_T
      COMMON
     *       /SENTRO/ ENTRPY(0:NDISOS)
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
     *       /NCKFLA/ IFNECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /FRASYM/ DOSYMM,do_symmetrize
      COMMON
     *       /DEFORM/ ALPHAC,IREALA
      COMMON
     *       /AUTOBA/ IBASIS
      COMMON
     *       /EDFINP/ IF_EDF
     *       /EDFPAR/ V0NEFF,V0PEFF,COUSCA
      COMMON
     *       /MINDEF/ LAMINP(1:NDSEAR),MIUINP(1:NDSEAR)
     *       /MINLIM/ NUMINP,LMXINP,ITEINP
     *       /MINSTP/ STPINP
      COMMON
     *       /HFMEAN/ IHFPOT
#if(USE_MPI==1)
      COMMON
     *       /SIGNAL/ escapeSignal
      COMMON
     *       /OUTPUT/ nfisum
#endif
C
C=======================================================================
CXIAOBAO added for Lipkin method of particle number restoration.
C=======================================================================
C
      REAL
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
      COMMON
     *       /LIPLAM/
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
      REAL
     *       ELIP2N,ELIP2P,ELIP4N,ELIP4P,ELIP6N,ELIP6P,
     *       ELAM4N,ELAM6N,ELAM4P,ELAM6P
      COMMON
     *       /LIPADE/
     *       ELIP2N,ELIP2P,ELIP4N,ELIP4P,ELIP6N,ELIP6P,
     *       ELAM4N,ELAM6N,ELAM4P,ELAM6P
C
      INTEGER,PARAMETER :: NODGAU = 1000
      COMPLEX
     *        RLIPNU,NLIPNU
      COMMON
     *       /LIPNUM/
     *          RLIPNU(0:6,0:NODGAU,0:NDISOS),
     *          NLIPNU(0:6,0:NODGAU,0:NDISOS)
C
      COMMON
     *       /FC_CBR/ FR2CBR,FS2CBR,FR3CBR,FS3CBR,
     *                FT2CBR,FK2CBR,FT3CBR,FK3CBR,
     *                FL2CBR,FP2CBR,FL3CBR,FP3CBR,
     *                FC2CBR,FJ2CBR,FC3CBR,FJ3CBR
      COMMON
     *       /FERMIL/ F_KT_L(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_L,IDIM_L,IIFERL,ITFERL,ISFERL
      COMMON
     *       /FERMIR/ F_KT_R(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_R,IDIM_R,IIFERR,ITFERR,ISFERR
      COMMON
     *       /FERMLL/ C_KT_L(-NDPROI:NDPROI,NDPROT,NDCONF),
     *                EIGINI(NDCONF),MIXIND(NDCONF,2)
      COMMON
     *       /ISDLIP/ IS_DLI(0:NDISOS)
      COMMON
     *       /AXILIZ/ NOSCIL,IF_THO,IAXIAP
      COMMON
     *       /ASYPAI/ KAPASY
      COMMON
     *       /SEPDON/ ISEPDO(NDKART,NDSEGA,NDSEGA)
      COMMON
     *       /SEPBIN/ SEPVIC(NDSEPA,NDFORC),IVISEP
      COMMON
     *       /SEPVER/ SEPERR(NDSEPA,NDFORC),IERSEP
      COMMON
     *       /SEPFAC/ SEPFAC(NDSEPA,NDFORC),IFASEP
      COMMON
     *       /SEPVIN/ SEPVCC(NDSEPA,NDFORC),IRESEP
      COMMON
     *       /SEPTIN/ SEPTCC(NDSEPA,NDFORC)
      COMMON
     *       /SKYDAT/ T0_DAT,X0_DAT,T1_DAT,X1_DAT,T2_DAT,X2_DAT,
     *                T3_DAT,X3_DAT,WW_DAT,PO_DAT
      COMMON
     *       /SKYERR/ T0_ERR,X0_ERR,T1_ERR,X1_ERR,T2_ERR,X2_ERR,
     *                T3_ERR,X3_ERR,WW_ERR,PO_ERR
      COMMON
     *       /SKYFAC/ T0_FAC,X0_FAC,T1_FAC,X1_FAC,T2_FAC,X2_FAC,
     *                T3_FAC,X3_FAC,WW_FAC,PO_FAC
      COMMON
     *       /SKYINP/ T0_INP,X0_INP,T1_INP,X1_INP,T2_INP,X2_INP,
     *                T3_INP,X3_INP,WW_INP,PO_INP
      COMMON
     *       /JPA2HF/ DEL2HF(0:NDISOS),IPA2HF(0:NDISOS)
      COMMON
     *       /IDENTU/ IDENSU,JDENSU
      COMMON
     *       /LIMITL/ LAMMAX,NMUCON
      COMMON
     *       /ALLAST/ LASTAL(0:NDISOS)
      COMMON
     *       /REGPAR/ REGWID
      COMMON
     *       /REJVIN/ REJVCC(NDREGA,NDFORC)
      COMMON
     *       /REJVER/ REJERR(NDREGA,NDFORC)
      COMMON
     *       /REJVAC/ REJFAC(NDREGA,NDFORC)
      COMMON
     *       /REJTIN/ REJTCC(NDREGA,NDFORC)
      COMMON
     *       /JREJAL/ IREREJ(4),NREREJ(4)
      COMMON
     *       /REGBIN/ REGBCC(NDREGA,NDFORC),IREREG
      COMMON
     *       /REGVIN/ REGVCC(NDREGA,NDFORC)
      COMMON
     *       /REGTIN/ REGTCC(NDREGA,NDFORC)
      COMMON
     *       /COLMIX/ MIXCOL(0:NDPROI,0:NDISOM,NDCONF)
      COMMON
     *       /GYROSC/ GYRORP,GYRSPN,GYRSPP,IGYROS
      COMMON
     *       /GEFACT/ GESPIN(0:NDISOS),GEORBI(0:NDISOS)
      COMMON
     *       /G_FACT/ G_SPIN(0:NDISOS),G_ORBI(0:NDISOS)
      COMMON
     *      /danelip/ LIPKIP,LIPKIN
C
C=======================================================================
C
      DATA
     *       NAMMUL /'MULTIPOLE MOMENTS [UNITS:  (10 FERMI)^LAMBDA]'/,
     *       NAMSUR /'SURFACE MOMENTS, UNITS: (10 FERMI)^(LAMBDA+2)'/,
     *       NAMSCH /'SCHIFF MOMENTS,  UNITS: (10 FERMI)^(LAMBDA+2)'/,
     *       NAMPLM /'PENSURFACE MOMENTS, IN: (10 FERMI)^(LAMBDA+4)'/,
     *       NAMMAG /'MAGNETIC MOMENTS      [MGNT*FERMI^(LAMBDA-1)]'/,
     *       NAMASM /'SPIN-ASYMMETRY MOMNTS [HBAR*FERMI^(LAMBDA+1)]'/
      DATA
     *       NAMHAR /'                 '/,
     *       NAMSHI /'[CENT-MASS FRAME]'/,
     *       NAMROT /'[INTRINSIC FRAME]'/
C
      CHARACTER
     *          NAMODU*16,NAMMOD*16
      COMMON
     *       /LIMODU/ MODORD(NDMODU),NAMODU(NDMODU),MODVER(NDMODU),
     *                MODTOT
      COMMON
     *       /VERMOD/ NAMMOD(NDMODU),MODUVE(NDMODU),MODSET(NDMODU)
      COMMON
     *       /PARFIX/ ISIQTY
      COMMON
     *       /POWNMU/ NMUPOW
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /CENPOS/ CENCOR(1:NDKART,1:NDTWCE)
      COMMON
     *      /HERMIN/  INTWHE(1:NDTWCE,1:NDTWCE,1:NDTWCE,1:NDTWCE)
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *      /INFAST/  IDCOPY(1:NDTWDD,0:1),IDCOCO(1:NDTWDD,0:1)
      COMMON
     *       /FRCONS/ FRGSTF(0:NDISOS,1:NDTWCE),
     *                FRGASK(0:NDISOS,1:NDTWCE),
     *                IFLFRG(0:NDISOS,1:NDTWCE),
     *                CLMFRA(0:NDISOS,1:NDTWCE),
     *                AVEFRA(0:NDISOS,1:NDTWCE)
      COMMON
     *       /QMUTWC/ QFRA_N(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QFRA_P(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QFRA_T(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
      COMMON
     *       /QTWCNS/ STQTWC(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QTWCAS(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                IFLQTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                GALMTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
C     -- USED IN ATDHF CALCULATION --
      COMMON
     *       /SWSING/ I_SING
C     -- USED IN ATDHF CALCULATION --
      COMMON
     *       /PHYPIO/ PIMASS,G_AXIC,PIDECA
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /FORANL/ MAGANL(NDFANL)
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /TOMOPI/ ITOMOZ,IOBSCH,IDESCH,INDENS
C
C=======================================================================
C      UPON REQUEST, INITIALIZING THE MPI ENVIRONMENT AND SETTING UP
C      MPI GROUP STRUCTURE
C=======================================================================
C
      do_debug = .False.
C
#if(USE_MPI==1)
      call mpi_init(mpi_err)
      call mpi_comm_size(MPI_COMM_WORLD, worldSize, mpi_err)
      call mpi_comm_rank(MPI_COMM_WORLD, worldRank, mpi_err)
C
      nofpro = worldSize
C
      allocate(my_cputime(0:0), my_evals(0:0))
      if (worldRank == 0 ) then
          allocate(all_cputimes(0:worldSize-1),
     *                all_evals(0:worldSize-1))
C
          nfisum=89
          write(filsum,'(''hf256a_summary.txt'')')
C
          open(nfisum,file=filsum,status='unknown',form='formatted')
C
      else
          allocate(all_cputimes(0:0), all_evals(0:0))
      end if
C
      ! Record system and CPU starting times
      call system_clock(syst_cnt, syst_rate)
C
      syst_start = real(syst_cnt)
     *           / real(syst_rate)
C
      call cpu_time(cput_start)
C
      printTopology = 0
      counter_eval = 0
      iprint = 1
C
      numberHFODDproc = 1
C
      ! Attention: M_GRID and N_GRID below are passed through pre-processor
      !            not by standard NAMELI routine. This is because we need
      !            them even before we call NAMELI (or its likes)
#if(USE_SCALAPACK==1)
      numberHFODDproc = M_GRID * N_GRID
      NPGRID = N_GRID
      MPGRID = M_GRID
#endif
C
      n_proc = worldRank
      numberMasters = worldSize / numberHFODDproc
C
      ! Get handle on world group
      call mpi_comm_group(MPI_COMM_WORLD, worldGroup, mpi_err)
C
      ! Define the rank of the masters
      allocate(rankMasters(0:(numberMasters-1)))
C
      do ii = 0, numberMasters - 1
         rankMasters(ii) = ii
      end do
C
      ! Define new group of masters: the oligarchy
      call mpi_group_incl(worldGroup, numberMasters, rankMasters,
     *                                     groupMasters, mpi_err)
      call mpi_comm_create(MPI_COMM_WORLD, groupMasters,
     *                             mastersCOMM, mpi_err)
C
      ! Everybody else is a stupid slave
      if (numberHFODDproc > 1) then
          call mpi_group_excl(worldGroup, numberMasters, rankMasters,
     *                                          groupSlaves, mpi_err)
          call mpi_comm_create(MPI_COMM_WORLD, groupSlaves,
     *                             slavesCOMM, mpi_err)
      end if
C
      ! Second grouping: define tribes of slaves associated with every
      ! oligarch. Since they are many such groups (as many as masters),
      ! and they all have the same size, it is simpler to just split
      ! the communicator into many sub-communicators
C
      color = mod(worldRank, numberMasters)
      intkey = worldRank
C
      call mpi_comm_split(MPI_COMM_WORLD, color, intkey, tribeCOMM,
     *                                                     mpi_err)
C
      call mpi_comm_rank(tribeCOMM, tribeRank, mpi_err)
C
#if(USE_SCALAPACK==1)
C
      allocate(all_tribeRank(0:(worldSize-1)))
      allocate(all_color(0:(worldSize-1)))
      allocate(all_worldRank(0:(worldSize-1)))
C
      call MPI_Allgather(tribeRank, 1, MPI_INTEGER, all_tribeRank, 1,
     *                                 MPI_INTEGER,
     *                                 MPI_COMM_WORLD, mpi_err)
C
      call MPI_Allgather(color, 1, MPI_INTEGER, all_color, 1,
     *                             MPI_INTEGER,
     *                             MPI_COMM_WORLD, mpi_err)
C
      call MPI_Allgather(worldRank, 1, MPI_INTEGER, all_worldRank, 1,
     *                                 MPI_INTEGER,
     *                                 MPI_COMM_WORLD, mpi_err)
C
      allocate(rankTribe(0:(numberHFODDproc-1),
     *                     0:(numberMasters-1)))
C
      do n_proc = 0, worldSize - 1
         n_tribe = all_tribeRank(n_proc)
         n_color = all_color(n_proc)
         rankTribe(n_tribe, n_color) = all_worldRank(n_proc)
      end do
C
      deallocate(all_tribeRank,all_color,all_worldRank)
C
      if ( worldRank == 0) then
          do n_color = 0, numberMasters-1
             do n_tribe = 0, numberHFODDproc-1
                write(nfisum,'("n_tribe = ",i4," n_color = ",i4,
     *                    " my_rank = ",i4)')
     *                      n_tribe, n_color,
     *                      rankTribe(n_tribe, n_color)
             end do
          end do
      end if
C
#endif
C
      if ( printTopology == 1 ) then
C
          if ( worldRank < numberMasters ) then
               write(nfisum,'(''AFTER GROUPS - Processor: '',i7,
     *                   '' of color = '',i7,'' is master = '',i7,
     *                   '' Communicator handle: '',i12)')
     *                      worldRank, color, masterRank, mastersCOMM
          end if
C
          if (worldRank >= numberMasters) then
               write(nfisum,'(''AFTER GROUPS - Processor: '',i7,
     *                   '' of color = '',i7,'' is slave = '',i7,
     *                   '' Communicator handle: '',i12)')
     *                      worldRank, color, slaveRank, slavesCOMM
          end if
C
          write(nfisum,'(''AFTER GROUPS - Processor: '',i7,
     *              '' of color = '',i7,'' has rank = '',i7,
     *              '' in its tribe'')')
     *              worldRank, color, tribeRank
C
      end if
C
#endif
C
C=======================================================================
C
      CALL CPUTIM('HFODD ',1)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C      Flag that triggers the clean exit from this process (QUABCS)
C
#if(USE_MPI==1)
      escapeSignal = 0
#endif
C
C=======================================================================
C         DEFINING  THE   V E R S I O N   N U M B E R   OF THE CODE
C=======================================================================
C
C                           ------------------
C                          |                  |
                              VERSIO='3.34E'
C                          |                  |
C                           ------------------
C
C=======================================================================
C         DEFINING  THE   I N P U T   A N D   O U T P U T   FILE NUMBERS
C=======================================================================
C
#if(USE_MPI==1)
      NFIPRI=88
      WRITE(FILOUT,'(''hfodd_'',i6.6,''.out'')') worldRank+1
      OPEN(NFIPRI,FILE=FILOUT,STATUS='UNKNOWN',FORM='FORMATTED')
#else
#if(USE_FITS==1)
      CALL FITJAD(JADRO_NAME, DAT_SUFFIX)
#else
      NFIREA=05
      NFIPRI=06
#endif
#endif
C
C=======================================================================
C      DISPLAYING THE CHARACTERISTICS OF THE PARALLEL MODEL:
C       - SIMPLE MPI STRUCTURE WITH/WITHOUT OPENMP
C       - ADVANCED MPI STRUCTURE WITH/WITHOUT OPENMP
C=======================================================================
C
#if( USE_MPI==1 || USE_OPENMP==1)
      WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *      ''*                       P A R A L L E L    '',
     *      ''M O D E L                          *'',/,
     *      ''*'',77X,''*'')')
#else
      WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *      ''*                   S I N G L E - C O R E     '',
     *      ''V E R S I O N                   *'')')
#endif
C
#if(USE_MPI==1)
#if(USE_SCALAPACK==0)
      WRITE(NFIPRI,'(''*  SIMPLE MPI FRAMEWORK (1 COMMUNICATOR)'',
     *      ''    :  1 CORE per HFODD TASK          *'')')
#else
      WRITE(NFIPRI,'(''*  ADVANCED MPI FRAMEWORK (3 COMMUNICATORS)'',
     *      '' : '',I2,'' CORES per HFODD TASK         *'')')
     *      numberHFODDproc
#endif
#endif
C
#if(USE_OPENMP==1)
!$OMP PARALLEL
!$OMP& SHARED(NFIPRI)
!$OMP& PRIVATE(numThreads,idThread)
      numThreads = omp_get_num_threads()
      idThread = omp_get_thread_num()
      IF (idThread .EQ. 0) THEN
          WRITE(NFIPRI,'(''*  MULTI-THREADING FRAMEWORK WITH '',
     *    ''OPENMP    : '',I2,'' THREADS per HFODD TASK       *'')')
     *                numThreads
      END IF
!$OMP END PARALLEL
#endif
C
      WRITE(NFIPRI,'(''*'',77X,''*'')')
C
C=======================================================================
C         PRINTING THE OUTPUT HEADER
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     * 1H*, 19X, "     __  __ _____  ___   ____   ____   ",   19X,1H*,/,
     * 1H*, 19X, "    / / / // ___/.'' _ \ / __ \ / __ \  ",  19X,1H*,/,
     * 1H*, 19X, "   / /_/ // /_  / / / // / / // / / /  ",   19X,1H*,/,
     * 1H*, 19X, "  / __  // __/ / / / // / / // / / /   ",   19X,1H*,/,
     * 1H*, 19X, " / / / // /   / /_/ // /_/ // /_/ /    ",   19X,1H*,/,
     * 1H*, 19X, "/_/ /_//_/    \___.''/____.''/____.''     ",19X,1H*,/,
     * 1H*, 77X, 1H*,/,
     *                              1H*,77X,1H*,/,
     *                              79(1H*),/,1H*,77X,1H*,/,1H*, 9X,
     *     ''UNIVERSAL NON-RELATIVISTIC NUCLEAR DFT CODE VERSION: '',A5,
     *                              10X,1H*,/,1H*,77X,1H*,/,1H*,13X,
     *      '' NO SYMMETRY-PLANES AND NO TIME-REVERSAL SYMMETRY  '',
     *                              13X,1H*,/,1H*,77X,1H*,/,1H*,13X,
     *      ''   DEFORMED CARTESIAN HARMONIC-OSCILLATOR BASIS    '',
     *                              13X,1H*,/,1H*,77X,1H*,/,
     *                              79(1H*),/,1H*,77X,1H*,/,1H*,13X,
     *      '' J. DOBACZEWSKI, B.C. BACKES, P. BACZYK, P. BECKER '',
     *                              13X,1H*,/,              1H*,13X,
     *      '' M. BENDER, K. BENNACEUR, J. BONNARD, B.G. CARLSSON'',
     *                              13X,1H*,/,              1H*,13X,
     *      '' J. DUDEK, J. ENGEL, Y. GAO, A. IDINI, M. KONIECZKA'',
     *                              13X,1H*,/,              1H*,13X,
     *      ''     M. KORTELAINEN, T. LESINSKI, J. MCDONNELL     '',
     *                              13X,1H*,/,              1H*,13X,
     *      ''    P. OLBRATOWSKI, P. POWALOWSKI, L. PROCHNIAK    '',
     *                              13X,1H*,/,              1H*,13X,
     *      ''    A.M. ROMERO, M. SADZIAK, J. SARICH, K. SATO    '',
     *                              13X,1H*,/,              1H*,13X,
     *      ''    A. SANCHEZ-FERNANDEZ, W. SATULA, N. SCHUNCK    '',
     *                              13X,1H*,/,              1H*,13X,
     *      ''  J.A. SHEIKH, Y. SHI, A. STASZCZAK, M. STOITSOV   '',
     *                              13X,1H*,/,              1H*,13X,
     *      ''    X. SUN, P. TOIVANEN, X.B. WANG, T.R. WERNER    '',
     *                              13X,1H*,/,              1H*,13X,
     *      ''  H. WIBOWO, L.F. YU, M. ZALEWSKI AND H. ZDUNCZUK  '',
     *                              13X,1H*,/,1H*,77X,1H*,/,1H*,13X,
     *      ''  INSTYTUT FIZYKI TEORETYCZNEJ, WARSZAWA, POLSKA   '',
     *                                            13X,1H*,/,1H*,13X,
     *      ''           UNIVERSITY OF YORK, YORK, UK            '',
     *                              13X,1H*,/,1H*,77X,1H*,/,1H*,13X,
     *      ''                     1993-2024                     '',
     *                              13X,1H*,/,1H*,77X,1H*,/,79(1H*))')
     *
     *       VERSIO
C
C=======================================================================
C         PRINTING THE ARRAY DIMENSIONS
C=======================================================================
C
      WRITE(NFIPRI,'(/,79(1H*),/,             1H*,77X,1H*,/,1H*,2X,
     *      ''CODE COMPILED WITH THE FOLLOWING ARRAY DIMENSIONS '',
     *      ''AND SWITCHES:'',
     *                              12X,1H*,/,1H*,77X,1H*,/
     *                              79(1H*),/,1H*,77X,1H*,/,1H*,2X,
     *      ''NDBASE ='',I5,2X,''NDSTAT ='',I5,2X,
     *      ''NDXHRM ='',I5,2X,''NDYHRM ='',I5,2X,
     *      ''NDZHRM ='',I5,2X,
     *                                  1H*,/,1H*,77X,1H*,/,1H*,2X,
     *      ''NDMAIN ='',I5,2X,''NDMULT ='',I5,2X,
     *      ''NDMULR ='',I5,2X,''NDLAMB ='',I5,2X,
     *      ''NDITER ='',I5,2X,
     *                                  1H*,/,1H*,77X,1H*,/,1H*,2X,
     *      ''NDAKNO ='',I5,2X,''NDBKNO ='',I5,2X,
     *      ''NDPROI ='',I5,2X,''        '',5X,2X,
     *      ''        '',5X,2X,
     *                                  1H*,/,1H*,77X,1H*,/,1H*,2X,
     *      ''NDATKN ='',I5,2X,''NDBTKN ='',I5,2X,
     *      ''NDPROT ='',I5,2X,''        '',5X,2X,
     *      ''        '',5X,2X,
     *                                  1H*,/,1H*,77X,1H*,/,1H*,2X,
     *      ''IPARAL ='',I5,2X,''IPARAT ='',I5,2X,
     *      ''I_CRAY ='',I5,2X,''NDCOUL ='',I5,2X,
     *      ''NDPOLS ='',I5,2X,
     *                                  1H*,/,1H*,77X,1H*,/,1H*,2X,
     *      ''ISWTWC ='',I5,2X,''NDTWCE ='',I5,2X,
     *      ''NDTWBL ='',I5,2X,''NDTWHE ='',I5,2X,
     *      ''NDCONF ='',I5,2X,
     *                                  1H*,/,1H*,77X,1H*,/,1H*,2X,
     *      ''NDPROM ='',I7,3X,''NDISOM ='',I7,3X,
     *      ''NDPROD ='',I7,3X,''        '',7X,6X,
     *                                  1H*)')
     *
     *      NDBASE,NDSTAT,NDXHRM,NDYHRM,NDZHRM,
     *      NDMAIN,NDMULT,NDMULR,NDLAMB,NDITER,
     *      NDAKNO,NDBKNO,NDPROI,
     *      NDATKN,NDBTKN,NDPROT,
     *      IPARAL,IPARAT,I_CRAY,NDCOUL,NDPOLS,
     *      ISWTWC,NDTWCE,NDTWBL,NDTWHE,NDCONF,
     *      NDPROM,NDISOM,NDPROD
C
C=======================================================================
C      DISPLAYING VARIOUS PREPROCESSOR OPTIONS
C=======================================================================
C
      I_SWITCH_PORT=0
      I_SWITCH_DIAG=0
      I_SWITCH_ESSL=0
      I_SWITCH_QUAD=0
      I_SWITCH_VECT=0
#if(SWITCH_PORT==1)
      I_SWITCH_PORT=1
#endif
#if(SWITCH_DIAG==1)
      I_SWITCH_DIAG=1
#endif
#if(SWITCH_DIAG==2)
      I_SWITCH_DIAG=2
#endif
#if(SWITCH_DIAG==3)
      I_SWITCH_DIAG=3
#endif
#if(SWITCH_DIAG==4)
      I_SWITCH_DIAG=4
#endif
#if(SWITCH_ESSL==1)
      I_SWITCH_ESSL=1
#endif
#if(SWITCH_QUAD==1)
      I_SWITCH_QUAD=1
#endif
#if(SWITCH_VECT==1)
      I_SWITCH_VECT=1
#endif
C
      WRITE(NFIPRI,'(''*'',77X,''*'',/,''*  PRE-PROCESSOR OPTIONS:'',
     *             53X,''*'',/,''*'',77X,''*'',/,
     *             ''*       switch_port = '',I1,
     *             ''     switch_diag = '',I1,
     *             ''     switch_essl = '',I1,15X,''*'',/,
     *             ''*'',77X,''*'',/,''*       '',15X,
     *             ''     switch_quad = '',I1,
     *             ''     switch_vect = '',I1,15X,''*'',/,
     *             ''*'',77X,''*'',/,79(''*''))')
     *             I_SWITCH_PORT,I_SWITCH_DIAG,I_SWITCH_ESSL,
     *                           I_SWITCH_QUAD,I_SWITCH_VECT
C
C=======================================================================
C         PRINTING THE DATE AND TIME
C=======================================================================
C
      CALL DATE_AND_TIME(MYDATE,MYTIME,MYZONE,MYVALU)
C
      WRITE(NFIPRI,'(                         1H*,77X,1H*,/,1H*,2X,
     *      ''EXECUTION BEGINS ON '',A4,''.'',A2,''.'',A2,'' AT '',
     *                               A2,'':'',A2,'':'',A6,
     *                              29X,1H*,/,1H*,77X,1H*,/,79(1H*))')
     *
     *      MYDATE(1:4),MYDATE(5:6),MYDATE(7:8),
     *      MYTIME(1:2),MYTIME(3:4),MYTIME(5:10)
C
C=======================================================================
C      CHECKING THE CONSISTENCY OF THE LODED MODULES
C=======================================================================
C      ATTENTION FUTURE DEVELOPERS:
C      TO PROPERLY MAINTAIN THE MODULE VERSION-NUMBER CHECKING, AT EVERY
C      MODIFICATION OF A MODULE ONE SHOULD UPDATE ITS VERSION NUMBER:
C      1. IN THE NAME OF THE FILE CONTAINING THE MODULE
C      2. IN THE SUBROUTINE Set_version_hfodd_[NAME] INSIDE THE MODULE
C      2. IN THE MAKEFILE
C      3. IN THE BLOCK DATA List_of_modules @ THE BEGINNING OF THIS FILE
C
C      ANY NEW MODULE SHOULD BE ADDED TO THE MAKEFILE AND TO THE LIST OF
C      MODULES @ THE BEGINNING OF THIS FILE, WHERE THE VALUE OF VARIABLE
C      "MODTOT" SHOULD BE, IN ADDITION, INCREASED BY ONE.
C=======================================================================
C
      MODSET(:)=0
C
      CALL Set_version_hfodd_sizes
      CALL Set_version_hfodd_modules
      CALL Set_version_hfodd_hfbtho
      CALL Set_version_hfodd_interface
      CALL Set_version_hfodd_functional
#if(USE_MPI==1)
      CALL Set_version_hfodd_mpiio
      CALL Set_version_hfodd_mpimanager
#endif
      CALL Set_version_hfodd_shell
#if(USE_SCALAPACK==1)
      CALL Set_version_hfodd_SLsiz
#endif
      CALL Set_version_hfodd_fission
      CALL Set_version_hfodd_pairs
      CALL Set_version_hfodd_pnp
#if(USE_FITS==1)
      CALL Set_version_hfodd_fits
#endif
      CALL Set_version_hfodd_lipcorr
      CALL Set_version_hfodd_tgrad
      CALL Set_version_hfodd_wigner
      CALL Set_version_hfodd_twocen
      CALL Set_version_hfodd_adiabatic
C
      IMODOK=1
C
      DO NUMODU=1,MODTOT
C
         IF (MODSET(NUMODU).GE.1.AND.
     *      (MODSET(NUMODU).NE.MODORD(NUMODU).OR.
     *       NAMODU(NUMODU).NE.NAMMOD(NUMODU).OR.
     *       MODVER(NUMODU).NE.MODUVE(NUMODU))) THEN
C
             IF (IMODOK.EQ.1)
     *           WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *        1H*,2X,''INCORRECT VERSIONS OF LOADED MODULES'',
     *               '' -- THE CODE CANNOT RUN AND STOPS NOW'',2X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *        1H*,2X,'' -----------------------------------'',
     *               ''------------------------------------ '',2X,1H*,/,
     *        1H*,2X,''|            | MODULE   R E Q U I R '',
     *               ''E D   || MODULE     L O A D E D     |'',2X,1H*,/,
     *        1H*,2X,''|   MODULE   |----------------------'',
     *               ''------||----------------------------|'',2X,1H*,/,
     *        1H*,2X,''| NUM1  NUM2 | NAME             | VE'',
     *               ''RSION || NAME             | VERSION |'',2X,1H*,/,
     *        1H*,2X,''|------------|------------------|---'',
     *               ''------||------------------|---------|'',2X,1H*)')
C
             IMODOK=0
C
             WRITE (NFIPRI,'(''*  |  '',I2,4X,I2,''  | '',
     *                        A16,'' |  '',I3,''    || '',
     *                        A16,'' |  '',I3,''    |  *'')')
     *              MODSET(NUMODU),MODORD(NUMODU),
     *              NAMODU(NUMODU),MODVER(NUMODU),
     *              NAMMOD(NUMODU),MODUVE(NUMODU)
C
         END IF
C
      END DO
C
      IF (IMODOK.EQ.0) THEN
C
          WRITE(NFIPRI,'(
     *        1H*,2X,'' -----------------------------------'',
     *               ''------------------------------------ '',2X,1H*,/,
     *                                          1H*,77X,1H*,/,79(1H*))')
          STOP 'INCORRECT VERSIONS OF LOADED MODULES'
C
      END IF
C
      WRITE(NFIPRI,*)
C
C=======================================================================
C         P R E S E T T I N G   T H E   D E F A U L T   V A L U E S
C=======================================================================
C
      CALL PREDEF(IN_FIX,IZ_FIX,SKYRME,GOGNAM,ISTAND,
     *            KETA_J,KETA_W,KETACM,KETA_M,KETA_P,
     *                          KETA_T,KETAPA,NOZEPA,
     *                          ITWOLI,KETA_R,
     *                          KETAJ2,KETAT2,
     *     LANODD,LANSCA,HBMSAT,RHOSAT,EFFSAT,
     *     ILIBAS,INBASI,IZBASI,FCHOM0,R0PARM,
     *                                 IOPTGS,
     *     IPAIRI,IPAHFB,ITWOBA,IPABCS,IMFHFB,
     *                                 IPNMIX,
     *                          LIPKIN,LIPKIP,
     *                          LIPNON,LIPNOP,
     *                   IPNPRJ,NPPNPN,NPPNPP,
     *            IROTAT,ITIREP,IREVIE,IQPSTA,
     *            DELFIN,DELFIP,IDEFIN,IDEFIP,
     *            FERFIN,FERFIP,IFEFIN,IFEFIP,
     *            FE2FIN,FE2FIP,IF2FIN,IF2FIP,
     *            FERALN,FERALP,IFERAN,IFERAP,
     *                                 NUQEVE,
     *            INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *            INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                   INSIMN,IRSIMN,IDSIMN,
     *                   INSIMP,IRSIMP,IDSIMP,
     *                   INSIQN,IPSIQN,IDSIQN,
     *                   INSIQP,IPSIQP,IDSIQP,
     *                          INSIZN,IDSIZN,
     *                          INSIZP,IDSIZP,
     *                          IFIBLN,INIBLN,
     *                          IFIBLP,INIBLP,
     *                                 IREAWS,
     *                   ICONTI,IPCONT,IOCONT,
     *                   ISCONT,ITCONT,IACONT,
     *            IYCONT,IGCONT,IGPCON,IECONT,
     *     ILCONT,IFCONT,IMCONT,IRCONT,IBCONT,
     *     NUCHAO,NUPING,EPSPNG,EPSITE,EPSCON,
     *            ISPHER,ISIMPY,ISIGNY,IPARTY,
     *                   ISIMTX,ISIMTY,ISIMTZ,
     *            IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                   NOITER,NULAST,NUCONS,
     *            ISYMDE,INIROT,INIINV,INIKAR,
     *                   IRENMA,IRENIN,IDOGOA,
     *                   IFRWAV,ITOWAV,IWRWAV,
     *                          ISAKER,ICHKER,
     *                   IPRROT,IPRISO,IPRIS3,
     *                   IPRNUM,IPRVEC,IPRPTY,
     *                          IPROMI,IPROMA,
     *                   NUAKNO,NUBKNO,KPROJE,
     *                   NATKNO,NBTKNO,KSOSTZ,
     *            NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *                          KSOSMI,KSOSMA,
     *                   ISOSAD,EPSISO,ICSKIP,
     *     IFERME,IBETME,IIFERR,ITFERR,ISFERR,
     *            IPAKER,IPAK3D,IPAALL,KFIKER,
     *            NUASTA,NUASTO,NUGSTA,NUGSTO,
     *            NATSTA,NATSTO,NGTSTA,NGTSTO,
     *            NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *                   ICUTOV,CUTOVE,CUTOVF,
     *                   IONISH,ISLPRI,ISUPRI,
     *                   IENPRI,ISRPRI,IMIPRI,
     *                   IKEPRI,IRMPRI,IELPRI,
     *            QMUCUT,QMACUT,QASCUT,QSICUT,
     *                   NOSCIL,NLIMIT,ENECUT,
     *                   NUMCOU,NUMETA,FURMAX,
     *            ICOTYP,ICOUDI,ICOUEX,E_EFFE,
     *            PIMASS,PNMASS,IYUTYP,I_YUKA,
     *            YUKAGT,YUKAG0,YUKAG1,YUKAG2,
     *                          I_GOGA,IGOGPA,
     *                          I_REGA,IREGPA,
     *                          I_SEPA,ISEPPA,
     *                          I_COUA,ICOUPA,
     *                          N3SERD,IDOTHC,
     *            I1LINE,IPRSTA,IPRMID,IPRSTO,
     *            IDESTA,IDEMID,IDESTO,IDEDIS,
     *                          INTRIP,IVIPRI,
     *                   IPRI_N,IPRI_P,IPRI_T,
     *                   NMUCON,NMUCOU,NMUPRI,
     *                          ICOUMD,ICOUMX,
     *                   ISCHIF,NSICON,NSIPRI,
     *                   NMACON,NMAPRI,NMAORD,
     *                   NASCON,NASPRI,NASORD,
     *                                 NRAORD,
     *            NMURED,NMARED,NASRED,NSIRED,
     *                   NEXBET,IPRIBE,IPRIBL,
     *            IWRIOL,IWRISO,IWRIRE,IWRIBA,
     *                   IWRIYU,IWRIGO,IWRIRO,
     *            IWRILI,IWRIFI,IWRIQU,IWRIRM,
     *                   FILISO,FILREP,FILREC,
     *                   FILWOO,FILREV,FILCOU,
     *                          FILWAV,FILKER,
     *                          FILYUP,FILYUC,
     *                          FILGOP,FILGOC,
     *                          FILGPP,FILGPC,
     *                          FILROP,FILROC,
     *                          FILLIP,FILLIC,
     *                   FILFIP,FILFIC,FILFER,
     *                          FILQUA,FILRED,
     *                          FILBAP,FILBAC,
     *                   ICHFLI,IPAFLI,IREFLI,
     *                   ISPFLI,ISHFLI,IFLIPI,
     *            SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                          ICOULI,ICOULO,
     *                          FACTGN,FACTGP,
     *                          EMINAL,EMAXAL,
     *            EMAXQU,ECUTOF,LIMQUA,LAMCUT,
     *                          IQUNIL,NILXYZ,
     *                                 IAVRGG,
     *                                 IPOTHO,
     *                                 EPSHER,
     *                   ICOMIX,INLKER,INRKER,
     *                   ICMPRI,IN_EXC,EPSMIX,
     *                          ISOADD,NBTKNT,
     *                   IFSHEL,IF_RPA,IFRTHO,
     *            PRHD_T,PRHDDT,PRHDST,POWDRT,
     *                   IFRAGM,NUMPUS,IFPUSH,
     *     DELTAE,XLOCMX,V2_MIN,ITRMAX,NTHETA,
     *            MIN_QP,IDEALL,IDELOC,IDECON,
     *                   ILIPON,ILIPOP,GAUSHI,
     *                          I_SLOW,SLOWAL,
     *            SLOWLD,SLOWTP,SLOWRP,SLOWLM,
     *     NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,
     *     NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,
     *                          LASTAN,LASTAP,
     *                   IAXIAP,KAPASY,INUNIL,
     *                                 IADBAT,
     *                          NEWGOG,NEWCOU,
     *                                 ITWCEN,
     *                          IEIGCU,EIGCUT,
     *                          NLIMTW,ENECTW,
     *                                 IFRCNT)
C
C=======================================================================
C         I N I T I A L I Z I N G   O U T P U T   T O   Z E R O
C=======================================================================
C
      CALL ZEROUT
C
C=======================================================================
C         DEFINING THE NEWTON BINOMIAL COEFFICIENTS, FACTORIALS, SIMPLE
C         GAUSS  INTEGRALS,  AND  ORTHOGONAL  POLYNOMIAL  NORMALIZATION
C         FACTORS
C=======================================================================
C
      CALL DEFBIN
      CALL DEFBIR
      CALL DEFGAU
      CALL DEFFAC
      CALL NORHER
C
C=======================================================================
C         HERE STARTS CALCULATION FOR ONE INPUT-DATA SET
C=======================================================================
C
      batch_init=1
C
      IF_THO=IFRTHO
C
#if(USE_MPI==0)
C
      NUDATA=0
C
    3 CONTINUE
C
      NUDATA=NUDATA+1
C
#endif
C
C=======================================================================
C         READING THE INPUT DATA
C=======================================================================
#if(USE_MPI==1)
C
C     - master processor reads the common input and broadcasts the
C       data, which are then passed to local HFODD variables
C     - master processor reads the parallel input and broadcasts
C       the data which are then used by all processors to construct
C       list of jobs
C
      CALL mpi_getSequentialData()
C
      ! Get sequential data
C
C=======================================================================
C
      CALL mpi_setSequentialData(IOPTGS,NXHERM,NYHERM,NZHERM,
     *                           IPAIRI,IPAHFB,IPABCS,IMFHFB,
     *                                         LIPKIN,LIPKIP,
     *                           FE2FIN,IF2FIN,FE2FIP,IF2FIP,
     *                                         IROTAT,IREVIE,
     *                           ICONTI,IPCONT,IGCONT,IGPCON,
     *                                  ILCONT,IFCONT,IACONT,
     *                           NUCHAO,NUPING,EPSPNG,EPSITE,
     *                                  ISIMPY,ISIGNY,IPARTY,
     *                                  ISIMTX,ISIMTY,ISIMTZ,
     *                                         NOITER,NULAST,
     *                                  NOSCIL,NLIMIT,ENECUT,
     *                                  ICOTYP,ICOUDI,ICOUEX,
     *                                         I_GOGA,IGOGPA,
     *                                                I1LINE,
     *                           SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                                                ECUTOF,
     *                                                NILXYZ,
     *                           IBROYD,N_ITER,BROTRI,ALPHAM,
     *                                  PRHO_T,PRHOST,POWERT,
     *                                                OMEGAY,
     *                    IFSHEL,MPOLYN,G_STUN,G_STUP,H_OMFA,
     *                           LAMBAS,MIUBAS,BETBAS,NUMDEF,
     *                    LAM_WS,MIU_WS,NUM_WS,ITE_WS,STP_WS,
     *                    LAMPUS,MIUPUS,NUMPUS,QMOPUS,IFPUSH,
     *                                         NITPUS,IREAWS,
     *                    ISTAND,KETA_J,KETA_W,KETACM,KETA_M,
     *                           IF_RPA,IF_EDF,IF_THO,CBETHO,
     *                                  IBASIS,IHFPOT,IFRAGM,
     *                                  NMUCON,NMUCOU,NMUPRI,
     *                                  NEXBET,IPRIBE,IPRIBL,
     *                                                FCHOM0,
     *                                  L_COLL,M_COLL,N_COLL,
     *                                                IWRIFI,
     *                                  INBASI,IZBASI,R0PARM,
     *                    DELTAE,XLOCMX,V2_MIN,ITRMAX,NTHETA,
     *                           MIN_QP,IDEALL,IDELOC,IDECON)
C
      ! Deformation of the basis: fixed or automatically
      ! adjusted on requested value of Q2
C
      IF (ASSOCIATED(LAMBAS)) THEN
C
          DO I=1,NUMDEF
             LAMACT=ABS(LAMBAS(I))
             MIUACT=MIUBAS(I)
             ALPHAR(LAMACT,MIUACT)=BETBAS(I)
          END DO
C
      END IF
C
      ! data for shell correction
C
      NPOLYN=MPOLYN
      GSTRUN=G_STUN
      GSTRUP=G_STUP
      HOMFAC=H_OMFA
C
      ! By default, computing pairing properties separately
      ! for neutrons and protons
C
      CALL RHODEP(2,PRHO_N,PRHODN,PRHOSN,POWERN)
C
      CALL RHODEP(2,PRHO_P,PRHODP,PRHOSP,POWERP)
C
      ! If the user set the keyword PAIR_INTER in the input file
      ! neutron and proton pairing properties are the same and
      ! overwritten here (same mechanism as NAMELI)
C
      IF (ABS(PRHO_T).GT.1.E-10) THEN
C
          PRHO_N=PRHO_T
          PRHOSN=PRHOST
          POWERN=POWERT
C
          CALL RHODEP(2,PRHO_N,PRHODN,PRHOSN,POWERN)
C
          PRHO_P=PRHO_T
          PRHOSP=PRHOST
          POWERP=POWERT
C
          CALL RHODEP(2,PRHO_P,PRHODP,PRHOSP,POWERP)
C
      END IF
C
      ! Get parallel data (I/O done only by root processor)
C
      CALL mpi_initializeParallelData()
C
      CALL mpi_getParallelData()
C
      CALL mpi_setParallelData()
C
      CALL mpi_printParallelData()
C
      ! Construct job list based on parallel data (all processors)
C
      IERROR=0
      CALL mpi_constructJobList(NUMITE,NXHERM,NYHERM,NZHERM,
     *                          IPCONT,ILCONT,IACONT,IMCONT,IRCONT,
     *                                               IRENMA,IRENIN,
     *                                               LIPKIN,LIPKIP,
     *                                        REFERN,REFERP,REDELN,
     *                                        REDELP,REFE2N,REFE2P,
     *                                 IFIBLN,INIBLN,IFIBLP,INIBLP,
     *                                 NMUMAX,NSIMAX,NMUCON,ISHIFT,
     *                                                      IF_THO,
     *                                                      IERROR)
C
      ! Construct job list based on parallel data (all processors)
C
      procLoop: DO INDJOB=1,NOFJOB
C
         ! Execute only if
         IF (color .EQ. MOD(INDJOB-1, numberMasters)) THEN
C
             MNSIQN=INSIQN(1)
             MPSIQN=IPSIQN(1)
             MDSIQN=IDSIQN(1)
             MNSIQP=INSIQP(1)
             MPSIQP=IPSIQP(1)
             MDSIQP=IDSIQP(1)
C
             CALL mpi_getCurrentData(INDJOB,IN_FIX,IZ_FIX,
     *                                             SKYRME,GOGNAM,
     *                                      MNSIQN,MPSIQN,MDSIQN,
     *                                      MNSIQP,MPSIQP,MDSIQP,
     *                               INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *                               INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                               ICONTI,IPCONT,ILCONT,IFCONT,
     *                                                    I_GOGA,
     *                               SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                                                    IROTAT,
     *                                                    NILXYZ,
     *                                                    N_EXIT,
     *                                                    NOITER,
     *                                      FCHOM0,NOSCIL,NLIMIT,
     *                                             LIPKIN,LIPKIP,
     *                               NXHERM,NYHERM,NZHERM,IOPTGS,
     *                                      IPAIRI,IPAHFB,IMFHFB,
     *                                                    IWRILI,
     *                                                    EPSITE,
     *                                                    INIROT,
     *                                                    IGAMMA,
     *                                                    LANODD,
     *                               IFIBLN,INIBLN,IFIBLP,INIBLP,
     *                                                    NMUCON,
     *                                                    IFSHEL,
     *                                                    IF_RPA,
     *                                                    INDFIL,
     *                                                    TEMP_T)
C
             IF (ABS(TEMP_T).GT.1.D-12) IFTEMP=1
C
             CALL mpi_printSequentialData(IOPTGS,NXHERM,NYHERM,NZHERM,
     *                                    IPAIRI,IPAHFB,IPABCS,IMFHFB,
     *                                                  LIPKIN,LIPKIP,
     *                                    FE2FIN,IF2FIN,FE2FIP,IF2FIP,
     *                                                  IROTAT,IREVIE,
     *                                    ICONTI,IPCONT,IGCONT,IGPCON,
     *                                           ILCONT,IFCONT,IACONT,
     *                                    NUCHAO,NUPING,EPSPNG,EPSITE,
     *                                           ISIMPY,ISIGNY,IPARTY,
     *                                           ISIMTX,ISIMTY,ISIMTZ,
     *                                                  NOITER,NULAST,
     *                                           NOSCIL,NLIMIT,ENECUT,
     *                                           ICOTYP,ICOUDI,ICOUEX,
     *                                                  I_GOGA,IGOGPA,
     *                                                         I1LINE,
     *                                    SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                                                         ECUTOF,
     *                                                         NILXYZ,
     *                                    IBROYD,N_ITER,BROTRI,ALPHAM,
     *                                           PRHO_T,PRHOST,POWERT,
     *                                    PRHO_N,PRHOSN,PRHODN,POWERN,
     *                                    PROD_P,PRHOSP,PRHODP,POWERP,
     *                                                         OMEGAY,
     *                             IFSHEL,NPOLYN,GSTRUN,GSTRUP,HOMFAC,
     *                                    LAMBAS,MIUBAS,BETBAS,NUMDEF,
     *                             LAM_WS,MIU_WS,NUM_WS,ITE_WS,STP_WS,
     *                                           LMXINP,IFPUSH,IREAWS,
     *                             ISTAND,KETA_J,KETA_W,KETACM,KETA_M,
     *                                    IF_RPA,IF_EDF,IF_THO,CBETHO,
     *                                                  IBASIS,IFRAGM,
     *                                           NMUCON,NMUCOU,NMUPRI,
     *                                           NEXBET,IPRIBE,IPRIBL,
     *                                                         FCHOM0,
     *                                           IWRIFI,IFTEMP,IFNECK,
     *                                           INBASI,IZBASI,R0PARM,
     *                             DELTAE,XLOCMX,V2_MIN,NTHETA,MIN_QP,
     *                                           IDEALL,IDELOC,IDECON,
     *                                                     batch_init)
C
#else
C
      ALLOCATE(LAMPUS(1:NDMULT))
      ALLOCATE(MIUPUS(1:NDMULT))
      ALLOCATE(QMOPUS(1:NDMULT))
C
      CALL NAMELI(IN_FIX,IZ_FIX,SKYRME,GOGNAM,ISTAND,
     *            KETA_J,KETA_W,KETACM,KETA_M,KETA_P,
     *                          KETA_T,KETAPA,NOZEPA,
     *                          ITWOLI,KETA_R,
     *                          KETAJ2,KETAT2,
     *     LANODD,LANSCA,HBMSAT,RHOSAT,EFFSAT,
     *     ILIBAS,INBASI,IZBASI,FCHOM0,R0PARM,
     *                                 IOPTGS,
     *     IPAIRI,IPAHFB,ITWOBA,IPABCS,IMFHFB,
     *                                 IPNMIX,
     *                          LIPKIN,LIPKIP,
     *                          LIPNON,LIPNOP,
     *                   IPNPRJ,NPPNPN,NPPNPP,
     *            IROTAT,ITIREP,IREVIE,IQPSTA,
     *            DELFIN,DELFIP,IDEFIN,IDEFIP,
     *            FERFIN,FERFIP,IFEFIN,IFEFIP,
     *            FE2FIN,FE2FIP,IF2FIN,IF2FIP,
     *            FERALN,FERALP,IFERAN,IFERAP,
     *                                 NUQEVE,
     *            INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *            INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                   INSIMN,IRSIMN,IDSIMN,
     *                   INSIMP,IRSIMP,IDSIMP,
     *                   INSIQN,IPSIQN,IDSIQN,
     *                   INSIQP,IPSIQP,IDSIQP,
     *                          INSIZN,IDSIZN,
     *                          INSIZP,IDSIZP,
     *                          IFIBLN,INIBLN,
     *                          IFIBLP,INIBLP,
     *                                 IREAWS,
     *                   ICONTI,IPCONT,IOCONT,
     *                   ISCONT,ITCONT,IACONT,
     *            IYCONT,IGCONT,IGPCON,IECONT,
     *     ILCONT,IFCONT,IMCONT,IRCONT,IBCONT,
     *     NUCHAO,NUPING,EPSPNG,EPSITE,EPSCON,
     *            ISPHER,ISIMPY,ISIGNY,IPARTY,
     *                   ISIMTX,ISIMTY,ISIMTZ,
     *            IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                   NOITER,NULAST,NUCONS,
     *            ISYMDE,INIROT,INIINV,INIKAR,
     *                   IRENMA,IRENIN,IDOGOA,
     *                   IFRWAV,ITOWAV,IWRWAV,
     *                          ISAKER,ICHKER,
     *                   IPRROT,IPRISO,IPRIS3,
     *                   IPRNUM,IPRVEC,IPRPTY,
     *                          IPROMI,IPROMA,
     *                   NUAKNO,NUBKNO,KPROJE,
     *                   NATKNO,NBTKNO,KSOSTZ,
     *            NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *                          KSOSMI,KSOSMA,
     *                   ISOSAD,EPSISO,ICSKIP,
     *     IFERME,IBETME,IIFERR,ITFERR,ISFERR,
     *            IPAKER,IPAK3D,IPAALL,KFIKER,
     *            NUASTA,NUASTO,NUGSTA,NUGSTO,
     *            NATSTA,NATSTO,NGTSTA,NGTSTO,
     *            NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *                   ICUTOV,CUTOVE,CUTOVF,
     *                   IONISH,ISLPRI,ISUPRI,
     *                   IENPRI,ISRPRI,IMIPRI,
     *                   IKEPRI,IRMPRI,IELPRI,
     *            QMUCUT,QMACUT,QASCUT,QSICUT,
     *                   NOSCIL,NLIMIT,ENECUT,
     *                   NUMCOU,NUMETA,FURMAX,
     *            ICOTYP,ICOUDI,ICOUEX,E_EFFE,
     *            PIMASS,PNMASS,IYUTYP,I_YUKA,
     *            YUKAGT,YUKAG0,YUKAG1,YUKAG2,
     *                          I_GOGA,IGOGPA,
     *                          I_REGA,IREGPA,
     *                          I_SEPA,ISEPPA,
     *                          I_COUA,ICOUPA,
     *                          N3SERD,IDOTHC,
     *            I1LINE,IPRSTA,IPRMID,IPRSTO,
     *            IDESTA,IDEMID,IDESTO,IDEDIS,
     *                          INTRIP,IVIPRI,
     *                   IPRI_N,IPRI_P,IPRI_T,
     *                   NMUCON,NMUCOU,NMUPRI,
     *                          ICOUMD,ICOUMX,
     *                   ISCHIF,NSICON,NSIPRI,
     *                   NMACON,NMAPRI,NMAORD,
     *                   NASCON,NASPRI,NASORD,
     *                                 NRAORD,
     *            NMURED,NMARED,NASRED,NSIRED,
     *                   NEXBET,IPRIBE,IPRIBL,
     *            IWRIOL,IWRISO,IWRIRE,IWRIBA,
     *                   IWRIYU,IWRIGO,IWRIRO,
     *            IWRILI,IWRIFI,IWRIQU,IWRIRM,
     *                   FILISO,FILREP,FILREC,
     *                   FILWOO,FILREV,FILCOU,
     *                          FILWAV,FILKER,
     *                          FILYUP,FILYUC,
     *                          FILGOP,FILGOC,
     *                          FILGPP,FILGPC,
     *                          FILROP,FILROC,
     *                          FILLIP,FILLIC,
     *                   FILFIP,FILFIC,FILFER,
     *                          FILQUA,FILRED,
     *                          FILBAP,FILBAC,
     *                   ICHFLI,IPAFLI,IREFLI,
     *                   ISPFLI,ISHFLI,IFLIPI,
     *            SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                          ICOULI,ICOULO,
     *                          FACTGN,FACTGP,
     *                          EMINAL,EMAXAL,
     *            EMAXQU,ECUTOF,LIMQUA,LAMCUT,
     *                          IQUNIL,NILXYZ,
     *                                 IAVRGG,
     *                                 IPOTHO,
     *                                 EPSHER,
     *                   ICOMIX,INLKER,INRKER,
     *                   ICMPRI,IN_EXC,EPSMIX,
     *                          ISOADD,NBTKNT,
     *                   IFSHEL,IF_RPA,IFRTHO,
     *            PRHD_T,PRHDDT,PRHDST,POWDRT,
     *                                 IFRAGM,
     *     DELTAE,XLOCMX,V2_MIN,ITRMAX,NTHETA,
     *            MIN_QP,IDEALL,IDELOC,IDECON,
     *                   ILIPON,ILIPOP,GAUSHI,
     *                          I_SLOW,SLOWAL,
     *            SLOWLD,SLOWTP,SLOWRP,SLOWLM,
     *     NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,
     *     NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,
     *                          LASTAN,LASTAP,
     *                   IAXIAP,KAPASY,INUNIL,
     *                                 IADBAT,
     *                          NEWGOG,NEWCOU,
     *                                 ITWCEN,
     *                          IEIGCU,EIGCUT,
     *                          NLIMTW,ENECTW,
     *                                 IFRCNT)
C
      INDFIL=0
      INDJOB=1
C
      IF_THO=IFRTHO
C
C=======================================================================
C         SETTING THE BASIS DEFORMATIONS TO THOSE READ FROM THE INPUT
C=======================================================================
C
      ALPHAR(:,:)=ALPHRE(:,:)
C
#endif
C
C=======================================================================
C         HERE STARTS THE LOOP OVER BATCH NUMBER (PARALLEL MODE ONLY)
C=======================================================================
#if(USE_MPI==1)
C
C      Backup copy of IF_THO
      ITHOBK=IF_THO
      NUDATA=1
C
      DO
C
C         Restoring the IF_THO flag that has been set to 0 after the
C         first iteration
         IF (NUDATA.GT.1) IF_THO=ITHOBK
C
#endif
C
C      By default, symmetrize the calculation of the densities in
C      the routine DENSHF
      do_symmetrize = .True.
C
      TERMNT=.FALSE.
      IS_YES=0
      IS_PIN=0
      IS_CHA=0
      IS_CON=0
      ITERUN=0
      ISHIFT=0
C
      ISGOGA=0 ! Gogny mean field
      ISGOGP=0 ! Gogny pairing field
      ISREGA=0 ! Regularized mean field
      ISREGP=0 ! Regularized pairing field
      ISSEPA=0 ! Separable mean field
      ISSEPP=0 ! Separable pairing field
      ISFSTA=0 ! Spin-orbit and tensor mean field
      ISFSTP=0 ! Spin-orbit and tensor pairing field
C
      LDPNMX=1 ! default for no proton-neutron mixing
C
C      Mixing of matrix elements (p and n separated)
      NOFBRN=0
      NOFBRP=0
      NSWBRN=1000000
      NSWBRP=1000000
      ITAK_N=0
      ITAK_P=0
      NOICAN=NOIINP
C
C      Mixing of fields (p and n combined)
      NOFBRO=0
      NSWBRO=1000
      ITAKEN=0
      KEPTES=0
C
      IS_DLI=0
C
C      Counting and defining the active constraints
C
                       DOPUSH=.FALSE.
      IF (IFPUSH.EQ.1) DOPUSH=.TRUE.
C
C REMOVED INTERFACES 170407
C     CALL NUMCON(LAMPUS,MIUPUS,QMOPUS,NUMPUS,IF_RPA,IFPUSH,DOPUSH)
C
C=======================================================================
C      AUTOMATIC ADJUSTMENT OF THE BASIS DEFORMATION AND FREQUENCIES
C      BASED ON REQUESTED VALUE OF THE QUADRUPOLE MOMENT.  FCHOM0 IS
C      A MULTIPLICATIVE  FACTOR OF  BASIC FREQUENCY  41/A^(1/3). THE
C      DEFORMATION OF THE BASIS PASSED THROUGH COMMON BLOCK.
C=======================================================================
C
CLP@+
      CALL NUMCON(IF_RPA)
CLP@-
      IF (IBASIS.EQ.1.AND.batch_init.EQ.1)
     *    CALL ADJBAS(FCHOM0,IN_FIX,IZ_FIX)
C
C=======================================================================
C
      IDOPLM=0
C
C=======================================================================
C
      ISQPRO=0
C
C=======================================================================
C      OPENING ALL RELEVANT FILES FOR I/O
C=======================================================================
C
      IF (batch_init.EQ.1) THEN
          CALL IOFILE(IREAWS,ICONTI,IFCONT,IYCONT,ILCONT,IGCONT,
     *                IGPCON,IECONT,IWRIRE,IWRILI,IWRIYU,IWRIGO,
     *                IWRIRO,IWRIFI,IWRISO,IWRIQU,IWRIRM,
     *
     *                LIPKIN,LIPKIP,I_YUKA,I_GOGA,IGOGPA,I_REGA,
     *                INDFIL,INDJOB,IREVIE,IF_THO,NEWGOG,
     *
     *                NFIWOO,NFIREP,NFIREC,NFIREV,NFICOU,NFIWAV,
     *                NFIKER,NFIYUP,NFIYUC,NFIGOP,NFIGOC,NFIGPC,
     *                NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *                NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP,
     *                NFIFER,
     *
     *                FILWOO,FILREP,FILREC,FILREV,FILCOU,FILWAV,
     *                FILKER,FILYUP,FILYUC,FILGOP,FILGOC,FILGPC,
     *                FILGPP,FILROP,FILROC,FILLIP,FILLIC,FILFIP,
     *                FILFIC,FILISO,FILQUA,FILRED)
      END IF
C
C=======================================================================
C         INPUT-RELATED PREDEFINITIONS
C=======================================================================
C
      NVASIZ(0)=IN_FIX+MVASIZ(0)
      NVASIZ(1)=IZ_FIX+MVASIZ(1)
C
      IF (KVASIZ(0).NE.0) NVASIZ(0)=KVASIZ(0)
      IF (KVASIZ(1).NE.0) NVASIZ(1)=KVASIZ(1)
C
      NVAMIZ=IN_FIX+IZ_FIX
C
      IA_FIX=IN_FIX+IZ_FIX
C
                                      INNUMB=INBASI
      IF (ILIBAS.EQ.1.OR.ILIBAS.EQ.3) INNUMB=IN_FIX
                                      IZNUMB=IZBASI
      IF (ILIBAS.EQ.2.OR.ILIBAS.EQ.3) IZNUMB=IZ_FIX
C
C=======================================================================
C         SETTING "ISIQTY" ACCORDING TO THE ADOPTED COMPATIBILITY MODE
C=======================================================================
C
      IF (IPARTY.NE.-1) THEN
C
          ISIQTY=IPARTY
C
      ELSE
C
          IF (ISIGNY.EQ.1.AND.ISIMPY.EQ.1) THEN
C
              ISIQTY=1
          ELSE
              ISIQTY=0
C
          END IF
C
      END IF
C
C=======================================================================
C         SETTING "JSIMTY" ACCORDING TO THE ADOPTED COMPATIBILITY MODE
C=======================================================================
C
      IF (ISIMTY.NE.-1) THEN
C
          JSIMTY=ISIMTY
C
      ELSE
C
          IF (IROTAT.EQ.1) THEN
              JSIMTY=0
          ELSE
              JSIMTY=1
          END IF
C
      END IF
C
C=======================================================================
C         SETTING "JPABCS" ACCORDING TO THE ADOPTED COMPATIBILITY MODE
C=======================================================================
C
      IF (IPABCS.NE.-1) THEN
C
          JPABCS=IPABCS
C
      ELSE
C
          IF (IPAHFB.GE.1) THEN
              JPABCS=0
          ELSE
              JPABCS=IPAIRI
          END IF
C
      END IF
C
C=======================================================================
C         SETTING THE ANGULAR FREQUENCY COMPONENTS TO THE INITIAL VALUES
C=======================================================================
C
      OMOVAX=OMEGAX
      OMOVAY=OMEGAY
      OMOVAZ=OMEGAZ
C
C=======================================================================
C         SETTING THE FERMI ENERGY COMPONENTS TO THE INITIAL VALUES
C=======================================================================
C
      FERMOV=FERISO
C
C=======================================================================
C         CLEARING THE STORAGE SWITCH OF THE SEPARABLE INTERATION
C=======================================================================
C
      ISEPDO=0
C
C=======================================================================
C         CHANGING THE PARITY/SIGNATURE NOTATION INTO THE
C         PARITY/TIME-REVERSAL NOTATION
C=======================================================================
C
      CALL SIGREV
C
C=======================================================================
C         SETTING THE ABSOLUTE CONFIGURATIONS
C=======================================================================
C
      IF (IPNMIX.NE.1) THEN
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL SETSIG(IPAIRI)
              ELSE
                  CALL SETSIM(IPAIRI)
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  CALL SETSIQ(IPAIRI)
              ELSE
                  CALL SETSIZ(IPAIRI)
C
              END IF
C
          END IF
C
C=======================================================================
C         SETTING THE ABSOLUTE CONFIGURATIONS FOR PROTON-NEUTRON MIXING
C=======================================================================
C
      ELSE
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL SETMIG(IPAIRI)
              ELSE
                  CALL SETMIM(IPAIRI)
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  CALL SETMIQ(IPAIRI)
              ELSE
                  CALL SETMIZ(IPAIRI)
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C         SETTING THE COULOMB, PHASE SPACE, AND PAIRING DATA
C=======================================================================
C
      BOUCOU=FURMAX*NUMCOU
C
      IF (NUMBSP(0,0).EQ.0) NUMBSP(0,0)=IN_FIX
      IF (NUMBSP(1,0).EQ.0) NUMBSP(1,0)=IN_FIX
C
      IF (NUMBSP(0,1).EQ.0) NUMBSP(0,1)=IZ_FIX
      IF (NUMBSP(1,1).EQ.0) NUMBSP(1,1)=IZ_FIX
C
      IF (IF_THO.EQ.0) THEN
C
          EFERMN=FERINI(0)
          DELTAN=DELINI(0)
          EFER2N=FE2INI(0)
C
          EFENIN=0.0D0
          EFENOU=EFERMN
          EF2NIN=0.0D0
          EF2NOU=EFER2N
C
          EFERMP=FERINI(1)
          DELTAP=DELINI(1)
          EFER2P=FE2INI(1)
C
          EFEPIN=0.0D0
          EFEPOU=EFERMP
          EF2PIN=0.0D0
          EF2POU=EFER2P
C
          EFERMA=FERINA
          DELTAA=DELINA
C
      END IF
C
C=======================================================================
C         SETTING SWITCH "NOSHIM" THAT BLOCKS PRINTING OF SHIFTED
C         MAGNETIC MOMENTS UNTIL THEIR CALCULATION IS  DEVELOPED.
C         WHEN THE PARITY IS BROKEN, THE ROTATED MAGNETIC MOMENTS
C         CANNOT BE PRINTED EITHER BECAUSE THEY SHOULD CORRESPOND
C         TO A ROTATION OF SHIFTED MOMENTS.
C=======================================================================
C
      NOSHIM=0
      IF (ISIQTY.NE.1) NOSHIM=1
C
C=======================================================================
C         WITHOUT ROTATION (IROTAT=0) AND WITHOUT BREAKING THE Y-SIMPLEX
C         SYMMETRY (ISIMPY=1), THE TIME-REVERSED BLOCK IS NOT EXPLICITLY
C         CALCULATED. THIS IS DONE BY USING MREVER=0, I.E. BY PERFORMING
C         THE LOOPS OVER IREVER ONLY FOR IREVER=0.  IN SUCH A CASE,  THE
C         ARRAYS FOR IREVER=1 REMAIN UNDEFINED.
C
C
C         IROTAT:    0  1
C         ISIMPY: 0  1  1  <--- MREVER
C                 1  0  1  <-'
C
C=======================================================================
C
      MREVER=1
      IF (ISIMPY.EQ.1.AND.IROTAT.NE.1) MREVER=0
C
C=======================================================================
C         SETTING THE VALUES OF LIMITS FOR ISOSPIN PROJECTION
C=======================================================================
C          ATTENTION!  KSOSTZ AND ISOSTZ BOTH DENOTE THE  FIXED  ISOSPIN
C                      PROJECTION  USED  IN  THE   1D-ISOSPIN-PROJECTION
C                      CALCULATIONS. HOWEVER:
C                      KSOSTZ IS READ IN THE INPUT DATA AND THUS IS  NOT
C                             SUPPOSED TO BE LATER CHANGED BY THE  CODE.
C                      ISOSTZ IS INITIALIZED TO KSOSTZ OR  IN_FIX-IZ_FIX
C                             AND THEN  USED  INTERNALLY  BY  THE  CODE.
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.66H)  AND (2.84),  VARIABLES
C                       ISOSTZ, ISOSMI, AND ISOSMA, WHERE NOT GIVEN  ANY
C                       VALUE UNLESS IPRISO=1 OR IPRIS3=1. THIS HAS BEEN
C                       CAUSING PROBLEMS IN PROANG WHENEVER THE  ANGULAR
C                       MOMENTUM PROJECTION WAS REQUESTED THROUGH  USING
C                       IPRROT=1. THIS BUG WAS CORRECTED  ON  11/01/2018
C                       IN VERSION (2.84A).
C=======================================================================
C
      ISOSTZ=KSOSTZ
      ISOSMI=KSOSMI
      ISOSMA=KSOSMA
      IPRGCM=0
C
      IF (IPRROT.GE.1) THEN
          IPRGCM=IPRROT
      END IF
C
      IF (IPRISO.GE.1) THEN
          ISOSTZ=IN_FIX-IZ_FIX
          ISOSMI=ABS(ISOSTZ)
          ISOSMA=ISOSMI+ISOSAD
          IPRGCM=IPRISO
      END IF
C
      IF (IPRIS3.GE.1) THEN
          ISOSTZ=KSOSTZ
          ISOSMI=KSOSMI
          ISOSMA=KSOSMA
          IPRGCM=IPRIS3
      END IF
C
      IF (IPRNUM.GE.1) THEN
          IPRGCM=IPRNUM
      END IF
C
      IF (IPRVEC.GE.1) THEN
          IPRGCM=IPRVEC
      END IF
C
      IF (IPRPTY.GE.1) THEN
          IPRGCM=IPRPTY
      END IF
C
C=======================================================================
C         TESTING THE CONSISTENCY OF THE PROJECTION SWITCHES
C=======================================================================
C
      INCONS=0
C
      IF (IPRROT.GE.1.AND.IPRROT.NE.IPRGCM) INCONS=1
      IF (IPRISO.GE.1.AND.IPRISO.NE.IPRGCM) INCONS=1
      IF (IPRIS3.GE.1.AND.IPRIS3.NE.IPRGCM) INCONS=1
      IF (IPRNUM.GE.1.AND.IPRNUM.NE.IPRGCM) INCONS=1
      IF (IPRVEC.GE.1.AND.IPRVEC.NE.IPRGCM) INCONS=1
      IF (IPRPTY.GE.1.AND.IPRPTY.NE.IPRGCM) INCONS=1
C
      IF (INCONS.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,20(1H/),
     *        '' INCONSISTENT PROJECTION SWITCHES  '',20(1H/),/,20(1H/),
     *        '' FOUND ON THE INPUT FILE           '',20(1H/),/)')
C
          WRITE(NFIPRI,'(/,20(1H/),'' IPRROT ='',I2,
     *                             '' IPRISO ='',I2,
     *                             '' IPRIS3 ='',I2,2X,20(1H/),/,
     *                     20(1H/),'' IPRNUM ='',I2,
     *                             '' IPRVEC ='',I2,
     *                             '' IPRPTY ='',I2,2X,20(1H/),/,
     *                     20(1H/),''         '',2X,
     *                             ''         '',2X,
     *                             '' IPRGCM ='',I2,2X,20(1H/),/)')
     *    IPRROT,IPRISO,IPRIS3,
     *    IPRNUM,IPRVEC,IPRPTY,
     *                  IPRGCM
C
          STOP 'INCONSISTENT PROJECTION SWITCHES FOUND ON INPUT FILE'
C
      END IF
C
C=======================================================================
C         SETTING THE SWITCH THAT HANDLES SAVING ARRAYS "WAVOCC" AND
C         "V_OCCU"
C=======================================================================
C
      ISAOCC=0
      IF (IADBAT.EQ.1) ISAOCC=1
C
C=======================================================================
C         SETTING THE PARAMETERS THAT HANDLE THE ANGULAR-MOMENTUM
C         PROJECTION, CALCULATION OF THE GCM KERNELS, AND TOMOGRAPHY
C=======================================================================
C
      ISAWAV=0
      IF (IPRGCM.GE.1.OR.IRENMA.GE.1.OR.IRENIN.GE.1.OR.IWRWAV.GE.1.OR.
     *    ABS(ITOMOZ).EQ.2)
     *    ISAWAV=1
      IKERNE=0
C
C=======================================================================
C         SETTING THE PARAMETER THAT HANDLES ANGULAR-MOMENTUM PROJECTION
C         OF BLOCKED STATES
C=======================================================================
C
      CALL INIADD
      IF ((       IABS(IDSIGN) .EQ.1.OR.       IABS(IDSIMN) .EQ.1.OR.
     *     MAXVAL(IABS(IDSIQN)).EQ.1.OR.MAXVAL(IABS(IDSIZN)).EQ.1)
     *     .AND.IPRGCM.GE.1) THEN
C
         LPRODR(0)=1
      ELSE
         LPRODR(0)=0
C
      END IF
C
      IF ((       IABS(IDSIGP) .EQ.1.OR.       IABS(IDSIMP) .EQ.1.OR.
     *     MAXVAL(IABS(IDSIQP)).EQ.1.OR.MAXVAL(IABS(IDSIZP)).EQ.1)
     *    .AND.IPRGCM.GE.1) THEN
C
         LPRODR(1)=1
      ELSE
         LPRODR(1)=0
C
      END IF
      IPRODD=MAXVAL(LPRODR)
C
C=======================================================================
C         SETTING THE NAMES OF SURFACE OR SCHIFF MOMENTS
C=======================================================================
C
                       NAMSIF=NAMSUR
      IF (ISCHIF.EQ.1) NAMSIF=NAMSCH
C
C=======================================================================
C         SETTING THE VALUES OF LINEAR LAGRANGE PARAMETERS
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            GALMUQ(LAMBDA,MIU)=QLINEA(LAMBDA,MIU)
            GALMUS(LAMBDA,MIU)=SLINEA(LAMBDA,MIU)
C
            GALMUV(LAMBDA,MIU)=VLINEA(LAMBDA,MIU)
C
            GALMTW(LAMBDA,MIU,:)=0.0D0
C
         END DO
      END DO
C
C=======================================================================
C         SETTING THE VALUES OF SPIN LAGRANGE PARAMETERS
C=======================================================================
C
      GALSPI=DALSPI
C
C=======================================================================
C         SETTING THE VALUES OF ISOSPIN LAGRANGE PARAMETERS
C=======================================================================
C
      GALISO=DALISO
C
C=======================================================================
C         SETTING THE PARTICLE NUMBERS
C=======================================================================
C
      PARNUN=IN_FIX
      PARNUP=IZ_FIX
      PARNUA=IN_FIX+IZ_FIX
C
C=======================================================================
C         SETTING THE FLAG THAT STOPS THE SYMMETRIZATION OF DENSITIES
C         IN "DENSHF" WHEN VARIOUS FINITE-RANGE FIELDS ARE USED.
C=======================================================================
C      ATTENTION: BETWEEN VERSIONS 2.72C AND 3.00T,  THE  SYMMETRIZATION
C                 OF DENSITIES WAS IN "DENSHF" ENFORCED FOR FINITE-RANGE
C                 FUNCTIONALS BY DEFINING AND TRANSFERRING THE  VARIABLE
C                 "DOSYMM". THIS PREVENTED COLLAPSES  OF  ITERATIONS  IN
C                 CASES WHEN THE ZERO-RANGE AND FINITE-RANGE TERMS  WERE
C                 SIMULTANEOUSLY INCLUDED.  HOWEVER,  THE  EXACT-COULOMB
C                 CASE WAS THEN ALSO ADDED TO THE SAME CONDITION. AS  IT
C                 TURNS OUT, THE COLLAPSES IN QUESTION DO NOT HAPPEN FOR
C                 THE EXACT-COULOMB CASE; THEREFORE,  ON  25/11/2020  IN
C                 VERSION 3.00U, THE EXACT-COULOMB CASE WAS REMOVED FROM
C                 THE VARIABLE "DOSYMM". ALTHOUGH THIS WAS NOT REALLY  A
C                 BUG, THE ABSENCE OF SYMMETRIZATION COULD RESULT IN THE
C                 CODE DEPARTING FROM  THE  PRINCIPAL-AXIS  ORIENTATION.
C                 MOREOVER, THE ABSENCE OF SYMMETRIZATION WAS NOT AT ALL
C                 COMMUNICATED TO THE USER.
C=======================================================================
C
      DOSYMM=I_YUKA.LE.1        .AND.
     *       I_GOGA.LE.1        .AND.       IGOGPA.LE. 1.AND.
     *       I_REGA.LE.1        .AND.       IREGPA.LE. 1.AND.
     *       I_SEPA.LE.1        .AND.       ISEPPA.LE. 1.AND.
     *       MAXVAL(I_FSTA).LE.1.AND.MAXVAL(IFSTPA).LE.1
C
C=======================================================================
C         SETTING THE PARAMETERS OF THE SEPARABLE INTERACTION.
C=======================================================================
C
      IRESEP=IVISEP
C
      DO INSEPA=1,IRESEP
C
         SEPVCC(INSEPA,1)=SEPVIC(INSEPA,1)+SEPFAC(INSEPA,1)
     *                                    *SEPERR(INSEPA,1)
         SEPVCC(INSEPA,2)=SEPVIC(INSEPA,2)+SEPFAC(INSEPA,2)
     *                                    *SEPERR(INSEPA,2)
         SEPVCC(INSEPA,3)=SEPVIC(INSEPA,3)+SEPFAC(INSEPA,3)
     *                                    *SEPERR(INSEPA,3)
         SEPVCC(INSEPA,4)=SEPVIC(INSEPA,4)+SEPFAC(INSEPA,4)
     *                                    *SEPERR(INSEPA,4)
C
         SEPTCC(INSEPA,1)=SEPVCC(INSEPA,1)
         SEPTCC(INSEPA,2)=SEPVCC(INSEPA,2)/SEPVCC(INSEPA,1)
         SEPTCC(INSEPA,3)=SEPVCC(INSEPA,3)/SEPVCC(INSEPA,1)
         SEPTCC(INSEPA,4)=SEPVCC(INSEPA,4)/SEPVCC(INSEPA,1)
C
      END DO
C
C=======================================================================
C         SETTING THE PARAMETERS OF THE SKYRME INTERACTION "INPU".
C=======================================================================
C
      T0_INP = T0_DAT + T0_ERR * T0_FAC
      X0_INP = X0_DAT + X0_ERR * X0_FAC
C
      T1_INP = T1_DAT + T1_ERR * T1_FAC
      X1_INP = X1_DAT + X1_ERR * X1_FAC
C
      T2_INP = T2_DAT + T2_ERR * T2_FAC
      X2_INP = X2_DAT + X2_ERR * X2_FAC
C
      T3_INP = T3_DAT + T3_ERR * T3_FAC
      X3_INP = X3_DAT + X3_ERR * X3_FAC
C
      WW_INP = WW_DAT + WW_ERR * WW_FAC
      PO_INP = PO_DAT + PO_ERR * PO_FAC
C
C=======================================================================
C         SETTING PARAMETER "LDPNMX" THAT DEFINES THE NUMBER OF ISOSPIN
C         BLOCKS OF DENSITIES AND FIELDS
C=======================================================================
C
                                       LDPNMX=1
      IF (IPNMIX.NE.1.AND.IPRGCM.GE.1) LDPNMX=3
      IF (IPNMIX.EQ.1)                 LDPNMX=3
C
C=======================================================================
C         SETTING THE PAIRING STRENGTH PARAMETERS
C=======================================================================
C
      IF (NOZEPA.EQ.1) THEN
C
          PRHO_N=0.0D0
          PRHODN=0.0D0
          PRHOSN=0.16
          POWERN=1.0
C
          PRHO_P=0.0D0
          PRHODP=0.0D0
          PRHOSP=0.16
          POWERP=1.0
C
          PRHO_T=0.0D0
          PRHODT=0.0D0
          PRHOST=0.16
          POWERT=1.0
C
      ELSE
C
          PRHO_N=PRHD_N
          PRHODN=PRHDDN
          PRHOSN=PRHDSN
          POWERN=POWDRN
C
          PRHO_P=PRHD_P
          PRHODP=PRHDDP
          PRHOSP=PRHDSP
          POWERP=POWDRP
C
          PRHO_T=PRHD_T
          PRHODT=PRHDDT
          PRHOST=PRHDST
          POWERT=POWDRT
C
      END IF
C
C=======================================================================
C         SETTING THE INDEX OF HFB DEGRADED TO HF
C=======================================================================
C
      IND2HF(:)=0
C
C=======================================================================
C         SETTING THE ARRAY CONTAINING THE SWITCHES RELATED TO THE
C         OCCUPATIONS OF LAST ORBITALS IN OMEGA BLOCKS
C=======================================================================
C
      LASTAL(0)=LASTAN
      LASTAL(1)=LASTAP
C
C=======================================================================
C         SETTING THE ARRAYS CONTAINING REGULARIZED COUPLING CONSTANTS
C=======================================================================
C
      IREREG=100
      N3LORD=1
C
      INCONS=0
C
      DO KREJAL=1,4
         IF (IREREJ(KREJAL).NE.100) THEN
             DO LREJAL=1,4
                IF (IREREJ(LREJAL).NE.100) THEN
                    IF (IREREJ(KREJAL).EQ.IREREJ(LREJAL).AND.
     *                  NREREJ(KREJAL).EQ.NREREJ(LREJAL)) THEN
                        IF (IREREG.EQ.100) THEN
                            IREREG=IREREJ(KREJAL)
                            N3LORD=NREREJ(KREJAL)
                        ELSE
                            IF (IREREJ(KREJAL).NE.IREREG.OR.
     *                          NREREJ(KREJAL).NE.N3LORD) INCONS=1
                        END IF
                    ELSE
                        INCONS=1
                    END IF
                END IF
             END DO
         END IF
      END DO
C
      IF (IREREG.EQ.100) IREREG=0
C
      IF (INCONS.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,20(1H/),
     *        '' INCONSISTENT REGULARIZED COUPLING '',20(1H/),/,20(1H/),
     *        '' CONSTANTS FOUND ON THE INPUT FILE '',20(1H/),/)')
          DO KREJAL=1,4
             IF (IREREJ(KREJAL).NE.100) THEN
C
                WRITE(NFIPRI,'(/,20(1H/),'' IREREJ('',I1,'') = '',I3,2X,
     *                                   '' NREREJ('',I1,'') = '',I3,1X,
     *                                                        20(1H/))')
     *           KREJAL,IREREJ(KREJAL),
     *           KREJAL,NREREJ(KREJAL)
C
             END IF
          END DO
C
          STOP 'INCONSISTENT REGULARIZED COUPLING CONSTANTS FOUND'
C
      END IF
C
      IF (IREREJ(1).NE.100.AND.IREREJ(4).NE.100)
     *
     *    STOP 'IREREJ(1)<>100 NOT ALLOWED TOGETHER WITH IREREJ(4)<>100'
C
      IF (IREREJ(1).NE.100) THEN
C
          IF (IREREG.GE.1) THEN
C
              IF (IREREG.GT.NDREGA) STOP ' INCREASE NDREGA IN HFODD 1'
C
              REGVCC=REJVCC
C
          END IF
C
      END IF
C
      IF (IREREJ(4).NE.100) THEN
C
          IF (IREREG.GE.1) THEN
C
              IF (IREREG.GT.NDREGA) STOP ' INCREASE NDREGA IN HFODD 2'
C
              REGTCC=REJTCC
C
              DO INREGA=1,IREREG
C
                 REGVCC(INREGA,1)=REGTCC(INREGA,1)
                 REGVCC(INREGA,2)=REGTCC(INREGA,1)*REGTCC(INREGA,2)
                 REGVCC(INREGA,3)=REGTCC(INREGA,1)*REGTCC(INREGA,3)
                 REGVCC(INREGA,4)=REGTCC(INREGA,1)*REGTCC(INREGA,4)
C
              END DO
C
          END IF
C
      END IF
C
      IF (IREREJ(1).NE.100.OR.IREREJ(4).NE.100) THEN
C
          DO INREGA=1,IREREG
C
             REGVCC(INREGA,1)=REGVCC(INREGA,1)+REJFAC(INREGA,1)
     *                                        *REJERR(INREGA,1)
             REGVCC(INREGA,2)=REGVCC(INREGA,2)+REJFAC(INREGA,2)
     *                                        *REJERR(INREGA,2)
             REGVCC(INREGA,3)=REGVCC(INREGA,3)+REJFAC(INREGA,3)
     *                                        *REJERR(INREGA,3)
             REGVCC(INREGA,4)=REGVCC(INREGA,4)+REJFAC(INREGA,4)
     *                                        *REJERR(INREGA,4)
C
             REGTCC(INREGA,1)=REGVCC(INREGA,1)
             REGTCC(INREGA,2)=REGVCC(INREGA,2)/REGVCC(INREGA,1)
             REGTCC(INREGA,3)=REGVCC(INREGA,3)/REGVCC(INREGA,1)
             REGTCC(INREGA,4)=REGVCC(INREGA,4)/REGVCC(INREGA,1)
C
                                    FACTOR= REGWID**(2*INREGA-2)
                                    FACTOR= FACTOR*2**(INREGA-1)
             IF (MOD(INREGA,2).EQ.0)FACTOR=-FACTOR
C
             IF (N3LORD.GE.0) THEN
C
                 DO INFORC=1,NDFORC
C
                    REGBCC(INREGA,INFORC)=REGVCC(INREGA,INFORC)/FACTOR
C
                 END DO
C
             ELSE
C
                 REGBCC=0.0D0
C
             END IF
C
         END DO
C
      END IF
C
C=======================================================================
C         SETTING THE ARRAY CONTAINING THE LIST OF MIXED CONFIGURATIONS
C=======================================================================
C
      MIXNUM=0
      MICONF(:)=0
C
      DO IUCONF=1,ILCONF
C
         IF (INCONF(IUCONF).GT.0) THEN
C
             MIXNUM=MIXNUM+1
             MICONF(MIXNUM)=IUCONF
C
         END IF
C
      END DO
C
C=======================================================================
C         SETTING THE SWITCH THAT DEFINES THE ATFHF(B) CALCULATION IN
C         "DENSHF"
C=======================================================================
C
      I_SING=0
C
C=======================================================================
C         HERE WE INITIALIZE THE SWITCHES THAT GOVERN THE CALCULATION OF
C         THE WIGNER D FUNCTIONS IN "DSMALH".
C=======================================================================
C
      ISWIND=0
      NUANGU=0
C
C=======================================================================
C         INCLUDING THE EFFECTIVE GYROSCOPIC FACTORS
C=======================================================================
C
      GESPIN(0)=G_SPIN(0)*GYRSPN
      GEORBI(0)=G_ORBI(0)
C
      GESPIN(1)=G_SPIN(1)*GYRSPP
      GEORBI(1)=G_ORBI(1)*GYRORP
C
C=======================================================================
C         END OF INPUT-RELATED PREDEFINITIONS
C=======================================================================
C
C=======================================================================
C         READING THE INPUT DATA FROM THE WOODS-SAXON FILE
C=======================================================================
C
      IF (IREAWS.EQ.1.AND.batch_init.EQ.1) THEN
C
          OPEN(NFIWOO,FILE=FILWOO,STATUS='OLD',IOSTAT=IERROR,
     *                                         FORM='UNFORMATTED')
C
          CALL READWS(INNUMB,IZNUMB,FCHOM0,R0PARM,HOMEGA,
     *                       NFIWOO,EPSHER,NOSCIL,NLIMIT,
     *                       ENECUT,LAMMAX,ISOTRO,CVOLFC,
     *                       CMSXFC,CMSYFC,CMSZFC,XMOMFC,
     *                              YMOMFC,ZMOMFC,GPAIRN,
     *                                            GPAIRP)
C
          CLOSE(NFIWOO)
C
          CALL DEFPRI(LAMMAX,INNUMB,IZBASI)
C
      ELSE
C
C=======================================================================
C         OPENING THE COMMON FILBAP AND FILBAC FILE
C=======================================================================
C
          IF (FILBAP.EQ.FILBAC) THEN
C
              NFIBAP=NFIBAC
C
              IF (IBCONT.GE.1) THEN
C
                  IERROR=0
                  OPEN(NFIBAP,FILE=FILBAP,STATUS='OLD',IOSTAT=IERROR,
     *                        FORM='FORMATTED')
C
                  IF (IERROR.NE.0) THEN
C
                      WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                             ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                     FILBAP
C
                      STOP ' FILE FILBAP NOT FOUND ON DISC'
C
                  END IF
C
              ELSE
C
                  IF (IWRIBA.NE.-1) THEN
                      OPEN(NFIBAC,FILE=FILBAC,STATUS='UNKNOWN',
     *                            FORM='FORMATTED')
                  END IF
C
              END IF
C
          ELSE
C
C=======================================================================
C         OPENING THE FILBAP FILE
C=======================================================================
C
              IF (IBCONT.GE.1) THEN
C
                  IERROR=0
                  OPEN(NFIBAP,FILE=FILBAP,STATUS='OLD',IOSTAT=IERROR,
     *                        FORM='FORMATTED')
C
                  IF (IERROR.NE.0) THEN
C
                      WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                             ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                     FILBAP
C
                      STOP ' FILE FILBAP NOT FOUND ON DISC'
C
                  END IF
C
              END IF
C
C=======================================================================
C         OPENING THE FILBAC FILE
C=======================================================================
C
              IF (IWRIBA.NE.-1) THEN
                  OPEN(NFIBAC,FILE=FILBAC,STATUS='UNKNOWN',
     *                        FORM='FORMATTED')
              END IF
C
          END IF
C
C=======================================================================
C         READING THE BASIS DEFORMATIONS FROM THE BASIS FILE
C=======================================================================
C
          IF (IBCONT.GE.1) THEN
C
C             INPFLD=1 => THE FILE WITH THE UNIT NUMBER  NFIBEP WILL BE
C                         USED TO  R E A D  BETA DEFORMATIONS FROM  THE
C                                                          PREVIOUS RUN
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *            1H*,''  CALLING SUBROUTINE "RECBAS" TO READ'',
     *                '' THE BASIS FILE OBTAINED PREVIOUSLY'',5X,1H*,/,
     *            1H*,2X,A68,                   7X,1H*,/,1H*,77X,1H*)')
     *
     *                FILBAP
C
              INPFLD=1
              IERROR=0
C
              CALL RECBAS(NFIBAP,NFIBAC,INPFLD,IERROR)
C
              IF (IERROR.NE.0) STOP 'BASIS FILE CORRUPTED - STOP HERE'
C
          END IF
C
C=======================================================================
C         NEW VERSION, LESZEK PROCHNIAK, ON 11/12/2020, FROM (3.01I)
C=======================================================================
C
              CALL GEOMFC(INNUMB,IZNUMB,FCHOM0,R0PARM,HOMEGA,
     *                                  LAMMAX,ISOTRO,CVOLFC,
     *                                  CMSXFC,CMSYFC,CMSZFC,
     *                                  XMOMFC,YMOMFC,ZMOMFC,
     *                                                ITWCEN)
C
      END IF
C
C=======================================================================
C         HERE BEGINS THE INITIALIZATION PHASE OF THE PROGRAM
C=======================================================================
C
C=======================================================================
C         CHOICE OF THE SKYRME FORCE PARAMETERS
C=======================================================================
C
      CALL PARAMS(SKYRME,LANODD,LANSCA,HBMSAT,RHOSAT,EFFSAT,ISTAND,
     *            KETA_J,KETA_W,KETACM,KETA_M,KETA_P,KETA_T,KETAPA,
     *            JETA_J,JETA_W,JETACM,JETA_M,JETA_P,JETA_T,JETAPA)
C
C=======================================================================
C         ALLOCATING SPACE FOR SKYRME DENSITIES AND FIELDS
C=======================================================================
C         TWO-CENTRE BASIS OPTION:
C
C         LDTWCE: NUMBER OF TERMS NEEDED TO COMPUTE THE HAMILTONIAN AND
C         ENERGY OF THE FUNCTIONAL, WHERE FOUR WAVE FUNCTION ARE INVOL-
C         VED (SEE COMMENTS BEFORE DENSHF).
C
C         NBLDEN: NUMBER OF TWO-CENTRE BASIS BLOCKS NEEDED TO BUILD THE
C         HAMILTONIAN AND THE DENSITY MATRIX.
C
C                           |        |        |
C                           |  C1C1  |  C1C2  |
C                           |        |        |
C                            -----------------
C                           |        |        |
C                           |  C2C1  |  C2C2  |
C                           |        |        |
C
C          WHERE C STANDS FOR CENTRE. ONLY THREE ARE COMPUTED DUE TO
C          HERMITICITY.
C=======================================================================
C
      CALL TWC_INDGEN(ITWCEN)
C
      IF (ITWCEN.EQ.1) THEN
C
          LDTWCE=1
          NBLDEN=1
          LDTWDD=1  !EXTRA TERMS DENSITY-DEPENDENT INTERACTIONS
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          LDTWCE=16
          NBLDEN=3
                            LDTWDD=22
          IF (IPAIRI.EQ.1)  LDTWDD=24
C
          IF (LDTWDD.GT.NDTWDD) STOP 'LDTWDD > NDTWDD'
C
      END IF
C
      CALL ALLODE(LDPNMX,IGRAIN,LDTWCE,LDTWDD)
C
      CALL ALLOVF(LDPNMX,LDTWCE)
C
C=======================================================================
C         ALLOCATING SPACE FOR SAVING DENSITY MATRIX AND PAIRING TENSOR
C=======================================================================
C
      IF (I_YUKA.GE.1.OR.I_GOGA.GE.1.OR.I_REGA.GE.1.OR.I_SEPA.GE.1.OR.
     *    I_COUA.GE.1.OR.MAXVAL(I_FSTA).GE.1.OR.MAXVAL(MAG2BC).GE.1.OR.
     *    ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.
     *    JETACM.GE.1.OR.KETA_R.GE.1)
     *
     *    CALL ALLORH(LDPNMX,ISIMPY)
C
      IF (IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1.OR.
     *    ICOUPA.GE.1.OR.MAXVAL(IFSTPA)       .GE.1.OR.
     *  ((JETACM.GE.1.OR.KETA_R.GE.1).AND.IPAHFB.GE.1))
     *
     *    CALL ALLOKA(LDPNMX,ISIMPY)
C
C=======================================================================
C         CALCULATING THE THREE-BODY-GRADIENT COUPLING CONSTANTS BASED
C         ON THE EV4 SUBROUTINES
C=======================================================================
C
      IF (IGRAIN.EQ.1) CALL TRACPL
C
C=======================================================================
C        LOGICAL VARIABLE "REA2PP" DECIDES ON WHETHER OR NOT WE NEED THE
C        SECOND ARRAY "FIP2DE", WHICH CONTAINS ADDITIONAL PAIRING FIELDS
C        REQUIRED ONLY FOR TRANSLATIONAL AND ROTATIONAL CORRECTIONS  AND
C        FOR THE FINITE-RANGE PAIRING
C=======================================================================
C
      REA2PP=JETACM.EQ.2.OR.KETA_R.EQ.2.OR.
     *       IGOGPA.GE.2.OR.IREGPA.GE.2.OR.ISEPPA.GE.2.OR.
     *       ICOUPA.GE.2.OR.MAXVAL(IFSTPA).GE.2
C
C=======================================================================
C         CHOICE OF THE GOGNY FORCE PARAMETERS
C=======================================================================
C
      CALL PARGOG(I_GOGA,IGOGPA,I_REGA,GOGNAM)
C
C=======================================================================
#if(USE_FITS==1)
      CALL FITINP(PARINP,NUMINP,I_TYPE,N3LORD)
#endif
C=======================================================================
C         CHOICE OF THE REGULARIZED-DELTA FORCE PARAMETERS
C=======================================================================
C
      CALL PARREG(I_REGA,N3LORD)
C
C=======================================================================
C         CHOICE OF THE SEPARABLE FORCE PARAMETERS
C=======================================================================
C
      IF (I_SEPA.GE.1.OR.ISEPPA.GE.1) CALL PARSEP
C
C=======================================================================
C         CHOICE OF THE FINITE-RANGE SPIN-ORBIT AND TENSOR FORCE
C         PARAMETERS
C=======================================================================
C
      IF (MAXVAL(I_FSTA).GE.1.OR.MAXVAL(IFSTPA).GE.1) CALL PARFST
C
C=======================================================================
C         TESTING INTEGRITY OF THE INPUT DATA
C=======================================================================
C
      CALL TESDAT(IOPTGS,NOSCIL,NLIMIT,ISTAND,
     *            KETA_J,KETA_W,KETACM,KETA_M,
     *                   KETA_P,KETA_T,KETAPA,
     *                   JETACM,JETA_T,JETAPA,
     *                                 NOZEPA,
     *                          ITWOLI,KETA_R,
     *                          KETAJ2,KETAT2,
     *                   ISIMPY,ISIGNY,ISIQTY,
     *                   ISIMTX,JSIMTY,ISIMTZ,
     *                                 IAXIAP,
     *                   NMUCON,NMUCOU,NMUPRI,
     *                          ICOUMD,ICOUMX,
     *            ISCHIF,NSICON,NSIPRI,IDOPLM,
     *                   NMACON,NMAPRI,NMAORD,
     *                   NASCON,NASPRI,NASORD,
     *                                 NRAORD,
     *            NMURED,NMARED,NASRED,NSIRED,
     *                   NEXBET,IPRIBE,IPRIBL,
     *            NUPING,EPSPNG,EPSITE,EPSCON,
     *                          NULAST,NUCONS,
     *            ISYMDE,INIROT,INIINV,INIKAR,
     *                          IWRIOL,IWRIBA,
     *                          IRENMA,IRENIN,
     *            IFRWAV,ITOWAV,IWRWAV,ISAKER,
     *     ISLPRI,ISUPRI,IENPRI,ISRPRI,IMIPRI,
     *                   IKEPRI,IRMPRI,IELPRI,
     *            QMUCUT,QMACUT,QASCUT,QSICUT,
     *                   IPRGCM,IPROMI,IPROMA,
     *                   NUAKNO,NUBKNO,KPROJE,
     *                   NATKNO,NBTKNO,ISOSTZ,
     *            NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *     IFERME,IBETME,IIFERR,ITFERR,ISFERR,
     *     ISOSAD,ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *            IPAKER,IPAK3D,IPAALL,KFIKER,
     *            NUASTA,NUASTO,NUGSTA,NUGSTO,
     *            NATSTA,NATSTO,NGTSTA,NGTSTO,
     *            NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *                   ICHFLI,IPAFLI,IREFLI,
     *                   ISPFLI,ISHFLI,IFLIPI,
     *                          NOITER,IREAWS,
     *                   ILIBAS,IN_FIX,IZ_FIX,
     *                          INNUMB,IZNUMB,
     *                                 IDESTA,
     *            IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                          IQUNIL,NILXYZ,
     *                   MREVER,IROTAT,IQPSTA,
     *                   IPAIRI,IPAHFB,JPABCS,
     *            IONISH,ITWOBA,NUQEVE,IMFHFB,
     *                   ECUTOF,LIMQUA,LAMCUT,
     *                                 IPNMIX,
     *                          LIPKIN,LIPKIP,
     *                          LIPNON,LIPNOP,
     *                   IPNPRJ,NPPNPN,NPPNPP,
     *     I_SLOW,SLOWEV,SLOWOD,SLOWPA,SLOWLM,
     *                          IFEFIN,IFEFIP,
     *                          IF2FIN,IF2FIP,
     *                          IFERAN,IFERAP,
     *                          IDEFIN,IDEFIP,
     *            INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *            INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                   INSIMN,IRSIMN,IDSIMN,
     *                   INSIMP,IRSIMP,IDSIMP,
     *                   INSIQN,IPSIQN,IDSIQN,
     *                   INSIQP,IPSIQP,IDSIQP,
     *                          INSIZN,IDSIZN,
     *                          INSIZP,IDSIZP,
     *                          IFIBLN,INIBLN,
     *                          IFIBLP,INIBLP,
     *            ICOTYP,ICOUDI,ICOUEX,ICOULO,
     *                          IYUTYP,I_YUKA,
     *                          I_GOGA,IGOGPA,
     *                          I_REGA,IREGPA,
     *                          I_SEPA,ISEPPA,
     *                          I_COUA,ICOUPA,
     *                          N3LORD,N3SERD,
     *                   ICONTI,IPCONT,IOCONT,
     *                   ISCONT,ITCONT,IACONT,
     *            IYCONT,IGCONT,IGPCON,IECONT,
     *            ILCONT,IFCONT,IMCONT,IRCONT,
     *     IFSHEL,IF_RPA,IWRIQU,IWRIRM,IF_THO,
     *                          LDPNMX,SKYRME,
     *                          IFRAGM,MIN_QP,
     *                   ILIPON,ILIPOP,GAUSHI,
     *     NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,
     *     NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,
     *                          LASTAN,LASTAP,
     *                                 ITWCEN,
     *                                 IADBAT,
     *                          NEWGOG,NEWCOU,
     *                          IPOTHO,IVIPRI,
     *                                 IFRCNT)
C
C=======================================================================
C         CALCULATING  THE  HARMONIC - OSCILLATOR  BASIS  PARAMETERS
C=======================================================================
C
      CALL SETBAS(IN_FIX,IZ_FIX,IREAWS,NOSCIL,NLIMIT,ENECUT,
     *                          IOPTGS,JETACM,ISPHER,INIROT,
     *                          IPRGCM,NUAKNO,ICOUDI,ICOUEX,
     *                                 E_EFFE,IF_THO,ITWCEN,
     *                                        NLIMTW,ENECTW)
C
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C      RUNNING HFBTHO
C=======================================================================
C
      IF (IF_THO.GE.1) THEN
C
          I_FAIL=0
C
#if(USE_MPI==1)
          WRITE(FILTHO,'(''t'',I6.6,''.hel'')') INDJOB
#else
          WRITE(FILTHO,'(''t'',I3.3,''_'',I3.3,''.hel'')')
     *                             IZ_FIX,IN_FIX
#endif
C
C          Read HFODD field file and transform the matrix of the mean-field
C          and pairing field into HFBTHO basis convention
C
          IF (IF_THO.EQ.2) THEN
C
C              First read traditional record file, which contains many
C              useful quantities at convergence
C
              WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *           ''*  CALLING SUBROUTINE "RECORD" TO READ'',
     *           '' THE REPLAY FILE OBTAINED PREVIOUSLY    *'',/,
     *           ''*'',2X,A68,7X,''*'')') FILREP
C
              INPFLD=1
              IERROR=0
C
              CALL RECORD(NFIREP,NFIREC,INPFLD,NUMITE,
     *                    IVEREP,NXHERM,NYHERM,NZHERM,
     *                                  IPCONT,ILCONT,
     *                           ISCONT,ITCONT,IACONT,
     *                                  IMCONT,IRCONT,
     *                                  IRENMA,IRENIN,
     *                                  LIPKIN,LIPKIP,
     *                                  REFERN,REFERP,
     *                                  REDELN,REDELP,
     *                                  REFE2N,REFE2P,
     *                                  IDSIGN,IDSIGP,
     *                                  IDSIMN,IDSIMP,
     *                                  IDSIQN,IDSIQP,
     *                                  IDSIZN,IDSIZP,
     *                                         INIBLN,
     *                                         INIBLP,
     *                                  NMUMAX,NSIMAX,
     *                                  IPNMIX,ISHIFT,
     *                                  JETA_T,JETAPA,IERROR,
     *                                         LDTWCE,LDTWDD,
     *                                                IFRCNT)
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(
     *              '' ////////////////////////////////////////'',
     *              ''/////////////////////////////////////'',/,
     *              '' ////       WARNING: RECORD FILE IS CORRUPTED'',
     *              '' !                          /////'',/,
     *              '' ////                 - RESTART IS CANCELLED '',
     *              ''                            /////'',/,
     *              '' ////                 - CALCULATIONS WILL RES'',
     *              ''TART FROM SCRATCH           /////'',/,
     *              '' ////////////////////////////////////////'',
     *              ''/////////////////////////////////////'')')
C
              END IF
C
              WRITE(NFIPRI,'(''*'',77X,''*'',/,
     *            ''*  CALLING SUBROUTINE "RECFIL" TO READ'',
     *            '' THE FIELDS FILE OBTAINED PREVIOUSLY    *'',/,
     *            ''*'',2X,A68,7X,''*'',/,''*'',77X,''*'')')
     *              FILFIP
C
              INPFIL=1
              IFNTHO=0
C
              CALL RECFIL(NFIFIP,NFIFIC,INPFIL,ISIMPY,IPAHFB,
     *                                  IPNMIX,NOSCIL,NUMITE,
     *                           EFERMN,EFERMP,EFER2N,EFER2P,
     *                                  DELTAN,DELTAP,IFNTHO,
     *                                         NLIMIT,FILTHO,
     *                           ISGOGP,ISREGP,REA2PP,IVEFIP,
     *                                                ITWCEN)
C
              WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *           ''*  CALLING SUBROUTINE  CARCYL  TO TRANSFORM '',
     *           ''THE HFB MATRIX READ  FROM HFODD   *'',/,
     *           ''*  INTO THE CYLINDRICAL BASIS USED IN HFBTHO.'',
     *                33X,''*'')')
C
C              Strip the phase from the matrix and move into cylindrical
C              coordinates
C
              bz_THO = 1.0/HOMSCA(3,1)
              bp_THO = 1.0/SQRT(HOMSCA(1,1)*HOMSCA(2,1))
C
                                    force_parity_THO = .False.
              IF (ABS(ISIGNY).EQ.1) force_parity_THO = .True.
C
              CALL CARCYL(NOSCIL,IF_THO,bz_THO,bp_THO,
     *                        force_parity_THO,ITWCEN)
C
C              Change ordering of basis states
              CALL ToHFBTHO(NDTRAN,NDSPIN,NOSCIL,LDBASE,NOFCNS)
C
C              Write results in HFBTHO format
              unit_tho  = 92
              beta0_THO = ALPHAR(2,0)
C              Lagrange parameters
              DO L=1,8
                 multLag_tho(L) = RALMUQ(L,0)
              END DO
              CALL WriteHFBTHO(unit_tho,FILTHO,IN_FIX,IZ_FIX,NOSCIL,
     *                           REFERN,REFERP,REDELN,REDELP,REFE2N,
     *                           REFE2P,PRHO_N,PRHO_P,BZ_THO,BP_THO,
     *                           beta0_THO,multLag_tho)
C
              ITESTA=NUMITE+1
C
          END IF
C
C@@@ HFBTHO -HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
#if(USE_MPI==1)
          IF (batch_mode.EQ.1) THEN
              CALL batch(NFIREP,NFIREC,NFILIP,NFILIC,
     *                   FILREP,FILREC,FILLIP,FILLIC,
     *                   NUDATA,IF_THO,
     *                          NXHERM,NYHERM,NZHERM,IRENMA,IRENIN,
     *                   REFERN,REFERP,REDELN,REDELP,REFE2N,REFE2P,
     *                   IFIBLN,INIBLN,IFIBLP,INIBLP,NMUMAX,NSIMAX,
     *                                               NMUCON,ISHIFT,
     *                   ICONTI,IPCONT,ILCONT,IACONT,IGCONT,IGPCON,
     *                                 ISCONT,ITCONT,IMCONT,IRCONT,
     *                   IPAIRI,LIPKIN,LIPKIP,I_GOGA,IGOGPA,I_YUKA,
     *                                        ITWOLI,JETACM,KETA_R,
     *                   IPNMIX,Q_NECK,QACTUA,QORIGI,QINCRE,INDJOB,
     *                   batch_init)
          END IF
#endif
C
C          Input parameters for HFBTHO
C
          file_THO    = FILTHO
          output_THO  = NFIPRI
C
          Nshell_THO  = NOSCIL
          b0_THO      = (HOMSCA(1,1)*HOMSCA(2,1)*HOMSCA(3,1))
     *                  **(-1.0D0/3.0D0)
          bz_THO      = 1.0D0/HOMSCA(3,1)
          bp_THO      = 1.0D0/SQRT(HOMSCA(1,1)*HOMSCA(2,1))
          beta0_THO   = ALPHAR(2,0)
          b2_THO      = REAL(ALPHAC(2,0)) ! Deformation of the WS potential
          b4_THO      = REAL(ALPHAC(4,0)) ! Deformation of the WS potential
          neutron_THO = IN_FIX
          proton_THO  = IZ_FIX
          type_THO    = 1
          IF (LIPKIN.EQ.1.OR.LIPKIP.EQ.1) type_THO=-1
C
          niter_THO    = 400
          accuracy_THO = 1.D-5
          restart_THO  = -1
C
          functional_THO   = TRIM(SKYRME)
          initial_pair_THO = .False.
                                           coulomb_THO = 2
          IF (ICOUDI.EQ.0.AND.ICOUEX.EQ.0) coulomb_THO = 0
          IF (ICOUDI.EQ.1.AND.ICOUEX.EQ.0) coulomb_THO = 1
          IF (ICOUDI.EQ.1.AND.ICOUEX.EQ.1) coulomb_THO = 2
C
          VpairN_THO = PRHO_N
          VpairP_THO = PRHO_P
          Ecut_THO   = ECUTOF
          V1_THO     = 0.5D0
C
          n_blocking_THO = (/ 0, 0, 0, 0, 0 /)
          p_blocking_THO = (/ 0, 0, 0, 0, 0 /)
C
          DO L=1,8
             lambda_THO(L) = L
             active_THO(L) = IFLAGQ(L,0)
             expect_THO(L) = QASKED(L,0)
          END DO
C
          useTHO_THO     = 0
          gauge_THO      = 1
          projection_THO = 0
          dN_THO         = 0
          dZ_THO         = 0
C
                           set_temper_THO = .False.
          IF (IFTEMP.EQ.1) set_temper_THO = .True.
          temper_THO=TEMP_T
C
          numGauss_THO    = 40
          numLaguerre_THO = 40
          numLegendre_THO = 80
          HFODD_to_HFBTHO = .True.
          nstate_THO      = NLIMIT
                                force_parity_THO = .False.
          IF (ABS(ISIGNY).EQ.1) force_parity_THO = .True.
C
          WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *      ''*          SMOOTH CONTINUATION FROM HFBTHO'',
     *      '' RUN HAS BEEN REQUESTED             *'',/,
     *      ''*'',77X,''*'',/,
     *      ''*  WARNING: THE RESTART WILL BE SMOOTH '',
     *      ''IF AND ONLY IF:                        *'',/,
     *      ''*            - AXIAL-, REFLECTION, AND '',
     *      ''TIME_REVERSAL SYMMETRIES ARE CONSERVED *'',/,
     *      ''*            - CALCULATIONS ARE UNCONSTRAINED'',
     *      ''                                 *'',/,
     *      ''*            - BASIS IS SPHERICAL OR DEFORMED'',
     *      '' ONLY ALONG BETA_2               *'',/,
     *      ''*            - HFB SOLUTION AT THE G.S. IS '',
     *      ''REQUESTED (NO HF CRANKING  ETC.)   *'',/,
     *      ''*           ANY OTHER CASE WILL RESULT IN '',
     *      ''THE STABILITY CONDITION AT FIRST    *'',/,
     *      ''*           ITERATION TO BE SIGNIFICANTLY '',
     *      ''GREATER THAN PERHAPS ANTICIPATED    *'',/,
     *      ''*'',77X,''*'',/,79(''*''))')
C
          CALL Main_Program(Nshell_THO, b0_THO, bz_THO, bp_THO,
     *                      beta0_THO, b2_THO, b4_THO, neutron_THO,
     *                      proton_THO, type_THO, niter_THO,
     *                      accuracy_THO, restart_THO,
     *                      functional_THO, initial_pair_THO,
     *                      coulomb_THO, VpairN_THO, VpairP_THO,
     *                      Ecut_THO, V1_THO, n_blocking_THO,
     *                      p_blocking_THO, lambda_THO, active_THO,
     *                      expect_THO, useTHO_THO, gauge_THO,
     *                      projection_THO, dN_THO, dZ_THO,
     *                      set_temper_THO, temper_THO, numGauss_THO,
     *                      numLaguerre_THO, numLegendre_THO,
     *                      HFODD_to_HFBTHO, nstate_THO,
     *                      force_parity_THO, file_THO, output_THO)
C
          IF (I_FAIL.EQ.1) THEN
              IF_THO=0
              WRITE(NFIPRI,'(79(''!''),/,
     *              ''!!   PROGRAM HFBTHO FAILED... LIKELY REASON: '',
     *              ''UNKNOWN INTERACTION             !!'',/,
     *              ''!!   HFODD WILL RESUME FROM SCRATCH - '',
     *              ''FORECAST MORE ITERATIONS NEEDED        !!'',/,
     *                       79(''!''))')
          END IF
C
          WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          ''*  CALLING SUBROUTINE "RECFIL" TO READ'',
     *          '' THE FIELDS FILE GENERATED BY HFBTHO    *'',/,
     *          ''*'',77X,''*'',/,79(''*''),/)')
C
          DO ITPNMX=0,LDPNMX
             CALL ZEDENS(ITPNMX)
          END DO
C
          NUMITE=-1
C
          INPFIL=1
C
          CALL RECFIL(NFIFIP,NFIFIC,INPFIL,ISIMPY,IPAHFB,
     *                              IPNMIX,NOSCIL,NUMITE,
     *                       EFERMN,EFERMP,EFER2N,EFER2P,
     *                              DELTAN,DELTAP,IF_THO,
     *                                     NLIMIT,FILTHO,
     *                       ISGOGP,ISREGP,REA2PP,IVEFIP,
     *                                            ITWCEN)
C
          REFERN=EFERMN
          REDELN=DELTAN
          REFE2N=EFER2N
C
          REFERP=EFERMP
          REDELP=DELTAP
          REFE2P=EFER2P
C
          ITESTA=NUMITE+1
C
      END IF
C
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C         COMPUTING THE SIZE OF THE BROYDEN VECTOR DEPENDING ON
C         THE USER'S CHOICE OF HFODD OPTIONS
C=======================================================================
C
      IF (MIXMAT.EQ.0) THEN
          CALL CALBRO_FIELDS(IROTAT,ISIMPY,IPAHFB,LIPKIN,LIPKIP,
     *                       NXHERM,NYHERM,NZHERM,IBROYD,NOFBRO)
      END IF
C
      IF (MIXMAT.EQ.1) THEN
          CALL CALBRO_MATRIX(MREVER,IROTAT,ISIMPY,IPAHFB,NOFBRN,
     *                              NOFBRP,LIPKIN,LIPKIP,IBROYD)
      END IF
C
C@@@ SHELL -SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C=======================================================================
C         ENFORCING THE SIZE OF PHASE SPACE SO THAT THERE ARE ENOUGH
C         SINGLE - PARTICLE STATES FOR THE  COMPUTATION OF THE SHELL
C         CORRECTION
C=======================================================================
C
      IF (IFSHEL.GE.1) THEN
C
              LDPHAS=LDBASE
          IF (LDPHAS.GT.NDSTAT .OR. LDPHAS.EQ.0) LDPHAS=NDSTAT
C
          DO IREVER=0,NDREVE
             DO ICHARG=0,NDISOS
                NUMBSP(IREVER,ICHARG)=LDPHAS
             END DO
          END DO
C
      END IF
C
C@@@ SHELL -SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C         REORDERING THE MATRICES OF THE MEAN-FIELD AND THE PAIRING
C         FIELD OBTAINED FROM  HFBTHO  TO COMPLY WITH  HFODD LABELS
C         CONVENTIONS. RESULTS HAVE BEEN READ PREVIOUSLY IN RECFIL.
C=======================================================================
C
      IF (IF_THO.GE.1) CALL FromHFBTHO(NDTRAN,NDSPIN)
C
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C         SETTING THE INITIAL VALUES OF THE RENORMALIZED MASSES
C=======================================================================
C
      TRAMAS=HBMASS/(IN_FIX+IZ_FIX)
C
      HBMREN(1)=-TRAMAS*HBMRIN(1)
      HBMREN(2)=-TRAMAS*HBMRIN(2)
      HBMREN(3)=-TRAMAS*HBMRIN(3)
C
C=======================================================================
C         SETTING THE INITIAL VALUES OF THE RENORMALIZED INERTIA
C=======================================================================
C
      ROTMAS=1 ! TEMPORARY !
C
      ROTREN(1)=-ROTMAS*ROTRIN(1)
      ROTREN(2)=-ROTMAS*ROTRIN(2)
      ROTREN(3)=-ROTMAS*ROTRIN(3)
C
C=======================================================================
C         DEFINITION (IN DEVHER) OF THE AUXILIARY EXPANSION COEFFICIENTS
C         TO EXPRESS  THE  PRODUCTS OF  T W O  HERMITE POLYNOMIALS, OR A
C         PRODUCT OF ONE POLYNOMIAL AND A DERIVATIVE ETC.  BY  A  SERIES
C         OF SINGLE HERMITE POLYNOMIALS
C=======================================================================
C         DEFINITION ( IN DEFINT ) OF HARMONIC OSCILLATOR WAVE FUNCTIONS
C         AND GAUSS-HERMITE INTEGRATION POINTS AND WEIGHTS
C=======================================================================
C         DEFINITION ( IN DEFYLM ) OF SOLID      HARMONICS
C         DEFINITION ( IN DEFSLM ) OF SURFACE    HARMONICS
C         DEFINITION ( IN DEFPLM ) OF PENSURFACE HARMONICS
C=======================================================================
C         THE PENSURFACE MOMENTS ARE CALCULATED ONLY IF "IDOPLM" IS  SET
C         ABOVE TO 1. THE CALCULATION OF  THE  PENSURFACE  MOMENTS  THEN
C         STRICTLY FOLLOWS THAT OF THE SURFACE MOMENTS, ALTHOUGH NOT ALL
C         OPTIONS AND TESTS ARE IMPEMENTED YET; YOU SHOULD PROCEED  WITH
C         EXTREME CAUTION!
C=======================================================================
C
      NOBODY=2
      NBDONE=1
C
      NMUMAX=1
      NMUMAX=MAX(NMUMAX,NMUCON,NMUCOU,NMUPRI)
C
      NMAMAX=0
      NMAMAX=MAX(NMAMAX,NMACON,NMAPRI)
C
      NSIMAX=0
      NSIMAX=MAX(NSIMAX,NSICON,NSIPRI)
C
      NASMAX=0
      NASMAX=MAX(NASMAX,NASCON,NASPRI)
C
C=======================================================================
C         ATTENTION: AFTER THE  MAGNETIC  MOMENTS  WERE  INPLEMENTED  IN
C                    VERSION (2.02), VARIABLE "NMUPOW" WAS NOT  PROPERLY
C                    UPDATED AND IT WAS LEFT  EQUAL  TO  THE  NUMBER  OF
C                    MULTIPOLE MOMENTS "NMUMAX",  WHEREAS  TO  DETERMINE
C                    THE ORBITAL ANGULAR MOMENTUM IN "INTORB", IT SHOULD
C                    HAVE BEEN EQUAL TO AT LEAST "NMAMAX"+1.  THEREFORE,
C                    FOR "NMUMAX"<="NMAMAX"  THE  CODE  COULD  NOT  WORK
C                    CORRECTLY. THIS BUG WAS CORRECTED ON 15/12/2021  IN
C                    VERSION (3.09H).
C=======================================================================
C
      NMUPOW=NMUMAX
      IF (NMAMAX.GT.0)                 NMUPOW=MAX(NMUPOW,NMAMAX+1)
      IF (NASMAX.GT.0)                 NMUPOW=MAX(NMUPOW,NASMAX+1)
      IF (NMAORD.GT.0)                 NMUPOW=MAX(NMUPOW,NMAMAX+1+
     *                                                   2*NMAORD)
      IF (NASORD.GT.0)                 NMUPOW=MAX(NMUPOW,NASMAX+1+
     *                                                   2*NASORD)
      IF (NRAORD.GT.0)                 NMUPOW=MAX(NMUPOW,2*NRAORD)
      IF (NSIMAX.GT.0)                 NMUPOW=MAX(NMUPOW,NSIMAX+2)
      IF (NSIMAX.GT.0.AND.IDOPLM.EQ.1) NMUPOW=MAX(NMUPOW,NSIMAX+4)
C
C=======================================================================
C         IN THE TWO-CENTRE BASIS OPTION DIFFERENT SUBROUTINES (TWC_)
C         ARE USED TO COMPUTE WAVE FUNCTIONS AND COEFFICIENTS. SEE
C         THE MODULE HFODD_TWOCEN FOR MORE INFORMATION.
C=======================================================================
C
      NXMAXX=NXMAXV(1)
      NGAUSS=NXHERM
      NOSACT=NOSCIL
      KARTEZ=1
C
      CALL SCAHER(NOSACT,KARTEZ)
C
      CALL DEVHER(NOSACT,KARTEZ)
C
      CALL DEFINT(NOSACT,KARTEZ,NGAUSS,NOBODY,
     *     HERMTS,DHRMTS,DDHRMT,FOURWG,FOURPT)
C
      CALL COPHER(NOSACT,KARTEZ,NGAUSS,HERMTS,DHRMTS,DDHRMT,
     *                                 CERMTS,CHRMTS,CDHRMT)
C
      CALL DEFINT(NOSACT,KARTEZ,NGAUSS,NBDONE,
     *     HERONE,DHRONE,DDHONE,TWOWGT,TWOPNT)
C
      CALL DEVMUL(NOSACT,NGAUSS,KARTEZ)
C
      CALL DEFMOS(NXMAXX,KARTEZ)
C
      IF (ITWCEN.EQ.2) THEN
C
         CALL TWC_DEFINT(NOSACT,KARTEZ,NGAUSS,ITWCEN)
C
         CALL TWC_DEVHER(NOSACT,KARTEZ,ITWCEN)
C
         CALL TWC_DEVMUL(NOSACT,NGAUSS,KARTEZ,ITWCEN)
C
         CALL TWC_COPHER(NOSACT,KARTEZ,NGAUSS,ITWCEN)
C
      END IF
C
C=======================================================================
C
      NYMAXX=NYMAXV(1)
      NGAUSS=NYHERM
      NOSACT=NOSCIL
      KARTEZ=2
C
      CALL DEVHER(NOSACT,KARTEZ)
C
      CALL DEFINT(NOSACT,KARTEZ,NGAUSS,NOBODY,
     *     HERMTS,DHRMTS,DDHRMT,FOURWG,FOURPT)
C
      CALL COPHER(NOSACT,KARTEZ,NGAUSS,HERMTS,DHRMTS,DDHRMT,
     *                                 CERMTS,CHRMTS,CDHRMT)
C
      CALL DEFINT(NOSACT,KARTEZ,NGAUSS,NBDONE,
     *     HERONE,DHRONE,DDHONE,TWOWGT,TWOPNT)
C
      CALL DEVMUL(NOSACT,NGAUSS,KARTEZ)
C
      CALL DEFMOS(NYMAXX,KARTEZ)
C
      IF (ITWCEN.EQ.2) THEN
C
         CALL TWC_DEFINT(NOSACT,KARTEZ,NGAUSS,ITWCEN)
C
         CALL TWC_DEVHER(NOSACT,KARTEZ,ITWCEN)
C
         CALL TWC_DEVMUL(NOSACT,NGAUSS,KARTEZ,ITWCEN)
C
         CALL TWC_COPHER(NOSACT,KARTEZ,NGAUSS,ITWCEN)
C
      END IF
C
C=======================================================================
C
      NZMAXX=NZMAXV(1)
      NGAUSS=NZHERM
      NOSACT=NOSCIL
      KARTEZ=3
C
      CALL DEVHER(NOSACT,KARTEZ)
C
      CALL DEFINT(NOSACT,KARTEZ,NGAUSS,NOBODY,
     *     HERMTS,DHRMTS,DDHRMT,FOURWG,FOURPT)
C
      CALL COPHER(NOSACT,KARTEZ,NGAUSS,HERMTS,DHRMTS,DDHRMT,
     *                                 CERMTS,CHRMTS,CDHRMT)
C
      CALL DEFINT(NOSACT,KARTEZ,NGAUSS,NBDONE,
     *     HERONE,DHRONE,DDHONE,TWOWGT,TWOPNT)
C
      CALL DEVMUL(NOSACT,NGAUSS,KARTEZ)
C
      CALL DEFMOS(NZMAXX,KARTEZ)
C
      IF (ITWCEN.EQ.2) THEN
C
         CALL TWC_DEFINT(NOSACT,KARTEZ,NGAUSS,ITWCEN)
C
         CALL TWC_DEVHER(NOSACT,KARTEZ,ITWCEN)
C
         CALL TWC_DEVMUL(NOSACT,NGAUSS,KARTEZ,ITWCEN)
C
         CALL TWC_COPHER(NOSACT,KARTEZ,NGAUSS,ITWCEN)
C
      END IF
C
C=======================================================================
C
C      IF (ITWCEN.EQ.2) CALL TWC_ROTBAS(ITWCEN,LDTWCE)
C
C=======================================================================
C
      CALL DEFEXP(ITWCEN,LDTWDD)
C
C=======================================================================
C
      CALL DEFYLM
      CALL DEFSLM
      CALL DEFVLM
      IF (IDOPLM.EQ.1)
     *CALL DEFPLM
C
      CALL DEFUNI(NMUMAX,NSIMAX,NMAMAX,NASMAX)
C
C=======================================================================
C         BUILDING ARRAYS PERTAINING TO THE SPHERICAL HO BASIS
C=======================================================================
C
      IF (ISPHER.EQ.1) THEN
C
C         CALL DOSPHE(NOSACT,NGAUSS,NXHERM,NYHERM,NZHERM)
C
      END IF
C
C=======================================================================
C         DEFINING THE SPHERICAL HARMONICS REQUIRED FOR A CALCULATION OF
C         EXACT BOHR DEFORMATION PARAMETERS
C=======================================================================
C
      IF (NEXBET.GT.0.AND.IPRIBE.EQ.1) CALL LOADIN(NEXBET)
C
C=======================================================================
C         DEFINING THE MULTIPOLES TO BE USED IN THE COULOMB POTENTIAL
C=======================================================================
C
      CALL MULCOU(ISIMPY,ISIGNY,ISIQTY,NMUCOU)
C
C=======================================================================
C         DEFINING THE FOURIER INTEGRALS  FOR  THE  COULOMB POTENTIAL
C=======================================================================
C
      CALL PRECOU(NOSCIL,NUMCOU,NUMETA,BOUCOU,
     *            NFICOU,FILCOU,ICOULI,ICOULO)
C
C=======================================================================
C         CALCULATING THE PHASES ACCORDING TO SOME INGENIOUS CONVENTION
C=======================================================================
C
      CALL PHASES(ITWCEN)
C
C=======================================================================
C         CALCULATING THE NORM OVERLAP MATRIX FOR THE TWO-CENTRE OPTION
C=======================================================================
C
      IF (ITWCEN.EQ.2) CALL TWC_NORMAT(IEIGCU,EIGCUT)
C
C=======================================================================
C         PRINTING THE INFORMATION CONCERNING THE CURRENT RUN
C=======================================================================
C
      CALL INFPRI(IN_FIX,IZ_FIX,
     *                   NUMCOU,NUMETA,FURMAX,
     *                   ICOTYP,ICOUDI,ICOUEX,
     *            PIMASS,PNMASS,IYUTYP,I_YUKA,
     *            YUKAGT,YUKAG0,YUKAG1,YUKAG2,
     *                          I_GOGA,IGOGPA,
     *                          I_REGA,IREGPA,
     *                          I_SEPA,ISEPPA,
     *                          I_COUA,ICOUPA,
     *                   N3LORD,N3SERD,IDOTHC,
     *     NUCHAO,NUPING,EPSPNG,EPSITE,EPSCON,
     *                   NOITER,NULAST,NUCONS,
     *            DELFIN,DELFIP,IDEFIN,IDEFIP,
     *            FERFIN,FERFIP,IFEFIN,IFEFIP,
     *            FE2FIN,FE2FIP,IF2FIN,IF2FIP,
     *            FERALN,FERALP,IFERAN,IFERAP,
     *                                 NUQEVE,
     *            INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *            INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                   INSIMN,IRSIMN,IDSIMN,
     *                   INSIMP,IRSIMP,IDSIMP,
     *                   INSIQN,IPSIQN,IDSIQN,
     *                   INSIQP,IPSIQP,IDSIQP,
     *                          INSIZN,IDSIZN,
     *                          INSIZP,IDSIZP,
     *                          IFIBLN,INIBLN,
     *                          IFIBLP,INIBLP,
     *                   ECUTOF,LIMQUA,LAMCUT,
     *            ISPHER,ISIMPY,ISIGNY,ISIQTY,
     *                   ISIMTX,JSIMTY,ISIMTZ,
     *            ISYMDE,INIROT,INIINV,INIKAR,
     *                   IRENMA,IRENIN,IDOGOA,
     *                   ITWOLI,JETACM,KETA_R,
     *                                 NOZEPA,
     *                          KETAJ2,KETAT2,
     *                          JETA_T,JETAPA,
     *                   IFRWAV,ITOWAV,IWRWAV,
     *                   IONISH,ISAKER,ICHKER,
     *                   IPRGCM,IPROMI,IPROMA,
     *                   NUAKNO,NUBKNO,KPROJE,
     *                   NATKNO,NBTKNO,ISOSTZ,
     *            NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *            ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *            IPAKER,IPAK3D,IPAALL,KFIKER,
     *            NUASTA,NUASTO,NUGSTA,NUGSTO,
     *            NATSTA,NATSTO,NGTSTA,NGTSTO,
     *            NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *                          ISLPRI,ISUPRI,
     *                   IENPRI,ISRPRI,IMIPRI,
     *                   IKEPRI,IRMPRI,IELPRI,
     *            QMUCUT,QMACUT,QASCUT,QSICUT,
     *            IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                   IPRSTA,IPRMID,IPRSTO,
     *            IDESTA,IDEMID,IDESTO,IDEDIS,
     *                          INTRIP,IVIPRI,
     *                   IPRI_N,IPRI_P,IPRI_T,
     *     IPAIRI,IPAHFB,ITWOBA,JPABCS,IMFHFB,
     *                                 IPNMIX,
     *                          LIPKIN,LIPKIP,
     *                          LIPNON,LIPNOP,
     *                          IQUNIL,NILXYZ,
     *                   IROTAT,ITIREP,IQPSTA,
     *                   NMUCON,NMUCOU,NMUPRI,
     *            ISCHIF,NSIMAX,NSICON,NSIPRI,
     *                                 IDOPLM,
     *            NMAMAX,NMACON,NMAPRI,NMAORD,
     *            NASMAX,NASCON,NASPRI,NASORD,
     *                                 NRAORD,
     *            NMURED,NMARED,NASRED,NSIRED,
     *            SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                   ICONTI,IPCONT,IOCONT,
     *                   ISCONT,ITCONT,IACONT,
     *            IYCONT,IGCONT,IGPCON,IECONT,
     *     ILCONT,IFCONT,IMCONT,IRCONT,IBCONT,
     *                                 IPOTHO,
     *                   BOUCOU,IFSHEL,IF_RPA,
     *                          I_SLOW,SLOWAL,
     *            SLOWLD,SLOWTP,SLOWRP,SLOWLM,
     *            NLSIGN,NLSIMN,NLSIQN,NLSIZN,
     *            NLSIGP,NLSIMP,NLSIQP,NLSIZP,
     *                   IAXIAP,KAPASY,INUNIL,
     *                                 IADBAT,
     *                          NEWGOG,NEWCOU,
     *                                 ITWCEN)
C
C=======================================================================
C         PRINTING THE INFORMATION CONCERNING THE CONFIGURATIONS
C=======================================================================
C
      IF (IPAIRI.NE.1.OR.IPA2HF(0).GE.1.OR.IPA2HF(1).GE.1) THEN
C
          IF (IPNMIX.NE.1) THEN
C
              IF (ISIMPY.EQ.1) THEN
C
                  IF (ISIGNY.EQ.1) THEN
C
                      CALL SIGPRI(ICHFLI,IPAFLI,IREFLI,
     *                            ISPFLI,ISHFLI,IFLIPI)
                  ELSE
C
                      CALL SIMPRI(ICHFLI,       IREFLI,
     *                            ISPFLI,ISHFLI,IFLIPI)
                  END IF
C
              ELSE
C
                  IF (ISIQTY.EQ.1) THEN
C
                      CALL SIQPRI(ICHFLI,IPAFLI,
     *                            ISPFLI,ISHFLI,IFLIPI)
                  ELSE
C
                      CALL SIZPRI(ICHFLI,
     *                            ISPFLI,ISHFLI,IFLIPI)
                  END IF
C
              END IF
C
          ELSE
C
              IF (ISIMPY.EQ.1) THEN
C
                  IF (ISIGNY.EQ.1) THEN
C
                      CALL MIGPRI(       IPAFLI,IREFLI,
     *                            ISPFLI,ISHFLI,IFLIPI)
                  ELSE
C
                      CALL MIMPRI(              IREFLI,
     *                            ISPFLI,ISHFLI,IFLIPI)
                  END IF
C
              ELSE
C
                  IF (ISIQTY.EQ.1) THEN
C
                      CALL MIQPRI(       IPAFLI,
     *                            ISPFLI,ISHFLI,IFLIPI)
                  ELSE
C
                      CALL MIZPRI(
     *                            ISPFLI,ISHFLI,IFLIPI)
                  END IF
C
              END IF
          END IF
C
      END IF
C
C=======================================================================
C         ZEROING THE HARTREE-FOCK FIELDS
C=======================================================================
C
      DO ITPNMX=0,LDPNMX
         CALL ZEFILD(ITPNMX)
      END DO
C
C=======================================================================
C=======================================================================
C         HERE STARTS THE    H A R T R E E - F O C K   I T E R A T I O N
C=======================================================================
C         T H R E E  DIFFERENT VARIABLES KEEP TRACK  OF  THE  NUMBER  OF
C         ITERATIONS:
C
C         NOITER = THE REQUESTED NUMBER OF THE HARTREE-FOCK  ITERATIONS.
C                  IT CAN BE EQUAL TO ZERO WHEN THE STARTING POINT  IS A
C                  NILSSON OR WOODS-SAXON POTENTIAL. IT CANNOT BE  EQUAL
C                  TO ZERO WHEN THE  CODE  STARTS  FROM  THE  PREVIOUSLY
C                  RECORDED HARTREE-FOCK SOLUTION.
C         NUMITE = THE EFFECTUATED NUMBER OF THE HARTREE-FOCK ITERATIONS
C                  THAT TAKES INTO ACCOUNT ALL THE  PREVIOUSLY  RECORDED
C                  HARTREE-FOCK SOLUTIONS.
C         ITERUN = THE NUMBER OF THE HARTREE-FOCK  ITERATIONS  PERFORMED
C                  IN THE CURRENT RUN.
C=======================================================================
C      TEST DEFGOG AHEAD OF DOING THE FIRST ITERATION
C=======================================================================
C
C     CALL PHCHAN(GOGSTR,GOG_SD,GOG_VD,GOG_SE,GOG_VE,NDGOGA,NUGOGA)
C
C     GOGWI0=GOGWID(1)
C
C     CALL DEFGOG(NXMAXX,NXHERM,1,GOGWI0,
C    *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
C    *                                        GAUX41,GAUX42,GAUX43)
C=======================================================================
C
      ITESTA=0
      ITESTO=NOITER
      IF (NOITER.EQ.0) TERMNT=.TRUE.
C
      IF (ITESTO.LT.ITESTA) STOP 'NO ITERATIONS 1'
C
C=======================================================================
C
      IF (IF_THO.EQ.0) NUMITE=-1
C
C=======================================================================
C      PRINTING OUT INFORMATION ON INFORMATION RECORDED ON DISK
C=======================================================================
C
      CALL RESPRI(IWRIRE,IWRIYU,IWRIFI,IWRIGO,IWRIRO,IWRILI,
     *            IWRIBA,I_YUKA,JETACM,KETA_R,LIPKIN,LIPKIP,
     *                          I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                                        ICOUDI,ICOUEX)
C
C=======================================================================
C      ALLOCATING  AND ZEROING THE MATRICES OF THE COULOMB, YUKAWA
C      AND GOGNY FIELDS,  AS WELL AS THE DENSITY MATRICES PRIOR TO
C      EXECUTION. RESTART OPTIONS WILL SIMPLY OVERWRITE THESE ZERO
C      MATRICES WITH ACTUAL VALUES READ FROM FILES.
C=======================================================================
C     ATTENTION: FOR THE REGULARIZED SKYRME INTERACTION,  SAVING  OF
C                THE PAIRING FIELDS IN A SEPARATE FILE, WHICH EXISTS
C                FOR THE GOGNY INTERACTION, IS NOT IMPLEMENTED. THUS
C                FOR  SAVING  RESULTS  OBTAINED  IN  THIS  CASE  AND
C                RESTARTING CALCULATIONS, ONE SHOULD USE THE GENERIC
C                SAVING OF FIELDS, GOVERNED BY "IWRIFI".
C=======================================================================
C
      CALL ZERCOU(ICOUDI,ICOUEX,I_COUA,ICOUPA,NEWCOU)
C
      IF (I_YUKA.GE.2) CALL ZERYUK
C
      IF (LIPKIN.EQ.1.OR.LIPKIP.EQ.1) CALL ZERLIP(ISIMPY,IFCONT)
C
      IF (I_GOGA.GE.2.AND.NEWGOG.EQ.0) CALL ZERGOG
C
      IF (IGOGPA.GE.2.AND.NEWGOG.EQ.0) CALL ZERGPA
C
      IF (I_REGA.GE.2.OR.(I_GOGA.GE.2.AND.NEWGOG.EQ.1)) CALL ZERREG
C
      IF (IREGPA.GE.2.OR.(IGOGPA.GE.2.AND.NEWGOG.EQ.1)) CALL ZERRPA
C
      IF (I_SEPA.GE.2) CALL ZERSEP(LDPNMX)
C
      IF (ISEPPA.GE.2) CALL ZERSPA(LDPNMX)
C
      IF (MAXVAL(I_FSTA).GE.2) CALL ZERFST
C
      IF (MAXVAL(IFSTPA).GE.2) CALL ZERFPA
C
C=======================================================================
C         ZEROING THE AVERAGE VALUES AND MEAN FIELDS OF  LINEAR  MOMENTA
C=======================================================================
C
      IF (JETACM.EQ.2) THEN
C
          ALINLT(:)=0.0D0
C
          CALL ZERLIN(ISIMPY,IPAIRI)
C
      END IF
C
C=======================================================================
C         ZEROING THE AVERAGE VALUES AND MEAN FIELDS OF ANGULAR  MOMENTA
C=======================================================================
C
      IF (KETA_R.EQ.2) THEN
C
          AROTLT(:)=0.0D0
C
          CALL ZERROT(ISIMPY,IPAIRI)
C
      END IF
C
C=======================================================================
C               C O N T I N U A T I O N   M O D E S
C=======================================================================
C
      IF (ICONTI.EQ.1) THEN
C
C         INPFLD=1 => THE FILE WITH THE UNIT NUMBER  NFIREP WILL BE
C                     USED TO  R E A D  THE RESULTS OF THE PREVIOUS
C                                                               RUN
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *            1H*,''  CALLING SUBROUTINE "RECORD" TO READ'',
     *                '' THE REPLAY FILE OBTAINED PREVIOUSLY'',4X,1H*,/,
     *            1H*,2X,A68,                                  7X,1H*)')
     *
     *            FILREP
C
          INPFLD=1
          IERROR=0
C
          CALL RECORD(NFIREP,NFIREC,INPFLD,NUMITE,
     *                IVEREP,NXHERM,NYHERM,NZHERM,
     *                              IPCONT,ILCONT,
     *                       ISCONT,ITCONT,IACONT,
     *                              IMCONT,IRCONT,
     *                              IRENMA,IRENIN,
     *                              LIPKIN,LIPKIP,
     *                              REFERN,REFERP,
     *                              REDELN,REDELP,
     *                              REFE2N,REFE2P,
     *                              IDSIGN,IDSIGP,
     *                              IDSIMN,IDSIMP,
     *                              IDSIQN,IDSIQP,
     *                              IDSIZN,IDSIZP,
     *                                     INIBLN,
     *                                     INIBLP,
     *                              NMUMAX,NSIMAX,
     *                              IPNMIX,ISHIFT,
     *                              JETA_T,JETAPA,IERROR,
     *                                     LDTWCE,LDTWDD,
     *                                            IFRCNT)
C
          IF (IERROR.NE.0) THEN
C
#if(USE_MPI==1)
C
              IPCONT=0
              IFCONT=0
              IACONT=0
              IYCONT=0
              IGCONT=0
              IGPCON=0
              ILCONT=0
C
              WRITE(NFIPRI,'(
     *              '' ////////////////////////////////////////'',
     *              ''/////////////////////////////////////'',/,
     *              '' ////       WARNING: RECORD FILE IS CORRUPTED'',
     *              '' !                          /////'',/,
     *              '' ////                 - RESTART IS CANCELLED '',
     *              ''                            /////'',/,
     *              '' ////                 - CALCULATIONS WILL RES'',
     *              ''TART FROM SCRATCH           /////'',/,
     *              '' ////////////////////////////////////////'',
     *              ''/////////////////////////////////////'')')
C
#else
              STOP 'RECORD FILE CORRUPTED - STOP HERE'
#endif
C
          END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
           IF (IFNECK.GE.1) THEN
C
C              Computing the total density
              CALL TRUTOD(1,1)
C              Computing the charge density (here proton density)
              CALL TRUCHD
C
C              We find the position of the neck
              ITEBIS=0
              CALL QNFIND(NXHERM,NYHERM,NZHERM,SLOWOD,ITEBIS,ISIMPY,
     *                                                ISIGNY,IPARTY)
C
           END IF
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
#if(USE_MPI==1)
          CALL mpi_pathExploration(IERROR,NMUCON)
#endif
C
          IF (NOITER.EQ.1) TERMNT=.TRUE.
C
          ITESTA=NUMITE + 1
          ITESTO=NUMITE + NOITER
          ITERUN=0
C
          IF (ITESTO.LT.ITESTA) STOP 'NO ITERATIONS 2'
C
C=======================================================================
C         RECALCULATING THE COULOMB MATRIX ELEMENTS FROM THE PROTON
C         DENSITY THAT HAS JUST BEEN  READ  FROM  THE  REPLAY  FILE
C=======================================================================
C
          IF (ICOUDI.EQ.1) THEN
C
              CALL COUMAT(NUMCOU,BOUCOU,ISIMPY,IKERNE)
C
          END IF
C
C=======================================================================
C         RECALCULATING THE TOTAL DENSITY AND  THE  CHARGE  DENSITY
C         FROM NEUTRON AND PROTON DENSITIES  THAT  HAVE  JUST  BEEN
C         READ FROM THE REPLAY FILE
C
C         ATTENTION: IN THE VERSIONS OF THE CODE EARLIER THAN 1.98J,
C                    THE TOTAL DENSITY WAS NOT  RECALCULATED,  WHICH
C                    RESULTED IN INCORRECT  VALUES  OF  THE  PAIRING
C                    ENERGY AND PAIRING REARRANGEMENT ENERGY  (FOR A
C                    DENSITY-DEPENDENT HFB PAIRING ONLY, AND IN  THE
C                    FIRST ITERATION AFTER A RESTART ONLY). THIS BUG
C                    HAD NO EFFECT ON THE CONVERGENCE,  BECAUSE  THE
C                    CORRESPONDING  PAIRING  FIELDS  ARE  CALCULATED
C                    AFTER THE REGULAR CALL TO THE "TRUTOD" ROUTINE.
C=======================================================================
C
          CALL TRUTOD(ITWCEN,LDTWCE)
C
C=======================================================================
C         RESETTING THE HFB PAIRING PROPERTIES TO THOSE FOUND ON  REPLAY
C         FILE PROVIDED SUCH COURSE OF ACTION IS ALLOWED BY THE RELEVANT
C         DATA PARAMETER "IPCONT". THUS:
C            FOR IPCONT=0 PAIRING PROPERTIES ARE  TAKEN  FROM  THE  DATA
C                         (FROM THE FERINI, DELINI, AND  FE2INI  ARRAYS)
C            FOR IPCONT=1 PAIRING PROPERTIES ARE TAKEN FROM  THE  REPLAY
C                         FILE.
C=======================================================================
C
          IF (IPCONT.EQ.1) THEN
C
              EFERMN=REFERN
              DELTAN=REDELN
              IF (ILCONT.GE.1) EFER2N=REFE2N
C
              EFENIN=EFERMN
              EFENOU=0.0D0
C
              EFERMP=REFERP
              DELTAP=REDELP
              IF (ILCONT.GE.1) EFER2P=REFE2P
C
              EFEPIN=EFERMP
              EFEPOU=0.0D0
C
              EFERMA=REFERA
              DELTAA=REDELA
C
          ELSE
C
              IF (IPNMIX.NE.1) THEN
C
                  CALL INIPAI(0,IPNMIX,ITWCEN,LDTWCE)
                  CALL INIPAI(1,IPNMIX,ITWCEN,LDTWCE)
              ELSE
                  CALL INIPAI(2,IPNMIX,1,1)
C
              END IF
C
          END IF
C
C=======================================================================
C         RESETTING THE LINEAR CONSTRAINTS  OF  THE  AUGMENTED  LAGRANGE
C         METHOD TO THOSE READ FROM THE RECORD FILE PROVIDED SUCH COURSE
C         OF ACTION IS ALLOWED BY THE RELEVANT DATA PARAMETER "IACONT".
C=======================================================================
C
          IF (IACONT.EQ.1) THEN
C
              DO LAMBDA=0,NDMULT
                 DO MIU=-LAMBDA,LAMBDA
C
                    GALMUQ(LAMBDA,MIU)=RALMUQ(LAMBDA,MIU)
                    GALMUS(LAMBDA,MIU)=RALMUS(LAMBDA,MIU)
C
                    GALMUV(LAMBDA,MIU)=RALMUV(LAMBDA,MIU)
C
                 END DO
              END DO
C
          END IF
C
C=======================================================================
C         RESETTING THE  SPIN  CONSTRAINTS  OF  THE  AUGMENTED  LAGRANGE
C         METHOD TO THOSE READ FROM THE RECORD FILE PROVIDED SUCH COURSE
C         OF ACTION IS ALLOWED BY THE RELEVANT DATA PARAMETER "ISCONT".
C=======================================================================
C
          IF (ISCONT.EQ.1) THEN
C
              GALSPI=RALSPI
              OMOVAX=OMEGAX+GALSPI(1)
              OMOVAY=OMEGAY+GALSPI(2)
              OMOVAZ=OMEGAZ+GALSPI(3)
C
          END IF
C
C=======================================================================
C         RESETTING THE ISOSPIN CONSTRAINTS OF  THE  AUGMENTED  LAGRANGE
C         METHOD TO THOSE READ FROM THE RECORD FILE PROVIDED SUCH COURSE
C         OF ACTION IS ALLOWED BY THE RELEVANT DATA PARAMETER "ITCONT".
C=======================================================================
C
          IF (ITCONT.EQ.1) THEN
C
              GALISO=RALISO
              FERMOV(1)=FERISO(1)+GALISO(1)
              FERMOV(2)=FERISO(2)+GALISO(2)
              FERMOV(3)=FERISO(3)+GALISO(3)
C
          END IF
C
C=======================================================================
C         RESETTING THE YUKAWA MEAN FIELDS TO THOSE FOUND ON THE  YUKAWA
C         FILE PROVIDED THE FIELDS FILE IS NOT USED. THUS:
C           FOR IYCONT=0 THE YUKAWA MEAN FIELDS ARE SET TO ZERO,
C           FOR IYCONT=1 THE YUKAWA MEAN FIELDS ARE READ FROM THE YUKAWA
C                        FILE.
C=======================================================================
C
          IF (IYCONT.EQ.1.AND.IFCONT.NE.1) THEN
C
              WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *            1H*,''  CALLING SUBROUTINE "RECYUK" TO READ'',
     *                '' THE YUKAWA FILE OBTAINED PREVIOUSLY'',4X,1H*,/,
     *            1H*,2X,A68,                                  7X,1H*)')
     *
     *            FILYUP
C
              INPYUK=1
C
              CALL RECYUK(NFIYUP,NFIYUC,INPYUK)
C
          END IF
C
C=======================================================================
C         RESETTING THE GOGNY MEAN FIELDS TO THOSE FOUND ON  THE  GOGNY
C         FILE PROVIDED THE FIELDS FILE IS NOT USED. THUS:
C           FOR IGCONT=0 THE GOGNY MEAN FIELDS ARE SET TO ZERO,
C           FOR IGCONT=1 THE GOGNY MEAN FIELDS ARE READ FROM THE YGOGNY
C                        FILE.
C=======================================================================
C
          IF (IGCONT.EQ.1.AND.IFCONT.NE.1) THEN
C
              WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *            1H*,''  CALLING SUBROUTINE "RECGOG" TO READ'',
     *                '' THE GOGNY FILE OBTAINED PREVIOUSLY '',4X,1H*,/,
     *            1H*,2X,A68,                                  7X,1H*)')
     *
     *            FILGOP
C
              INPGOG=1
C
              CALL RECGOG(NFIGOP,NFIGOC,INPGOG)
C
              ISGOGA=1
C
          ELSE
C
              ISGOGA=0
C
          END IF
C
C=======================================================================
C         RESETTING THE GOGNY PAIRING FIELDS TO THOSE FOUND ON THE GOGNY
C         PAIRING FILE PROVIDED THE FIELDS FILE IS NOT USED. THUS:
C           FOR IGPCON=0 THE GOGNY PAIRING FIELDS ARE SET TO ZERO,
C           FOR IGPCON=1 THE GOGNY PAIRING FIELDS ARE READ FROM THE
C                        GOGNY FILE.
C=======================================================================
C
          IF (IGPCON.EQ.1.AND.IFCONT.NE.1) THEN
C
              WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *            1H*,''  CALLING SUBROUTINE "RECGPA" TO READ'',
     *                '' THE GOGNY FILE OBTAINED PREVIOUSLY '',4X,1H*,/,
     *            1H*,2X,A68,                                  7X,1H*)')
     *
     *            FILGPA
C
              INPGPA=1
C
              CALL RECGPA(NFIGPP,NFIGPC,INPGPA)
C
              ISGOGP=1
C
          ELSE
C
              ISGOGP=0
C
          END IF
C
C=======================================================================
C         RESETTING THE REGUL MEAN FIELDS TO THOSE FOUND  ON  THE  REGUL
C         FILE PROVIDED THE FIELDS FILE IS NOT USED. THUS:
C           FOR IECONT=0 THE REGUL MEAN FIELDS ARE SET TO ZERO,
C           FOR IECONT=1 THE REGUL MEAN FIELDS ARE READ FROM THE REGUL
C                        FILE.
C=======================================================================
C
          IF (IECONT.EQ.1.AND.IFCONT.NE.1) THEN
C
              WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *            1H*,''  CALLING SUBROUTINE "RECREG" TO READ'',
     *                '' THE REGUL FILE OBTAINED PREVIOUSLY '',4X,1H*,/,
     *            1H*,2X,A68,                                  7X,1H*)')
     *
     *            FILROP
C
              INPREG=1
C
              CALL RECREG(NFIROP,NFIROC,INPREG)
C
              ISREGA=1
C
          ELSE
C
              ISREGA=0
C
          END IF
C
C=======================================================================
C         RESETTING THE DENSITY MATRICES TO THOSE FOUND ON  THE  LIPKIN
C         FILE PROVIDED THE FIELDS FILE IS NOT USED. THUS:
C           FOR ILCONT=0 THE DENSITY MATRICES ARE SET TO ZERO,
C           FOR ILCONT=1 THE DENSITY MATRICES ARE READ FROM  THE  LIPKIN
C                        FILE.
C=======================================================================
C
          IF (ILCONT.EQ.1.AND.IFCONT.NE.1) THEN
C
              WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *            1H*,''  CALLING SUBROUTINE "RECLIP" TO READ'',
     *                '' THE LIPKIN FILE OBTAINED PREVIOUSLY'',4X,1H*,/,
     *            1H*,2X,A68,                                  7X,1H*)')
     *
     *            FILLIP
C
              INPLIP=1
C
              CALL RECLIP(NFILIP,NFILIC,INPLIP,ISIMPY)
C
          END IF
C
C=======================================================================
C         ZEROING THE AVERAGE VALUES AND MEAN FIELDS OF  LINEAR  MOMENTA
C         WHEN THE CALCULATION OF CM CORRECTION BEFORE VARIATION IS  NOT
C         RESTARTED FROM THE DISK
C=======================================================================
C
          IF (JETACM.EQ.2.AND.IMCONT.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 ALINLT(KARTEZ)=0.0D0
C
              END DO
C
              CALL ZERLIN(ISIMPY,IPAIRI)
C
          END IF
C
C=======================================================================
C         ZEROING THE AVERAGE VALUES AND MEAN FIELDS OF ANGULAR  MOMENTA
C         WHEN THE CALCULATION OF ROT CORRECTION BEFORE VARIATION IS NOT
C         RESTARTED FROM THE DISK
C=======================================================================
C
          IF (KETA_R.EQ.2.AND.IRCONT.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 AROTLT(KARTEZ)=0.0D0
C
              END DO
C
              CALL ZERROT(ISIMPY,IPAIRI)
C
          END IF
C
C=======================================================================
C         READING THE FIELDS FROM THE FIELD FILE
C=======================================================================
C
          IF (IFCONT.EQ.1.AND.IF_THO.EQ.0) THEN
C
              WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *            1H*,''  CALLING SUBROUTINE "RECFIL" TO READ'',
     *                '' THE FIELDS FILE OBTAINED PREVIOUSLY'',4X,1H*,/,
     *            1H*,2X,A68,                                  7X,1H*)')
     *
     *            FILFIP
C
              INPFIL=1
C
              CALL RECFIL(NFIFIP,NFIFIC,INPFIL,ISIMPY,IPAHFB,
     *                                  IPNMIX,NOSCIL,NUMITE,
     *                           EFERMN,EFERMP,EFER2N,EFER2P,
     *                                  DELTAN,DELTAP,IF_THO,
     *                                         NLIMIT,FILTHO,
     *                           ISGOGP,ISREGP,REA2PP,IVEFIP,
     *                                                ITWCEN)
C
          END IF
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
      END IF
C
C@@@ HFBTHO -HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C
      IF (IF_THO.GE.1) THEN
C
          WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          ''*  CALLING SUBROUTINE  CYLCAR  TO TRANSFORM '',
     *          ''THE HFB MATRIX READ FROM HFBTHO   *'',/,
     *          ''*  INTO THE CARTESIAN BASIS USED IN HFODD.'',
     *          36X,''*'')')
C
          CALL CYLCAR(NOSCIL,ISIMPY,IF_THO)
C
          ITESTA=NUMITE+1
C
          WRITE(NFIPRI,'(''*'',77X,''*'',/,79(''*''),/)')
C
      END IF
C
C@@@ HFBTHO -HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
#if(USE_MPI==1)
      IF (IF_THO.EQ.0.AND.batch_mode.EQ.1) THEN
          CALL batch(NFIREP,NFIREC,NFILIP,NFILIC,
     *               FILREP,FILREC,FILLIP,FILLIC,
     *               NUDATA,IF_THO,
     *                      NXHERM,NYHERM,NZHERM,IRENMA,IRENIN,
     *               REFERN,REFERP,REDELN,REDELP,REFE2N,REFE2P,
     *               IFIBLN,INIBLN,IFIBLP,INIBLP,NMUMAX,NSIMAX,
     *                                           NMUCON,ISHIFT,
     *               ICONTI,IPCONT,ILCONT,IACONT,IGCONT,IGPCON,
     *                             ISCONT,ITCONT,IMCONT,IRCONT,
     *               IPAIRI,LIPKIN,LIPKIP,I_GOGA,IGOGPA,I_YUKA,
     *                                    ITWOLI,JETACM,KETA_R,
     *               IPNMIX,Q_NECK,QACTUA,QORIGI,QINCRE,INDJOB,
     *               batch_init)
      END IF
#endif
C
      EF2NIN=EFER2N
      EF2NOU=EFER2N
C
      EF2PIN=EFER2P
      EF2POU=EFER2P
C
C=======================================================================
C=======================================================================
C=======================================================================
C
C         HERE WE ENTER ANY NEW ITERATION OF THE HARTREE-FOCK:
C
C=======================================================================
C=======================================================================
C=======================================================================
C
   1  NUMITE=NUMITE+1
      ITERUN=ITERUN+1
C
C      If extra constraints are used to push the iterations in a
C      certain direction, thee constraints are released after NITPUS
C      iterations. We set the corresponding flag to 0 and re-define
C      the actual constraints
C
C REMOVED INTERFACES 170407
C     IF (IFPUSH.EQ.1.AND.IREAWS.EQ.0.AND.ITERUN.GT.NITPUS) THEN
C
C         DOPUSH = .FALSE.
C
C     END IF
C
C         CALL NUMCON(LAMPUS,MIUPUS,QMOPUS,NUMPUS,IF_RPA,IFPUSH,
C    *                                                   DOPUSH)
C
      IF (ITERUN.GT.NDITER+1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),
     *                '' ALLOWED NUMBER OF ITERATIONS '',5X,20(1H/),/,
     *                1X,20(1H/),'' NDITER='',I5,'' EXCEEDED'',
     *                                 15X,20(1H/),/)') NDITER
C
          STOP 'ITERUN.GT.NDITER+1 IN MAIN'
C
      END IF
C
C=======================================================================
C         RESETTING THE PARAMETERS THAT HANDLE THE ANGULAR-MOMENTUM
C         PROJECTION, CALCULATION OF THE GCM KERNELS, AND TOMOGRAPHY
C=======================================================================
C
      ISAWAV=0
      IF (IPRGCM.GE.1.OR.IRENMA.GE.1.OR.IRENIN.GE.1.OR.IWRWAV.GE.1.OR.
     *    ABS(ITOMOZ).EQ.2)
     *    ISAWAV=1
      IKERNE=0
C
C=======================================================================
C         HERE WE DEFINE THE LOGICAL SWITCH "PRINIT" THAT DECIDES  ON
C         WHETHER OR NOT THE RESULTS OF THE CURRENT ITERATION WILL BE
C         PRINTED
C=======================================================================
C
      IF ((NUMITE.EQ.ITESTA                     .AND.IPRSTA.EQ.1).OR.
     *    (NUMITE.GT.ITESTA.AND.NUMITE.LT.ITESTO.AND.IPRMID.EQ.1).OR.
     *   ((NUMITE.EQ.ITESTO.OR.TERMNT)          .AND.IPRSTO.EQ.1)) THEN
C
           PRINIT=.TRUE.
      ELSE
           PRINIT=.FALSE.
      END IF
C
C=======================================================================
C         HERE WE DEFINE SWITCHES "ISABLN" AND "ISABLP"  THAT  DECIDE
C         ON WHETHER OR NOT THE SINGLE-PARTICLE STATES  USED  IN  THE
C         QUASIPARTICLE BLOCKING WILL BE SAVED IN THE FIRST ITERATION
C=======================================================================
C
                                                       ISABLN=0
      IF (IFIBLN.EQ.1.AND.INIBLN.EQ.1.AND.ITERUN.EQ.1) ISABLN=1
                                                       ISABLP=0
      IF (IFIBLP.EQ.1.AND.INIBLP.EQ.1.AND.ITERUN.EQ.1) ISABLP=1
C
C=======================================================================
C         HERE WE DEFINE THE LOGICAL SWITCH "PRIYUK" THAT DECIDES  ON
C         WHETHER OR NOT THE TIME-REVERSAL-VIOLATING MATRIX  ELEMENTS
C         OF THE YUKAWA POTENTIAL WILL BE PRINTED.  NOTE  THAT  THESE
C         MATRIX ELEMENTS CAN ONLY BE CALCULATED ONCE THE YUKAWA MEAN
C         FIELD IS KNOWN FOR THE "DIV S" SOURCE DENSITY.  SINCE  THIS
C         DENSITY IS CALCULATED IN THE PREVIOUS ITERATION, THE MATRIX
C         ELEMENTS IN  QUESTION  C A N N O T  BE  CALCULATED  IN  THE
C         F I R S T  ITERATION OF THE CURRENT RUN.
C=======================================================================
C
      PRIYUK=PRINIT.AND.I_YUKA.GE.1.AND.ITERUN.GT.1
C
C=======================================================================
C         HERE WE DEFINE THE LOGICAL SWITCH  "PRIBET"  THAT  DECIDES  ON
C         WHETHER OR NOT THE BOHR DEFORMATION PARAMETERS WILL BE PRINTED
C=======================================================================
C
      PRIBET=PRINIT.AND.(IPRIBE.EQ.1.OR.IPRIBL.EQ.1)
C
C=======================================================================
C         HERE WE DEFINE THE INTEGER VARIABLES THAT DECIDE ON  HOW  MANY
C         MULTIPOLE, SURFACE  OR  SCHIFF,  MAGNETIC,  OR  SPIN-ASYMMETRY
C         MOMENTS IN ONE OF THE REFERENCE FRAMES HAVE TO  BE  CALCULATED
C         IN THE CURRENT ITERATION. THE NAMING CONVENTION IS AS FOLLOWS:
C
C         KXXXYY DENOTES THE NUMBER OF "YY" MOMENTS IN THE "XXX"  FRAME,
C                WHERE YY AND XXX READ:
C
C         XXX = MUL  -->  LABORATORY FRAME
C         XXX = SHI  -->  C-O-M FRAME
C         XXX = ROT  -->  INTRINSIC FRAME
C
C         YY  = MO   -->  MULTIPOLE MOMENTS
C         YY  = SI   -->  SURFACE OR SCHIFF MOMENTS
C         YY  = MA   -->  MAGNETIC MOMENTS
C         YY  = AS   -->  SPIN-ASYMMETRY MOMENTS
C
C         THE NUMBERS OF MULTIPOLE, SURFACE  OR  SCHIFF,  AND  MAGNETIC
C         MOMENTS ARE SET  INDEPENDENTLY  FROM  ONE  ANOTHER,  HOWEVER,
C         FOR ISCHIF=1 THE NUMBER OF SCHIFF MOMENTS MUST NOT BE  LARGER
C         THAN THAT OF THE MULTIPOLE MOMENTS, THAT IS, KMULMO >= KMULSI
C
C         SINCE ALL THE MOMENTS IN THE INTRINSIC FRAME  ARE  CALCULATED
C         IN THE C-O-M FRAME, THE NUMBERS THEREOF MUST OBEY:
C         KMULMO >= KSHIMO >= KROTMO
C         KMULSI >= KSHISI >= KROTSI
C         KMULMA >= KSHIMA >= KROTMA (NOT IMPLEMENTED YET)
C         KMULAS >= KSHIAS >= KROTAS (NOT IMPLEMENTED YET)
C
C         IN ADDITION, ALL CALCULATED LABORATORY MOMENTS MUST BE  LARGER
C         THEN THE CORRESPONDING  REDUCED  MOMENTS  CALCULATED  FOR  THE
C         ANGULAR-MOMENTUM-PROJECTED (AMP) STATES
C=======================================================================
C
                  KROTMO=2
      IF (PRINIT) KROTMO=MAX(KROTMO,NMUPRI)
      IF (TERMNT) KROTMO=MAX(KROTMO,NMUMAX)
C
                  KSHIMO=KROTMO
C
                  KMULMO=KSHIMO
                  KMULMO=MAX(KMULMO,NMUCON)
                  KMULMO=MAX(KMULMO,NMUCOU)
C
C=======================================================================
C
                  KROTSI=0
      IF (PRINIT) KROTSI=MAX(KROTSI,NSIPRI)
      IF (TERMNT) KROTSI=MAX(KROTSI,NSIMAX)
C
                  KSHISI=KROTSI
C
                  KMULSI=KSHISI
                  KMULSI=MAX(KMULSI,NSICON)
C
      IF (ISCHIF.EQ.1) KMULMO=MAX(KMULMO,KMULSI)
C
C=======================================================================
C
                  KROTMA=0
      IF (PRINIT) KROTMA=MAX(KROTMA,NMAPRI)
      IF (TERMNT) KROTMA=MAX(KROTMA,NMAMAX)
C
                  KSHIMA=KROTMA
C
                  KMULMA=KSHIMA
                  KMULMA=MAX(KMULMA,NMACON)
C
C=======================================================================
C
                  KROTAS=0
      IF (PRINIT) KROTAS=MAX(KROTAS,NASPRI)
      IF (TERMNT) KROTAS=MAX(KROTAS,NASMAX)
C
                  KSHIAS=KROTAS
C
                  KMULAS=KSHIAS
                  KMULAS=MAX(KMULAS,NASCON)
C
C=======================================================================
C
      IF (IPRGCM.GE.1) THEN
C
          KMULMO=MAX(KMULMO,NMURED)
          KMULSI=MAX(KMULSI,NSIRED)
          KMULMA=MAX(KMULMA,NMARED)
          KMULAS=MAX(KMULAS,NASRED)
C
      END IF
C
C=======================================================================
C         HERE WE DEFINE THE LOGICAL SWITCH "COR_CM" THAT DECIDES ON
C         WHETHER OR NOT THE QUADRATIC CORRECTION FOR THE CENTER  OF
C         MASS MOTION WILL BE CALCULATED IN THE  CURRENT  ITERATION.
C         SINCE SUCH A CALCULATION IS FAIRLY TIME CONSUMING,  IT  IS
C         PERFORMED ONLY WHEN NECESSARY. FOR EXAMPLE, WHEN THE C-O-M
C         CORRECTION NEEDS TO BE ADDED ONLY AFTER THE VARIATION,  IT
C         IS CALCULATED ONLY IN THE LAST ITERATION. ATTENTION:  SUCH
C         A PROCEDURE RESULTS IN THE TOTAL ENERGY BEING DIFFERENT IN
C         THE LAST BUT ONE AND LAST ITERATIONS.
C=======================================================================
C
      COR_CM=(JETACM.EQ.1.AND.(PRINIT.OR.TERMNT)).OR.
     *        JETACM.EQ.2
C
C=======================================================================
C         SAME AS ABOVE FOR THE LOGICAL SWITCH "CORROT" THAT DECIDES
C         ON THE QUADRATIC CORRECTION FOR THE ROTATIONAL MOTION.
C=======================================================================
C
      CORROT=(KETA_R.EQ.1.AND.(PRINIT.OR.TERMNT)).OR.
     *        KETA_R.EQ.2
C
C=======================================================================
C         HERE WE SET PARAMETER  "IDEVAR"  WHICH REQUESTS CALCULATION OF
C         THE PAIRING MATRIX ELEMENTS IN THE CURRENT ITERATION.
C         THE TRICK WITH IDEAUX IS USED ONLY FOR THE PURPOSE OF AVOIDING
C         DIVISION BY 0 WITHIN MOD(NUMITE,IDEAUX) FOR IDEDIS=0
C=======================================================================
C
      IDEAUX=IDEDIS
      IF (IDEDIS.LT.1) IDEAUX=1
C
      IF (JPABCS.EQ.3.AND.
     *   ((NUMITE.EQ.ITESTA.AND.                     IDESTA.EQ.1).OR.
     *    (NUMITE.GT.ITESTA.AND.NUMITE.LT.ITESTO.AND.IDEMID.EQ.1).OR.
     *   ((NUMITE.EQ.ITESTO.OR.TERMNT)          .AND.IDESTO.EQ.1).OR.
     *    (MOD(NUMITE,IDEAUX).EQ.0              .AND.IDEDIS.GE.1))) THEN
C
           IDEVAR=1
      ELSE
           IDEVAR=0
C
      END IF
C
C=======================================================================
C        SAVING THE SINGLE-PARTICLE DATA THAT HAVE BEEN OBTAINED
C        IN THE PREVIOUS ITERATION
C=======================================================================
C
      IF (ITERUN.GT.1) CALL OLSTOR
C
C=======================================================================
C         ZEROING THE SINGLE-PARTICLE MATRICES
C=======================================================================
C
      CALL SPZERO
C
C=======================================================================
C         HERE BEGINS THE CALCULATION WITHOUT THE PROTON-NEUTRON MIXING
C=======================================================================
C
      IF (IPNMIX.EQ.1) GO TO 8972
C
C=======================================================================
C         FOR IN_FIX=0 WE DO NOT PERFORM ANY CALCULATIONS FOR NEUTRONS
C=======================================================================
C
      IF (IN_FIX.EQ.0) GO TO 8970
C
C=======================================================================
C         HERE STARTS THE BLOCK FOR  N E U T R O N S
C=======================================================================
C
      NAMEPN='NEUTRONS'
C
      ICHARG=0
      ITPNMX=0
C
C=======================================================================
C         SETTING THE SWITCHES THAT DOWNGRADE HFB TO HF IF NEEDED
C=======================================================================
C
      IF (IPA2HF(ICHARG).EQ.1.OR.
     *    IPA2HF(ICHARG).EQ.2.AND.ABS(DELTAN).LT.DEL2HF(ICHARG)) THEN
C
          IF (IPA2HF(ICHARG).EQ.2.AND.ABS(DELTAN).LT.DEL2HF(ICHARG).AND.
     *        IND2HF(ICHARG).NE.1) THEN
C
              WRITE(NFIPRI,'(                                 79(1H*),/,
     *              1H*,7X,'' FROM NOW ON, THE HFB MODE FOR NEUTRONS'',
     *                     '' IS SWITCHED OVER TO HF '',      7X,1H*)')
              IND2HF(ICHARG)=1
C
          END IF
C
          MPAHFB=0
          MPABCS=0
          MPAIRI=0
      ELSE
          MPAHFB=IPAHFB
          MPABCS=JPABCS
          MPAIRI=IPAIRI
C
      END IF
C
      KPAHFB(ICHARG)=MPAHFB
C
C=======================================================================
C        CALCULATING THE MATRIX ELEMENTS OF THE NEUTRON MEAN FIELD
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.50G) AND (2.552) THE CALL TO
C                       "INTEGH"  BELOW  WAS  PERFORMED  FOR  UNDECLARED
C                       ARRAYS "ALINLI" AND "AROTLI" INSTEAD OF "ALINLT"
C                       AND "AROTLT". THIS COULD GIVE INCORRECT  RESULTS
C                       FOR THE EXACT C-O-M CORRECTION BEFORE VARIATION.
C                       THIS BUG WAS CORRECTED ON 06/11/2012 IN  VERSION
C                       (2.553). THE SAME COMMENT APPLIES TO  TWO  OTHER
C                       CALLS TO "INTEGH" BELOW.
C=======================================================================
C        TWO-CENTRE BASIS OPTION: THE MATRIX ELEMENTS OF THE SKYRME
C        HAMILTONIAN ARE GIVEN BY
C
C                    H_IJ= SUM_KL <I|O_KL|J>
C
C        WHERE I,J,K,L REFER TO THE INDEX OF THE CENTRE AND O_KL STANDS
C        FOR AN ARBRITARY MEAN FIELD TERM DEPENDING ON THE W.F'S. THE
C        ORDER OF THE INDEXES IS GIVEN BY THE TABLE
C
C                            I | J | K | L
C                           ---------------
C                       1.   1   1   1   1
C                       2.   1   1   1   2
C                       3.   1   1   2   1
C                       4.   1   1   2   2
C                       5.   1   2   1   1
C                       6.   1   2   1   2
C                       7.   1   2   2   1
C                       8.   1   2   2   2
C                       9.   2   1   1   1
C                      10.   2   1   1   2
C                      11.   2   1   2   1
C                      12.   2   1   2   2
C                      13.   2   2   1   1
C                      14.   2   2   1   2
C                      15.   2   2   2   1
C                      16.   2   2   2   2
C
C        HENCE, THE PAIR IJ SPECIFIES THE BLOCK OF THE HAMILTONIAN, AND
C        IS DETERMINED BY THE OUTER LOOP AS
C
C            LTWCEN=1 --> C1C1
C            LTWCEN=2 --> C2C2
C            LTWCEN=3 --> C2C1 (THE BLOCK C1C2 IS THE COMPLEX
C                              CONJUGATE AND IS BUILD IN TWCCCOP)
C
C        THEN, INNERK/INNERL SPECIFIES THE INDEX FOR THE FIELDS AND FOUR
C        DIFFERENT TERMS ARE SUMMED UP INSIDE INTEGH.    ONCE THE SUM IS
C        DONE, FOR EVERY LTWCEN WE BUILD THE HAMILTONIAN IN TWCCOP AS
C
C
C              (++) | C1C1 | C1C2  |  C1C1 | C1C2 | (+-)
C                   | C2C1 | C2C2  |  C2C1 | C2C2 |
C                      -------------------------
C              (-+) | C1C1 | C1C2  |  C1C1 | C1C2 | (--)
C                   | C2C1 | C2C2  |  C2C1 | C2C2 |
C
C        WHERE +/- STANDS FOR THE SIMPLEX BLOCK.
C
C=======================================================================
C
      IF (NUMITE.GT.0) THEN
C
          IF (NUMITE.GT.ITESTA.OR.(IFCONT.NE.1.AND.IF_THO.EQ.0)) THEN
C
              DO LTWCEN=1,NBLDEN
C
                 INNERI=IND2HL(LTWCEN)
                 INNERJ=IND2HR(LTWCEN)
C
                 DO INNERK=1,ITWCEN
                    DO INNERL=1,ITWCEN
C
                       INDCOE=INTWHE(INNERI,INNERJ,INNERK,INNERL)
C
                       CALL INTEGH(IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                      IPNMIX,ITPNMX,IROTAT,ICHARG,ISIMPY,
     *                             MPAHFB,IPOTHO,ISCHIF,IOCONT,
     *                                           NMUCON,NSICON,
     *                             I_YUKA,I_GOGA,I_REGA,I_SEPA,
     *                                    ITWOLI,JETACM,ALINLT,
     *                                           KETA_R,AROTLT,
     *                                           ICOUDI,ICOUEX,
     *                                           LIPKIN,LIPKIP,
     *                                           EFER2N,EFER2P,
     *                                                  IF_RPA,
     *                                           ILIPON,ILIPOP,
     *                                                  NEWGOG,
     *                                           LTWCEN,ITWCEN,
     *                                                  INDCOE)
C
                    END DO
                 END DO
C
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.78A) AND (2.83Q) THE CALL TO
C                       "MIXFIL"  BELOW  WAS  IN  THE  FIRST   ITERATION
C                       PERFORMED FOR UNDEFINED ARRAYS FIL_PP AND FIL_PM
C                       UNLESS A RESTART FROM FIELDS WAS IN EFFECT.
C                       THIS BUG WAS CORRECTED ON 23/11/2017 IN  VERSION
C                       (2.83R). THE SAME COMMENT APPLIES TO  TWO  OTHER
C                       CALLS TO "MIXFIL" BELOW.
C=======================================================================
C
                 IF (NUMITE.GT.ITESTA.OR.
     *              (IFCONT.EQ.1.OR.IF_THO.EQ.1)) THEN
C
                     IF (I_SLOW.EQ.1)
     *               CALL MIXFIL(ISIMPY,ICHARG,SLOWAL,ITWCEN,LTWCEN)
C
                 END IF
C
                 IF (ITWCEN.EQ.2) THEN
C
                     CALL TWCCOP(ICHARG,LTWCEN)
                     CALL TWC_SAVFIL(0,ICHARG,LTWCEN)
C
                 END IF
C
              END DO
C
          ELSE
C
              DO LTWCEN=1,NBLDEN
C
                 CALL GETFIL(ISIMPY,ICHARG,LTWCEN,ITWCEN)
                 IF (ITWCEN.EQ.2) CALL TWCCOP(ICHARG,LTWCEN)
C
              END DO
C
          END IF
C
          SPMODL='HARTREE-FOCK  '
C
C=======================================================================
C        CALCULATING THE MATRIX ELEMENTS OF THE NEUTRON PAIRING FIELD
C=======================================================================
C
          IF (MPAHFB.GE.1) THEN
C
              IF (NUMITE.GT.ITESTA.OR.(IFCONT.NE.1.AND.IF_THO.EQ.0))
     *        THEN
C
                  DO LTWCEN=1,NBLDEN
C
                     INNERI=IND2HL(LTWCEN)
                     INNERJ=IND2HR(LTWCEN)
C
C=======================================================================
C        TWO-CENTRE BASIS OPTION: THE FIXED DELTA CASE DOESN'T REQUIRE
C        INNER LOOPS AND INDCOE IS IGNORED WITHIN INTEGD.
C=======================================================================
C
                                                      ITWCE2=     1
                     IF (IDEFIN.EQ.0.AND.ITWCEN.EQ.2) ITWCE2=ITWCEN
C
                     DO INNERK=1,ITWCE2
                        DO INNERL=1,ITWCE2
C
                           INDCOE=INTWHE(INNERI,INNERJ,INNERK,INNERL)
C
                           CALL INTEGD(ITPNMX,ISIMPY,ICHARG,
     *                          DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                                        JETACM,KETA_R,
     *                          IGOGPA,IREGPA,ISEPPA,ICOUPA,
     *                                        NEWGOG,NEWCOU,
     *                                 LTWCEN,ITWCEN,INDCOE)
                        END DO
                     END DO
C
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.78A) AND (2.83Q) THE CALL TO
C                       "MIXPAI"  BELOW  WAS  IN  THE  FIRST   ITERATION
C                       PERFORMED FOR UNDEFINED ARRAYS FIPIDE AND FIP2DE
C                       UNLESS A RESTART  FROM  FIELDS  WAS  IN  EFFECT.
C                       MOREOVER, IN THE CALL TO "MIXPAI", THE  NAME  OF
C                       VARIABLE "SLOWAL"  WAS  MISSPELLED.  THESE  BUGS
C                       WERE CORRECTED ON 23/11/2017 IN VERSION (2.83R).
C                       THE SAME COMMENT APPLIES TO THREE OTHER CALLS TO
C                       "MIXPAI" BELOW.
C=======================================================================
C
                     IF (NUMITE.GT.ITESTA.OR.
     *                  (IFCONT.EQ.1.OR.IF_THO.EQ.1)) THEN
C
                          IF (I_SLOW.EQ.1) CALL MIXPAI(ICHARG,REA2PP,
     *                                          SLOWAL,ITWCEN,LTWCEN)
C
                     END IF
C
                     IF (ITWCEN.EQ.2) THEN
C
                         CALL TWDECO(ICHARG,LTWCEN)
                         CALL TWC_SAVFIL(1,ICHARG,LTWCEN)
C
                     END IF
C
                  END DO
C
              ELSE
C
                  DO LTWCEN=1,NBLDEN
C
                     CALL GETPAI(ICHARG,REA2PP,LTWCEN,ITWCEN)
                     IF (ITWCEN.EQ.2) CALL TWDECO(ICHARG,LTWCEN)
C
                  END DO
C
              END IF
C
              IF (IMFHFB.EQ.1) THEN
C
                  SPMODL='HFB MEAN FIELD'
              ELSE
                  SPMODL='CANONICAL     '
C
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C        INITIALIZING THE MATRIX ELEMENTS OF THE NEUTRON MEAN FIELD
C=======================================================================
C        TWO-CENTRE BASIS OPTION: THE INITIAL WAVE FUNCTIONS ARE GIVEN
C        BY THE DIAGONALISATION OF THE NILSON HAMILTONIAN WHICH IS
C        BUILT ONLY FOR DIAGONAL TERMS.
C=======================================================================
C
          IF (IREAWS.EQ.1) THEN
C
              CALL WSHAMI(ITILAX,ITISAX,NO_ORB,ICHARG,ISIMPY)
C
              SPMODL='WOODS-SAXON   '
C
          ELSE
C
              DO LTWCEN=1,ITWCEN
C
                 CALL NILSON(ITILAX,ITISAX,NO_ORB,INNUMB,IZNUMB,
     *                              ICHARG,NAMEPN,HOMEGA,ISIMPY,
     *                                            ITWCEN,LTWCEN)
                 SPMODL='NILSSON       '
C
                 IF (ITWCEN.EQ.2) THEN
C
                     CALL TWCCOP(ICHARG,LTWCEN)
                     IF (I_SLOW.EQ.1) CALL TWC_SAVFIL(0,ICHARG,LTWCEN)
C
                 END IF
C
              END DO
C
          END IF
C
C=======================================================================
C        INITIALIZING THE MATRIX ELEMENTS OF THE NEUTRON PAIRING FIELD
C=======================================================================
C
          IF (MPAHFB.GE.1) THEN
C
              CALL INIPAI(ITPNMX,IPNMIX,ITWCEN,LDTWCE)
C
              IF (JETACM.EQ.2) CALL ZERLIN(ISIMPY,MPAIRI)
              IF (KETA_R.EQ.2) CALL ZERROT(ISIMPY,MPAIRI)
C
              DO LTWCEN=1,ITWCEN
C
                 INNERI=IND2HL(LTWCEN)
                 INNERJ=IND2HR(LTWCEN)
C
                                                  ITWCE2=     1
                 IF (IDEFIN.EQ.0.AND.ITWCEN.EQ.2) ITWCE2=ITWCEN
C
                 DO INNERK=1,ITWCE2
                    DO INNERL=1,ITWCE2
C
                       INDCOE=INTWHE(INNERI,INNERJ,INNERK,INNERL)
C
                       CALL INTEGD(ITPNMX,ISIMPY,ICHARG,
     *                      DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                                    JETACM,KETA_R,
     *                      IGOGPA,IREGPA,ISEPPA,ICOUPA,
     *                                    NEWGOG,NEWCOU,
     *                             LTWCEN,ITWCEN,INDCOE)
C
                    END DO
                 END DO
C
                 IF (ITWCEN.EQ.2) THEN
C
                     CALL TWDECO(ICHARG,LTWCEN)
                     IF (I_SLOW.EQ.1) CALL TWC_SAVFIL(1,ICHARG,LTWCEN)
C
                 END IF
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C        MIXING OF THE MATRIX ELEMENTS OF THE HFB MATRIX. USUAL LINEAR
C        MIXING IS HANDLED BY THE ROUTINE DOBROY_MATRIX(), THE BROYDEN
C        CORRECTION BEING SIMPLY NOT ADDED
C=======================================================================
C
      IF (MIXMAT.EQ.1) THEN
C
          IF (ITERUN.GT.1) THEN
C
              CALL HPH_IN(ISIMPY,MREVER,ICHARG)
              IF (MPAHFB.GE.1) CALL DEL_IN(MREVER,IROTAT,ICHARG)
C
C              Evolving the Broyden and affecting the ouput
C
              CALL DOBROY_MATRIX(ITERUN,NSWBRN,ITAK_N,
     *                           NOICAN,SLOWEV,ESTABN,
     *                           EFERMN,EFENIN,EFENOU,
     *                           EFER2N,EF2NIN,EF2NOU,
     *                           LIPKIN,NOFBRN,ICHARG,
     *                                         MPAHFB)
C
              CALL HPH_OU(ISIMPY,MREVER,ICHARG)
              CALL GETFIL(ISIMPY,ICHARG,1,1)
C
              IF (MPAHFB.GE.1) THEN
                  CALL DEL_OU(MREVER,IROTAT,ICHARG)
                  CALL GETPAI(ICHARG,REA2PP,1,1)
              END IF
C
          ELSE
              CALL SAVFIL(ISIMPY,MPAHFB,ICHARG,REA2PP)
          END IF
C
      END IF
C
C=======================================================================
C        SAVING  THE   N E U T R O N   MEAN FIELDS
C=======================================================================
C            ATTENTION: BETWEEN  VERSIONS  (2.78T)  AND   (2.80J),   FOR
C                       I_SLOW=1, THE CALLS TO SAVFIL BELOW AND  FURTHER
C                       DOWN, WERE NOT PERFORMED. AS A RESULT, THE  CODE
C                       WAS ITERATING WITH  OLD  FIELDS  NOT  STORED  IN
C                       FIL_PP & FIL_PM, AND DID NOT CONVERGE. THIS  BUG
C                       WAS CORRECTED ON 11/06/2017 IN VERSION  (2.80K).
C
C                       NOTE THAT IN VERSIONS FROM (2.78D)  TO  (2.78S),
C                       THE STORING WAS NOT PERFOREMD EITHER, BUT THERE,
C                       THE  OLD  FIELDS  FIL_PP & FIL_PM  WERE  UPDATED
C                       DIRECTLY IN "MIXFIL". ALTHOUGH, SUCH A  SOLUTION
C                       WAS  INCONSISITENT,  AND  IT  WAS  CORRECTED  IN
C                       VERSION (2.78T), BUT THIS CORRECTION  LED  TO  A
C                       PROBLEM OF FIL_PP & FIL_PM BEING NEVER UPDATED.
C=======================================================================
C
      IF ((IWRIFI.NE.-1.OR.I_SLOW.EQ.1).AND.MIXMAT.EQ.0.AND.ITWCEN.EQ.1)
     *    CALL SAVFIL(ISIMPY,MPAHFB,ICHARG,REA2PP)
C
C=======================================================================
C        DIAGONALIZING THE MATRIX OF THE NEUTRON   H F B   HAMILTONIAN
C=======================================================================
C
      IF (MPAHFB.GE.1) THEN
C
          IREMQB(:)=0
          INUMQB(:)=0
          JNUMQB(:)=0
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL HFBSIG(EFERMN,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALN,IFERAN,PARNUN,IN_FIX,
     *                                             ITWOBA,IWRIQU,
     *                               INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *                                             IFIBLN,ISABLN,
     *                               IREQPB,INUQPB,JNUQPB,IF_RPA)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              ELSE
C
                  IF (IFERAN.EQ.1) STOP ' ALM METHD NOT IMPLEMENTED YET'
C
                  CALL HFBSIM(EFERMN,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALN,IFERAN,PARNUN,IN_FIX,
     *                                             ITWOBA,IWRIQU,
     *                                      INSIMN,IRSIMN,IDSIMN,
     *                                             IFIBLN,ISABLN,
     *                               IREQPB,INUQPB,JNUQPB,IF_RPA)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  IF (IFERAN.EQ.1) STOP ' ALM METHD NOT IMPLEMENTED YET'
C
                  CALL HFBSIQ(EFERMN,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALN,IFERAN,PARNUN,IN_FIX,
     *                                             ITWOBA,NUQEVE,
     *                                      INSIQN,IPSIQN,IDSIQN,
     *                                             IFIBLN,ISABLN,
     *                                      IREQPB,INUQPB,JNUQPB)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              ELSE
C
                  IF (IFERAN.EQ.1) STOP ' ALM METHD NOT IMPLEMENTED YET'
C
                  IF (ITWCEN.EQ.1) THEN
C
                  CALL HFBSIZ(EFERMN,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALN,IFERAN,PARNUN,IN_FIX,
     *                                             ITWOBA,NUQEVE,
     *                                             INSIZN,IDSIZN,
     *                                             IFIBLN,ISABLN,
     *                               IREMQB,INUMQB,JNUMQB,ISAOCC)
C
                  ELSEIF (ITWCEN.EQ.2) THEN
C
                      CALL TWCSIZ_NATBAS(ICHARG,LDMEFI,MPAHFB,EFERMN,
     *                                   ECUTOF,LAMCUT,INSIZN,IDSIZN,
     *                                   IFIBLN,ISABLN,IREMQB,INUMQB,
     *                                                        JNUMQB)
C
                  END IF
C
              END IF
C
          END IF
C
#if(USE_MPI==1)
          IF (escapeSignal.Eq.1) THEN
C
              WRITE(6,'(''Process '',i6,
     *                  '' - HFBSIM failed for neutrons. '',
     *                  ''Closing all files and exiting...'')')
     *                    WorldRank
C
              ! Properly close all files that could have been left
              ! opened (with the exclusion of the output unit NFIPRI)
              CALL IOCLOS(NFIWOO,NFIREP,NFIREV,NFIREC,NFICOU,NFIWAV,
     *                    NFIKER,NFIYUP,NFIYUC,NFIGOC,NFIGOP,NFIGPC,
     *                    NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *                    NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP)
C
              EXIT procLoop
C
          END IF
#endif
C
          EFENIN=EFERMN
C
          CALL QUABCS(EFERMN,IN_FIX,FERFIN,IFEFIN,ICHARG,
     *                       IDSIGN,IDSIMN,IDSIQN,IDSIZN,
     *                              IPRGCM,NUQEVE,ITWOBA,
     *                              FERALN,IFERAN,PARNUN,
     *                              IREMQB,INUMQB,JNUMQB,
     *                                     ISIMPY,ISIQTY)
C
#if(USE_MPI==1)
          IF (escapeSignal.Eq.1) THEN
C
              WRITE(6,'(''Process '',i6,
     *                  '' - QUABCS failed for neutrons. '',
     *                  ''Closing all files and exiting...'')')
     *                    WorldRank
C
              ! Properly close all files that could have been left
              ! opened (with the exclusion of the output unit NFIPRI)
              CALL IOCLOS(NFIWOO,NFIREP,NFIREV,NFIREC,NFICOU,NFIWAV,
     *                    NFIKER,NFIYUP,NFIYUC,NFIGOC,NFIGOP,NFIGPC,
     *                    NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *                    NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP)
C
              EXIT procLoop
C
          END IF
#endif
C
          EFENOU=EFERMN
C
          IF (PRINIT) THEN
C
              IF (IQUNIL.GE.1) CALL NILAQP(NOSCIL,MREVER,ICHARG,
     *                                            ISIMPY,NILXYZ)
C
              CALL SPTQUA(EMAXQU,ICHARG,NAMEPN,NILXYZ,
     *                    IQUNIL,ISIGNY,ISIMPY,ISIQTY,
     *                    IDSIGN,IDSIMN,IDSIQN,IDSIZN,
     *                           IREMQB,INUMQB,JNUMQB)
C
          END IF
C
      END IF
C
C=======================================================================
C        DIAGONALIZING THE MATRIX OF THE   N E U T R O N   MEAN FIELD
C=======================================================================
C
      DISLIN=0.0D0
C
      IF (MPAHFB.GE.1) THEN
C
          IF (ITWCEN.EQ.1) THEN
C
              IF (ISIMPY.EQ.1) THEN
C
                  CALL CANQUA(MREVER,ICHARG,IMFHFB,IREQPB,
     *                        LIPNON,PARLIN,DISLIN,ESUM_N)
              ELSE
                  CALL CANQUZ(ICHARG,IMFHFB,LIPNON,PARLIN,DISLIN,ESUM_N)
C
              END IF
C
          END IF
C
      ELSE
C
          LIMPAR=0
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL DIASIG(MREVER,ICHARG,LIMPAR,ECUTOF)
C
              ELSE
C
                  CALL DIASIM(MREVER,ICHARG,LIMPAR,ECUTOF)
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  CALL DIASIQ(ICHARG,LIMPAR,ECUTOF)
C
              ELSE
C
                  IF (ITWCEN.EQ.1) THEN
C
                      CALL DIASIZ(ICHARG,LIMPAR,ECUTOF,LDMEFI,ISAOCC)
C
                  ELSEIF(ITWCEN.EQ.2) THEN
C
                      CALL TWCSIZ_NATBAS(ICHARG,LDMEFI,MPAHFB,EFERMN,
     *                                   ECUTOF,LAMCUT,INSIZN,IDSIZN,
     *                                   IFIBLN,ISABLN,IREMQB,INUMQB,
     *                                                        JNUMQB)
C
                  END IF
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C        CALCULATING VARIOUS SINGLE-PARTICLE AVERAGES FOR NEUTRONS
C=======================================================================
C=======================================================================
C        THESE CALLS TO SUBROUTINES CALCULATING VARIOUS SINGLE-PARTICLE
C        AVERAGES ARE PERFORMED ONLY WHEN IT IS  ABSOLUTELY  NECESSARY:
C                              1. FOR THE DIABATIC BLOCKING CALCULATION
C                              2. WHEN THE PING-PONG  HAS BEEN DETECTED
C                              3. WHEN THE DIVERGENCE HAS BEEN DETECTED
C                              4. IN THE LAST ITERATION (TERMNT=.TRUE.)
C                              5. TO PRINT THE RESULTS  (PRINIT=.TRUE.)
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          IF((ISIMPY.EQ.1.AND.IFLIPI.NE.0.AND.ICHFLI.EQ.ICHARG)     .OR.
     *
     *   (ISIMPY.EQ.1.AND.ISIGNY.EQ.1.AND.(NOFLIG(0,0,ICHARG).NE.0  .OR.
     *                                     NOFLIG(0,1,ICHARG).NE.0  .OR.
     *                                     NOFLIG(1,0,ICHARG).NE.0  .OR.
     *                                     NOFLIG(1,1,ICHARG).NE.0)).OR.
     *
     *   (ISIMPY.EQ.1.AND.ISIGNY.NE.1.AND.(NOFLIM(  0,ICHARG).NE.0  .OR.
     *                                     NOFLIM(  1,ICHARG).NE.0)).OR.
     *
     *   (ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.(NOFLIQ(  0,ICHARG).NE.0  .OR.
     *                                     NOFLIQ(  1,ICHARG).NE.0)).OR.
     *
     *   (ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.(NOFLIZ(    ICHARG).NE.0)).OR.
     *
     *    IS_CON.EQ.1                                               .OR.
     *
     *    IS_PIN.EQ.1                                               .OR.
     *
     *    IS_CHA.EQ.1                                               .OR.
     *
     *    TERMNT                                                    .OR.
     *
     *    PRINIT)                                                   THEN
C
          CALL AVOBSE(MREVER,ICHARG,IPNMIX,NRAORD)
C
          END IF
C
      END IF
C
      CALL AVANGY(MREVER,ICHARG,IPNMIX,ISIMPY,ITWCEN)
C
C=======================================================================
C        CALCULATING SINGLE-PARTICLE AVERAGES FOR NEUTRONS
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL AVPARI(MREVER,ICHARG,IPNMIX)
C
          IF (TERMNT.OR.PRINIT) THEN
C
              CALL AVSIMP(MREVER,ICHARG,IPNMIX)
C
              CALL NILASP(NOSCIL,MREVER,ICHARG,ISIMPY,NILXYZ)
C
          END IF
C
      END IF
C
C=======================================================================
C        CALCULATING THE NEUTRON PAIRING AND DEFINING OCCUPATION FACTORS
C=======================================================================
C
      EPAI_N=0.0
      EREA_N=0.0
      ELIP_N=0.0
C
      IF (MPAIRI.EQ.1) THEN
C
          IF (MPABCS.GT.0) THEN
C
              IF (MPABCS.EQ.1.OR.
     *           (MPABCS.EQ.3.AND.ITERUN.EQ.1))  THEN
C
                  IF (IAVRGG.NE.1) THEN
C
                      CALL SETPAI(IN_FIX,IZ_FIX,FACTGN,ICHARG,GPAIRN)
C
                  ELSE
C
                      CALL GAVRAG(IN_FIX,IZ_FIX,FACTGN,ICHARG,GPAIRN)
C
                  END IF
C
              END IF
C
              EFENIN=EFERMN
              CALL DELPAI (ICHARG,MREVER,MPABCS,IN_FIX,ITERUN,
     *                     DELFIN,GPAIRN,EPAI_N,EFERMN,DELTAN)
              EFENOU=EFERMN
C
              IF (PRINIT)
     *
     *            CALL PAIPRI(NAMEPN,GPAIRN,EPAI_N,EFERMN,DELTAN,
     *                                      LIPKIN,EFER2N,ELIP_N,
     *                                      MPAHFB,MPABCS,IAVRGG,
     *                               IGOGPA,IREGPA,ISEPPA,ICOUPA)
C
          END IF
C
      ELSE
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL CONSIG(MREVER,ICHARG,IN_FIX,EFERMN,
     *                               ICHFLI,IPAFLI,IREFLI,
     *                               ISPFLI,ISHFLI,IFLIPI)
              ELSE
C
                  CALL CONSIM(MREVER,ICHARG,IN_FIX,EFERMN,
     *                               ICHFLI,       IREFLI,
     *                               ISPFLI,ISHFLI,IFLIPI)
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  CALL CONSIQ(ICHARG,IN_FIX,EFERMN,
     *                        ICHFLI,IPAFLI,
     *                        INSIQN,IPSIQN,IDSIQN,
     *                               IFIBLN,ISABLN,
     *                        ISPFLI,ISHFLI,IFLIPI,
     *                               NLSIQN,MXALIN)
              ELSE
C
                  CALL CONSIZ(ICHARG,IN_FIX,EFERMN,
     *                        ICHFLI,INSIZN,IDSIZN,
     *                               IFIBLN,ISABLN,
     *                        ISPFLI,ISHFLI,IFLIPI,
     *                               NLSIZN,MXALIN,
     *                                      ISAOCC,
     *                                      ITWCEN)
C
              END IF
C
          END IF
C
          DELTAN=0.0D0
C
      END IF
C
C=======================================================================
C       PRINTING SINGLE-PARTICLE SPECTRA FOR NEUTRONS
C=======================================================================
C
      IF (PRINIT) THEN
C
          CALL SPTALL(EMINAL,EMAXAL,SPMODL,NAMEPN,
     *                ISIGNY,ISIMPY,ISIQTY,MPAHFB,
     *                       MREVER,ICHARG,NILXYZ,
     *                IDSIGN,IDSIMN,IDSIQN,IDSIZN,NRAORD,
     *                                            ITWCEN)
C
      END IF
C
C=======================================================================
C        CALCULATING THE SUM OF NEUTRON SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      IF (MPAHFB.LT.1)
     *
     *    CALL SPENSU(MREVER,ESUM_N,ICHARG,ISIMPY,ITWCEN)
C
C=======================================================================
C        CALCULATING THE SUM OF NEUTRON QUASIPARTICLE ENERGIES
C=======================================================================
C
      IF (MPAHFB.GE.1.AND.IQPSTA.EQ.1)
     *
     *    CALL QPENSU(MREVER,ESUM_N,EFERMN,ICHARG)
C
C=======================================================================
C        ZEROING THE NEUTRON DENSITIES
C=======================================================================
C
      CALL ZEDENS(ITPNMX)
C
C=======================================================================
C        CALCULATING THE NEUTRON DENSITIES AND CURRENTS
C=======================================================================
C        TWO-CENTRE BASIS OPTION: FOR INTEGRATING THE HAMILTONIAN MATRIX
C        ELEMENTS AND THE ENERGY OF THE FUNCTIONAL WE DEAL WITH THE PRO-
C        DUCT OF FOUR WAVE FUNCTIONS. TO PROPERLY USE GAUSS-HERMITE QUA-
C        TURE, DENSITIES MUST BE EVALUATED IN SIXTEEN DIFFERENT SETS OF
C        POINTS WHICH INVOLVE THE CENTRE PARAMETERS (FREQUENCIES OF THE
C        BASIS AND POSITION OF THE CENTRES) OF ALL FOUR WAVE FUNCTIONS.
C        THEN, THE DENSITIES DE_() WILL DEPEND NOT ONLY IN KL (SEE
C        COMMENTS BEFORE INTEGH) BUT ALSO IN IJ.
C
C        TO USE THE PROPER COEFFICIENTS (WARIGH) RELATED TO ONE CENTRE
C        OR THE OTHER, WE CALL DENSHF AS FOLLOWS
C            1. LTWCEN=1 COMPUTES DENSITIES FOR I=J=K=L=1. WARIGH
C               OF THE FIRST CENTRE IS STORED IN SARIGH(:,:,:,:,1).
C            2. LTWCEN=16 (VALUE OF NDTWHE) COMPUTES DENSITIES FOR
C               I=J=K=L=2. WARIGH OF THE SECOND CENTRE IS STORED IN
C               SARIGH(:,:,:,:,2).
C            3. LTWCEN= 2 -> 15 WILL USE FIRST OR SECOND CENTRE COEFFI-
C               CIENTS IN FUNCTION OF THE INDEXES KL. E.G.:
C               K=1,L=2 --> WALEFT: SARIGH(...,1), WARIGH: SARIGH(...,2)
C
C        ATTENTION: THE NEXT PROCEDURE IS NOT IMPLEMENTED YET.
C        COMMENT ON ACCELERATION OF THIS PART: ONLY NINE OF THE SIXTEEN
C        DENSITIES ARE DIFFERENT.THIS IS DUE TO:
C            1. SWAPPING INDEXES I AND J DOESN'T CHANGE NEITHER THE
C            WARIGH COEFFIENTS (ONLY RELATED TO K AND L) NOR THE TOTAL
C            GAUSSIAN FUNCTION (WHICH DETERMINES THE POINTS WHERE
C            DENSITIES ARE EVALUATED).
C            2. SWAPPING INDEXES K AND L INTERCHANGES WARIGH AND WALEFT
C            BUT MAINTAIN THE SAME TOTAL GAUSSIAN FUNCTION, SO IT WILL
C            PRODUCE THE CONJUGATE OF THE ORIGINAL DENSITY.
C
C        THEN, WE CALL DENSHF FOR NINE SPECIFIC VALUES OF LTWCEN AND
C        THE REST OF DENSITIES (OR THEIR CONJUGATES) ARE COPIED USING
C        TWC_MORDEN.
C=======================================================================
C
      IF (ITWCEN.EQ.2) THEN
C
          ISAWAV=1
          IKERNE=0
C
      END IF
C
C=======================================================================
C     CALLING DENSHF FOR I=J=K=L=1 (SAME AS IN ONE-CENTRE OPTION)
C=======================================================================
C
      CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *            ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,ICHARG,
     *                                 MIN_QP,IPNMIX,ITPNMX,
     *                   ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *            ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                             ITWCEN,1)
C
      IF (ITWCEN.EQ.2) THEN
C
C=======================================================================
C     CALLING DENSHF FOR I=J=K=L=2
C=======================================================================
C
          CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *            ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,ICHARG,
     *                                 MIN_QP,IPNMIX,ITPNMX,
     *                   ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *            ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                        ITWCEN,NDTWHE)
C
          IKERNE=1
          ISAWAV=0
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(WALEFT)) THEN
          ALLOCATE (WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *                                                   STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WALEFT','HFODD ')
          END IF
C
          IF (ITWCEN.GT.NDTWCE) STOP ' ITWCEN.GT.NDTWCE IN HFODD'
C
          DO LTWCEN=1,LDTWDD
C
             IF (LTWCEN.EQ.1.OR.LTWCEN.EQ.16) CYCLE
C
C=======================================================================
C     CONDITION TO AVOID CALLING DENSHF UNNECCESARY TIMES
C=======================================================================
C
             IF (IDCOPY(LTWCEN,IPAIRI).EQ.0) THEN
C
C=======================================================================
C     SELECTING THE COEFFICIENTS FOR THE REST OF DENSITIES
C=======================================================================
C
                 WALEFT(:,:,:)=SARIGH(:,:,:,ICHARG,IND4HK(LTWCEN))
                 WARIGH(:,:,:)=SARIGH(:,:,:,ICHARG,IND4HL(LTWCEN))
C
C=======================================================================
C     CALLING DENSHF FOR THE REST OF THE CASES
C=======================================================================
C
                 CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *            ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,ICHARG,
     *                                 MIN_QP,IPNMIX,ITPNMX,
     *                   ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *            ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                        ITWCEN,LTWCEN)
C
            ELSEIF (IDCOPY(LTWCEN,IPAIRI).NE.0) THEN
C
                 CALL TWC_MORDEN(LTWCEN,ITPNMX,IGRAIN,IPAIRI)
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C        DOUBLING THE SINGLE-PARTICLE RESULTS IN CASE OF NO ROTATION
C=======================================================================
C
      IF (MREVER.EQ.0) THEN
C
          CALL DBLING(ITPNMX)
C
          ESUM_N=2*ESUM_N
C
      END IF
C
C@@@ HFBTHO -HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C        BY DEFAULT,  HFODD  INITIALIZES THE  MATRIX OF THE  MEAN-FIELD
C        BY  COMPUTING THE  MATRIX ELEMENTS  OF THE  NILSON  POTENTIAL.
C        IN  HFB  MODE IT  INITIALIZES  THE MATRIX OF THE PAIRING FIELD
C        BY COMPUTING THE MATRIX ELEMENTS OF THE  DELTA-PAIRING  INTER-
C        ACTION, WHICH DEPENDS ON THE ISO-SCALAR DENSITY, AND THEREFORE
C        ON BOTH PROTON AND NEUTRON DENSITIES ON THE GAUSS-HERMITE MESH.
C        WHEN RESTARTING FROM HFBTHO, THESE DENSITIES ARE NOT AVAILABLE:
C        THE COMPUTATION OF  ALL  PAIRING OBSERVABLES MUST THEREFORE BE
C        SHIFTED TO  AFTER  THE NEW ISOSCALAR DENSITY HAS BEEN COMPUTED.
C        THIS ONLY AFFECTS THE  FIRST ITERATION, SEE ALSO COMMENT ABOUT
C        NUMITE BELOW.
C=======================================================================
C
      IF (IF_THO.EQ.0.OR.ITERUN.NE.1) THEN
C
C=======================================================================
C        CALCULATING THE NEUTRON HFB PAIRING ENERGY AND AVERAGE DELTA
C=======================================================================
C
          IF (MPAHFB.GE.1)
     *
     *        CALL EPAIRI(IN_FIX,IZ_FIX,ITPNMX,EKEPAI,LDTWCE)
C
C=======================================================================
C        CALCULATING THE NEUTRON LIPKIN-NOGAMI CORRECTION
C=======================================================================
C        WHEN STARTING FROM SCRATCH, THE CODE INITALIZES THE PH AND PP
C        CHANNELS  AT  NUMITE = 0. WHEN  RESTARTING FROM  HFBTHO, THIS
C        INITIALIZATION  MUST BE  SKIPPED,  WHICH IS  DONE BY  SETTING
C        NUMITE = 1. HOWEVER, TO  ENSURE  A  SMOOTH  RESTART OF THE LN
C        LAMBDA_2 PARAMETER,  ONE MUST DO 'AS IF' WE WERE AT THE FIRST
C        ITERATION, HENCE THE TRICK BELOW.
C=======================================================================
C
                           NACTIT=NUMITE
          IF (IF_THO.GE.1) NACTIT=NUMITE-2
C
          IF (LIPKIN.EQ.1) THEN
              EF2NIN=EFER2N
              CALL LIPCOR(GPAIRN,FACTGN,FE2FIN,IF2FIN,I_SLOW,SLOWLI,
     *                                         EFER2N,NACTIT,ICHARG)
              EF2NOU=EFER2N
C
              ELIP_N=-2*EFER2N*DISLIN
C
          END IF
C
C=======================================================================
C        CALCULATING THE NEUTRON PAIRING MATRIX ELEMENTS
C=======================================================================
C
          IF (IDEVAR.EQ.1)
     *
     *        CALL GINTER(ICHARG,MREVER,PRHO_N,PRHODN,POWERN)
C
C=======================================================================
C        PRINTING THE PAIRING RESULTS
C=======================================================================
C
          IF (PRINIT.AND.MPAHFB.GE.1)
     *
     *        CALL PAIPRI(NAMEPN,GPAIRN,EPAI_N,EFERMN,DELTAN,
     *                                  LIPKIN,EFER2N,ELIP_N,
     *                                  MPAHFB,MPABCS,IAVRGG,
     *                           IGOGPA,IREGPA,ISEPPA,ICOUPA)
C
      END IF
C
C@@@ HFBTHO -HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C        CALCULATING THE   N E U T R O N   D E N S I T Y   M A T R I X
C=======================================================================
C        TWO-CENTRE BASIS OPTION:    THREE DIFFERENT BLOCKS ARE COMPUTED
C        IN THE SAME WAY AS THE HAMILTONIAN.   TO OBTAIN THE BIG DENSITY
C        MATRIX (SEE COMMENTS BEFORE INTEGH) TWC_BIGDEN IS USED.
C        ATTENTION: WALEFT IS REFERRED TO THE KET AND WARIGH TO THE BRA.
C=======================================================================

      IF (ITWCEN.EQ.1) THEN
C
          CALL DENMAC(MREVER,ICHARG,ISIMPY,MPAHFB,WARIGH,WARIGH,1)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          DO LTWCEN=1,NDTWBL
C
             WARIGH(:,:,:)=SARIGH(:,:,:,ICHARG,IND2HL(LTWCEN))
             WALEFT(:,:,:)=SARIGH(:,:,:,ICHARG,IND2HR(LTWCEN))
C
             CALL DENMAC(MREVER,ICHARG,ISIMPY,MPAHFB,WALEFT,WARIGH,
     *                                                      LTWCEN)
C
             CALL TWCCOP(ICHARG,LTWCEN)
C
          END DO
C
          CALL TWC_BIGDEN(ICHARG)
C
      END IF
C
      IF (ITWCEN.EQ.2.AND.IQPSTA.EQ.0.AND.MPAHFB.EQ.1)
     *  CALL TWC_CANQUZ(ESUM_N)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   P A I R I N G   T E N S O R
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.((COR_CM.OR.CORROT).OR.
     *    ICOUPA.GE.1.OR.MAXVAL(IFSTPA).GE.1.OR.
     *    IFRAGM.EQ.1.OR.
C    *    KETAJ2.EQ.1.OR.KETAT2.EQ.1.OR.
     *    IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1))
     *
     *    CALL PAIMAC(ICHARG,ISIMPY,WARIGH,WARIGH,IKERNE)
C
C=======================================================================
C        ADDING THE NEUTRON DENSITY MATRIX TO THE BROYDEN VECTOR
C=======================================================================
C@@@ HFBTHO -HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
                       NACTIT=NUMITE
      IF (IF_THO.GE.1) NACTIT=NUMITE-2
C@@@ HFBTHO -HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C
      IF (LIPKIN.EQ.1.AND.IBROYD.GE.1.AND.MIXMAT.EQ.0)
     *    CALL LIP_IN(ISIMPY,ICHARG,LIPKIN,LIPKIP,EF2NIN,EF2NOU,
     *                                                   NACTIT)
C
C=======================================================================
C        SLOWING DOWN AND SAVING THE NEUTRON DENSITY MATRIX FOR
C        LIPKIN-NOGAMI
C=======================================================================
C            ATTENTION: BETWEEN  VERSIONS  (2.38G)  AND   (2.78B),   THE
C                       LIPKIN-NOGAMI CALCULATIONS WERE  PERFORMED  WITH
C                       DENSITY  MATRIX  SLOWED  DOWN   WITH   PARAMETER
C                       "SLOWLI". THIS FACT  CONTRADICTED  THE  INTENDED
C                       USE OF "SLOWLI", AS SPECIFIED IN SECTION 3.3  OF
C                       CPC 180-2361, WHERE IT WAS MEANT  TO  SLOW  DOWN
C                       THE LIPKIN-NOGAMI PARAMETERS ONLY. THIS BUG  WAS
C                       CORRECTED ON 12/10/2016 IN VERSIONS (2.73Y)  AND
C                       (2.78C) BY ADDING A DEDICATED PARAMETER "SLOWLD"
C                       WHICH IS USED TO SLOW DOWN  THE  DENSITY  MATRIX
C                       FOR USE IN THE LIPKIN-NOGAMI METHOD.
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.97J) AND (3.07B), THE CONDITION
C                    TO CALL  "SAVLIP"  DID  NOT  INCLUDE  THE  TEST  OF
C                    "MPAHFB".  AS  A  RESULT,  AFTER  IMPLEMENTING  THE
C                    DYNAMIC DOWNGRADE OF HFB TO HF, "SAVLIP"  COULD  BE
C                    CALLED IN AN HF RUN, WHICH WAS CAUSING THE CODE  TO
C                    CRASH  ON  THE  SEGMENTATION  FAULT. THIS  BUG  WAS
C                    CORRECTED ON 25/09/2021 IN VERSIONS (3.07C).
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.LIPKIN.EQ.1) THEN
                           MIXDEN=0
          IF (IBROYD.LT.1) MIXDEN=1
C
          CALL SAVLIP(ISIMPY,ICHARG,SLOWLD,MIXDEN)
C
      END IF
C
C=======================================================================
C        SLOWING DOWN THE NEUTRON DENSITY MATRIX  AND  PAIRING
C        TENSOR FOR THE LIPKIN METHOD
C        ATTENTION: IF THE LIPKIN METHOD IS USED TOGETHER WITH
C                   FINITE-RANGE FORCES, COULOMB, OR  TWO-BODY
C                   CENTER-OF-MASS CORRECTION, CALLS TO SAVDEN
C                   AND SAVPAI, WHICH ARE EXECUTED LATER, WILL
C                   O V E R W R I T E  THE SLOWED-DOWN DENSITY
C                   MARIX AND PAIRING TENSOR THAT ARE  WRITTEN
C                   BY SAVLPM BELOW.
C=======================================================================
C
      IF (IRENMA.GE.1.OR.IRENIN.GE.1) THEN
C
                           MIXDEN=0
          IF (NACTIT.GT.0) MIXDEN=1
C
          CALL SAVLPM(ICHARG,ISIMPY,MPAIRI,SLOWLM,MIXDEN)
C
      END IF
C
C=======================================================================
C        SAVING THE NEUTRON DENSITY MATRIX
C=======================================================================
C
      IF (I_YUKA.GE.1.OR.I_GOGA.GE.1.OR.I_REGA.GE.1.OR.I_SEPA.GE.1.OR.
     *    I_COUA.GE.1.OR.MAXVAL(I_FSTA).GE.1.OR.MAXVAL(MAG2BC).GE.1.OR.
     *    ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.
     *    COR_CM.OR.CORROT.OR.IFRAGM.EQ.1.OR.
     *    JETACM.GE.1.OR.KETA_R.GE.1)
     *
     *    CALL SAVDEN(ISIMPY,ICHARG)
C
C=======================================================================
C        SAVING THE NEUTRON PAIRING TENSOR
C=======================================================================
C
      IF (IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1.OR.
     *    ICOUPA.GE.1.OR.MAXVAL(IFSTPA).GE.1.OR.
     *  ((COR_CM.OR.CORROT).AND.MPAHFB.GE.1))
     *
     *    CALL SAVPAI(ISIMPY,ICHARG)
C
C=======================================================================
C         CALCULATING   D I R E C T   YUKAWA ENERGIES FOR NEUTRONS
C=======================================================================
C
      IF (PRIYUK)
     *
     *    CALL YUKAWD(ISIMPY,ICHARG)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    K I N E T I C    E N E R G Y
C=======================================================================
C
      CALL EKINET(EKIN_N,DLINSN(0),EKEKIN,DKINSN(0),ITWCEN)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    POTENTIAL   HO   E N E R G Y
C=======================================================================
C
      EPOT_N =0.0D0
C
      IF (IPOTHO.EQ.1) THEN
        CALL EPOTHO(EPOT_N)
      END IF
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    M U L T I P O L E    MOMENTS
C=======================================================================
C
      ISHIFY=0
C
      CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,QMUL_N,QMUT_N,
     *                   COMULT,KMULMO,ISHIFY,ITWCEN)
      CALL MOMSIF(ISIMPY,ISIGNY,ISIQTY,SMUL_N,SMUT_N,
     *                                 COMULT,KMULSI)
      IF (ISCHIF.EQ.1)
     *CALL MOMSCH(SMUL_N,SMUT_N,KMULSI,QMUL_N,QMUT_N,KMULMO)
      CALL MOMVMU(ISIMPY,VMUL_N,COMULT,KMULSI)
      IF (IDOPLM.EQ.1)
     *CALL MOMPLM(ISIMPY,ISIGNY,ISIQTY,PMUL_N,COMULT,KMULSI)
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          CALL MOMPRI(ISIMPY,NAMMUL,NAMHAR,NAMEPN,QMUL_N,KMULMO,'Q')
          IF (KMULSI.GT.0)
     *    CALL MOMPRI(ISIMPY,NAMSIF,NAMHAR,NAMEPN,SMUL_N,KMULSI,'S')
          IF (KMULSI.GT.0.AND.IDOPLM.EQ.1)
     *    CALL MOMPRI(ISIMPY,NAMPLM,NAMHAR,NAMEPN,PMUL_N,KMULSI,'P')
C
      END IF
C
C=======================================================================
C         IN THE CASE OF SINGLE-PARTICLE BLOCKING, THE BLOCKED STATE CAN
C         BE EITHER A PARTICLE OR A HOLE. THEREFORE, HERE WE TEST IF THE
C         REQUESTED AND OBTAINED PARTICLE NUMBERS AGREE.
C=======================================================================
C
      IF (MAXVAL(IDSIQN).EQ.2.OR.MAXVAL(IDSIZN).EQ.2) THEN
C
          IF (ABS(QMUL_N(0,0)-IN_FIX).GT.1.0D-06) THEN
C
              WRITE(NFIPRI,'(/,1X,20(1H/),
     *             '' INCONSISTENT NUMBERS OF NEUTRONS'',1X,20(1H/),/,
     *                         1X,20(1H/),
     *             '' Q00='',D17.10,'' IN_FIX='',I3,     1X,20(1H/),/)')
     *
     *             QMUL_N(0,0),IN_FIX
C
              STOP ' INCONSISTENT NUMBERS OF NEUTRONS IN MAIN'
C
          END IF
C
      END IF
C
C=======================================================================
C        CALCULATING THE    N E U T R O N     M A G N E T I C    MOMENTS
C=======================================================================
C
      CALL MAGMOM(ISIMPY,IROTAT,ICHARG,AMUL_N,AMUT_N,KMULMA,NMAORD)
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          CALL MAGPRI(IROTAT,NAMMAG,NAMHAR,NAMEPN,AMUL_N,KMULMA,NMAORD,
     *                                                             'M')
C
      END IF
C
C=======================================================================
C        CALCULATING THE    N E U T R O N    S P I N - ASYMMETRY MOMENTS
C=======================================================================
C
      CALL ASMMOM(ISIMPY,IROTAT,WMUL_N,WMUT_N,KMULAS,NASORD)
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          CALL MAGPRI(IROTAT,NAMASM,NAMHAR,NAMEPN,WMUL_N,KMULAS,NASORD,
     *                                                             'A')
C
      END IF
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    R M S    R A D I I
C=======================================================================
C
      CALL RMSQUA(RADI_N,RMSRAN,IN_FIX,NRAORD,ITWCEN)
C
      IF (PRINIT.AND.IPRI_N.EQ.1)
     *
     *    CALL RADPRI(NAMEPN,RADI_N,RMSRAN,NRAORD)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    D E F O R M A T I O N S
C=======================================================================
C
      IF (PRIBET.AND.IPRI_N.EQ.1)
     *
     *    CALL BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMHAR,NAMEPN,
     *                              RADI_N,QMUL_N,BMUL_N,KMULMO)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   S P I N
C=======================================================================
C
      CALL SPIMOM(ISIMPY,IROTAT,ANGU_N,SPIN_N,ITWCEN)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   L I N E A R   M O M E N T A
C=======================================================================
C         ATTENTION! BETWEEN VERSIONS (2.78H) AND (3.22S), BUT  ALSO  IN
C                    THE PUBLISHED VERSION (2.73Y), SUBROUTINE ZDOTU  IN
C                    MODULES  "HFODD_LIPCORR_NN.F90"  WAS  CALLED   WITH
C                    INCORRECT ARGUMENTS AND THUS  COULD  WORK  PROPERLY
C                    ONLY FOR LDBASE=NDBASE. THIS  BUG  WAS  ERRATICALLY
C                    CAUSING SEGMENTATION FAULT FOR CALCULATIONS DONE IN
C                    SUBROUTINES  "LINAVR"  AND  "ROTAVR"  BELOW.  AFTER
C                    REMOVING ALL CALLS TO ZDOTU, THIS BUG WAS CORRECTED
C                    ON  06/02/2024  IN  VERSION  (3.22T),  WHICH   USES
C                    MODULE HFODD_LIPCORR_53.F90.
C=======================================================================
      IF (COR_CM)
     *
     *    CALL LINAVR(ISIMPY,ISIGNY,ISIQTY,
     *                MPAHFB,ICHARG,JETACM,IROTAT,MREVER,COR_CM,IKERNE,
     *                DLINSN,ELINSN,PLINSN,TLINSN,ALINLN,PLINLN,PLINKN,
     *                DKINSN,EKINSN,PKINSN,TKINSN,AKINLN,PKINLN,PKINKN)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   A N G U L A R   M O M E N T A
C=======================================================================
C
C     IF (CORROT.OR.KETAJ2.EQ.1)
      IF (CORROT)
     *
     *    CALL ROTAVR(ISIMPY,ISIGNY,ISIQTY,
     *                MPAHFB,ICHARG,KETA_R,IROTAT,MREVER,CORROT,IKERNE,
     *                DROTSN,EROTSN,PROTSN,TROTSN,AROTLN,PROTLN,PROTKN,
     *                DKOTSN,EKOTSN,PKOTSN,TKOTSN,AKOTLN,PKOTLN,PKOTKN)
C
C=======================================================================
C        CALCULATING PROPERTIES OF THE FRAGMENTS (TWO-CENTER BASIS)
C=======================================================================
C
      ENEFRN=0.0D0
      IF (ITWCEN.EQ.2) THEN
C
              CALL TWC_FRGENE(ICHARG,ITWCEN,ENEFRN)
              CALL TWC_FRGMOM(KMULMO,QFRA_N)
C
      END IF
C
C=======================================================================
C         CALCULATIONS FOR  MOMENTS OF INERTIA
C         AND MASS PARAMETERS (NEUTRON PART)
C=======================================================================
C
      if (TERMNT) then
C
          if (imominer.eq.1) then
                  call momsiner(icharg,ipahfb,jpabcs)
          endif
          if (imaspar.eq.1) then
                call maspar_v0(ipahfb,jpabcs,icharg,mrever)
          endif
C
      endif  ! TERMNT
C
C=======================================================================
C         HERE ENDS THE BLOCK FOR   N E U T R O N S
C=======================================================================
C
 8970 CONTINUE
C
C=======================================================================
C         FOR IZ_FIX=0 WE DO NOT PERFORM ANY CALCULATIONS FOR PROTONS
C=======================================================================
C
      IF (IZ_FIX.EQ.0) GO TO 8971
C
C=======================================================================
C         HERE STARTS THE BLOCK FOR  P R O T O N S
C=======================================================================
C
      NAMEPN=' PROTONS'
C
      ICHARG=1
      ITPNMX=1
C
C=======================================================================
C         SETTING THE SWITCHES THAT DOWNGRADE HFB TO HF IF NEEDED
C=======================================================================
C
      IF (IPA2HF(ICHARG).EQ.1.OR.
     *    IPA2HF(ICHARG).EQ.2.AND.ABS(DELTAP).LT.DEL2HF(ICHARG)) THEN
C
          IF (IPA2HF(ICHARG).EQ.2.AND.ABS(DELTAP).LT.DEL2HF(ICHARG).AND.
     *        IND2HF(ICHARG).NE.1) THEN
C
              WRITE(NFIPRI,'(                                 79(1H*),/,
     *              1H*,7X,'' FROM NOW ON, THE HFB MODE FOR  PROTONS'',
     *                     '' IS SWITCHED OVER TO HF '',      7X,1H* ,/,
     *                                                        79(1H*))')
              IND2HF(ICHARG)=1
C
          END IF
C
          MPAHFB=0
          MPABCS=0
          MPAIRI=0
      ELSE
          MPAHFB=IPAHFB
          MPABCS=JPABCS
          MPAIRI=IPAIRI
C
      END IF
C
      KPAHFB(ICHARG)=MPAHFB
C
C=======================================================================
C         CALCULATING THE MATRIX ELEMENTS OF THE PROTON MEAN FIELD
C=======================================================================
C         TWO-CENTRE BASIS OPTION: SEE COMMENTS IN NEUTRON BLOCK
C=======================================================================
C
      IF (NUMITE.GT.0) THEN
C
          IF (NUMITE.GT.ITESTA.OR.(IFCONT.NE.1.AND.IF_THO.EQ.0)) THEN
C
              DO LTWCEN=1,NBLDEN
C
                 INNERI=IND2HL(LTWCEN)
                 INNERJ=IND2HR(LTWCEN)
C
                 DO INNERK=1,ITWCEN
                    DO INNERL=1,ITWCEN
C
                       INDCOE=INTWHE(INNERI,INNERJ,INNERK,INNERL)

                       CALL INTEGH(IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                      IPNMIX,ITPNMX,IROTAT,ICHARG,ISIMPY,
     *                             MPAHFB,IPOTHO,ISCHIF,IOCONT,
     *                                           NMUCON,NSICON,
     *                             I_YUKA,I_GOGA,I_REGA,I_SEPA,
     *                                    ITWOLI,JETACM,ALINLT,
     *                                           KETA_R,AROTLT,
     *                                           ICOUDI,ICOUEX,
     *                                           LIPKIN,LIPKIP,
     *                                           EFER2N,EFER2P,
     *                                                  IF_RPA,
     *                                           ILIPON,ILIPOP,
     *                                                  NEWGOG,
     *                                           LTWCEN,ITWCEN,
     *                                                  INDCOE)
C
                    END DO
                 END DO
C
                 IF (NUMITE.GT.ITESTA.OR.
     *              (IFCONT.EQ.1.OR.IF_THO.EQ.1)) THEN
C
                     IF (I_SLOW.EQ.1)
     *               CALL MIXFIL(ISIMPY,ICHARG,SLOWAL,ITWCEN,LTWCEN)
C
                 END IF
C
                 IF (ITWCEN.EQ.2) THEN
C
                     CALL TWCCOP(ICHARG,LTWCEN)
                     CALL TWC_SAVFIL(0,ICHARG,LTWCEN)
C
                 END IF
C
              END DO
C
          ELSE
C
              DO LTWCEN=1,NBLDEN
C
                 CALL GETFIL(ISIMPY,ICHARG,LTWCEN,ITWCEN)
                 IF (ITWCEN.EQ.2) CALL TWCCOP(ICHARG,LTWCEN)
C
              END DO
C
          END IF
C
          SPMODL='HARTREE-FOCK  '
C
C=======================================================================
C        CALCULATING THE MATRIX ELEMENTS OF THE PROTON PAIRING FIELD
C=======================================================================
C
          IF (MPAHFB.GE.1) THEN
C
              IF (NUMITE.GT.ITESTA.OR.(IFCONT.NE.1.AND.IF_THO.EQ.0))
     *        THEN
C
                  DO LTWCEN=1,NBLDEN
C
                     INNERI=IND2HL(LTWCEN)
                     INNERJ=IND2HR(LTWCEN)
C
C=======================================================================
C        TWO-CENTRE BASIS OPTION: SEE COMMENT IN NEUTRON BLOCK.
C=======================================================================
C
                                                      ITWCE2=     1
                     IF (IDEFIN.EQ.0.AND.ITWCEN.EQ.2) ITWCE2=ITWCEN
C
                     DO INNERK=1,ITWCE2
                        DO INNERL=1,ITWCE2
C
                           INDCOE=INTWHE(INNERI,INNERJ,INNERK,INNERL)
C
                           CALL INTEGD(ITPNMX,ISIMPY,ICHARG,
     *                           DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                                         JETACM,KETA_R,
     *                           IGOGPA,IREGPA,ISEPPA,ICOUPA,
     *                                         NEWGOG,NEWCOU,
     *                                  LTWCEN,ITWCEN,INDCOE)
C
                        END DO
                     END DO
C
                     IF (NUMITE.GT.ITESTA.OR.
     *                  (IFCONT.EQ.1.OR.IF_THO.EQ.1)) THEN
                         IF (I_SLOW.EQ.1) CALL MIXPAI(ICHARG,REA2PP,
     *                                         SLOWAL,ITWCEN,LTWCEN)
C
                     END IF
C
                     IF (ITWCEN.EQ.2) THEN
C
                         CALL TWDECO(ICHARG,LTWCEN)
                         CALL TWC_SAVFIL(1,ICHARG,LTWCEN)
C
                     END IF
C
                  END DO
C
              ELSE
C
                  DO LTWCEN=1,NBLDEN
C
                     CALL GETPAI(ICHARG,REA2PP,LTWCEN,ITWCEN)
                     IF (ITWCEN.EQ.2) CALL TWDECO(ICHARG,LTWCEN)
C
                  END DO
C
              END IF
C
              IF (IMFHFB.EQ.1) THEN
C
                  SPMODL='HFB MEAN FIELD'
              ELSE
                  SPMODL='CANONICAL     '
C
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C        INITIALIZING THE MATRIX ELEMENTS OF THE PROTON MEAN FIELD
C=======================================================================
C
          IF (IREAWS.EQ.1) THEN
C
              CALL WSHAMI(ITILAX,ITISAX,NO_ORB,ICHARG,ISIMPY)
C
              SPMODL='WOODS-SAXON   '
C
          ELSE
C
              DO LTWCEN=1,ITWCEN
C
                 CALL NILSON(ITILAX,ITISAX,NO_ORB,INNUMB,IZNUMB,
     *                              ICHARG,NAMEPN,HOMEGA,ISIMPY,
     *                                            ITWCEN,LTWCEN)
                 SPMODL='NILSSON       '
C
                 IF (ITWCEN.EQ.2) THEN
C
                     CALL TWCCOP(ICHARG,LTWCEN)
                     IF (I_SLOW.EQ.1) CALL TWC_SAVFIL(0,ICHARG,LTWCEN)
C
                  END IF
C
              END DO
C
          END IF
C
C=======================================================================
C        INITIALIZING THE MATRIX ELEMENTS OF THE PROTON PAIRING FIELD
C=======================================================================
C
          IF (MPAHFB.GE.1) THEN
C
              CALL INIPAI(ITPNMX,IPNMIX,ITWCEN,LDTWCE)
C
              IF (JETACM.EQ.2) CALL ZERLIN(ISIMPY,MPAIRI)
              IF (KETA_R.EQ.2) CALL ZERROT(ISIMPY,MPAIRI)
C
              DO LTWCEN=1,ITWCEN
C
                 INNERI=IND2HL(LTWCEN)
                 INNERJ=IND2HR(LTWCEN)
C
                                                  ITWCE2=     1
                 IF (IDEFIN.EQ.0.AND.ITWCEN.EQ.2) ITWCE2=ITWCEN
C
                 DO INNERK=1,ITWCE2
                    DO INNERL=1,ITWCE2

C
                       INDCOE=INTWHE(INNERI,INNERJ,INNERK,INNERL)
C
                       CALL INTEGD(ITPNMX,ISIMPY,ICHARG,
     *                      DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                                    JETACM,KETA_R,
     *                      IGOGPA,IREGPA,ISEPPA,ICOUPA,
     *                                    NEWGOG,NEWCOU,
     *                             LTWCEN,ITWCEN,INDCOE)
C
                    END DO
                 END DO
C
                 IF (ITWCEN.EQ.2) THEN
C
                     CALL TWDECO(ICHARG,LTWCEN)
                     IF (I_SLOW.EQ.1) CALL TWC_SAVFIL(1,ICHARG,LTWCEN)
C
                 END IF
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C        MIXING OF THE MATRIX ELEMENTS OF THE HFB MATRIX. USUAL LINEAR
C        MIXING IS HANDLED BY THE ROUTINE DOBROY_MATRIX(), THE BROYDEN
C        CORRECTION BEING SIMPLY NOT ADDED
C=======================================================================
C
      IF (MIXMAT.EQ.1) THEN
C
          IF (ITERUN.GT.1) THEN
C
              CALL HPH_IN(ISIMPY,MREVER,ICHARG)
              IF (MPAHFB.GE.1) CALL DEL_IN(MREVER,IROTAT,ICHARG)
C
C              Evolving the Broyden and affecting the ouput
C
              CALL DOBROY_MATRIX(ITERUN,NSWBRP,ITAK_P,
     *                           NOICAN,SLOWEV,ESTABN,
     *                           EFERMP,EFEPIN,EFEPOU,
     *                           EFER2P,EF2PIN,EF2POU,
     *                           LIPKIP,NOFBRP,ICHARG,
     *                                         MPAHFB)
C
              CALL HPH_OU(ISIMPY,MREVER,ICHARG)
              CALL GETFIL(ISIMPY,ICHARG,1,1)
C
              IF (MPAHFB.GE.1) THEN
                  CALL DEL_OU(MREVER,IROTAT,ICHARG)
                  CALL GETPAI(ICHARG,REA2PP,1,1)
              END IF
C
          ELSE
              CALL SAVFIL(ISIMPY,MPAHFB,ICHARG,REA2PP)
          END IF
C
      END IF
C
C=======================================================================
C        SAVING  THE   P R O T O N   MEAN FIELDS
C=======================================================================
C
      IF ((IWRIFI.NE.-1.OR.I_SLOW.EQ.1).AND.MIXMAT.EQ.0.AND.ITWCEN.EQ.1)
     *    CALL SAVFIL(ISIMPY,MPAHFB,ICHARG,REA2PP)
C
C=======================================================================
C        DIAGONALIZING THE MATRIX OF THE  PROTON   H F B   HAMILTONIAN
C=======================================================================
C
      IF (MPAHFB.GE.1) THEN
C
          IREMQB(:)=0
          INUMQB(:)=0
          JNUMQB(:)=0
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL HFBSIG(EFERMP,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALP,IFERAP,PARNUP,IZ_FIX,
     *                                             ITWOBA,IWRIQU,
     *                               INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                                             IFIBLP,ISABLP,
     *                               IREQPB,INUQPB,JNUQPB,IF_RPA)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              ELSE
C
                  IF (IFERAP.EQ.1) STOP ' ALM METHD NOT IMPLEMENTED YET'
C
                  CALL HFBSIM(EFERMP,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALP,IFERAP,PARNUP,IZ_FIX,
     *                                             ITWOBA,IWRIQU,
     *                                      INSIMP,IRSIMP,IDSIMP,
     *                                             IFIBLP,ISABLP,
     *                               IREQPB,INUQPB,JNUQPB,IF_RPA)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  IF (IFERAP.EQ.1) STOP ' ALM METHD NOT IMPLEMENTED YET'
C
                  CALL HFBSIQ(EFERMP,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALP,IFERAP,PARNUP,IZ_FIX,
     *                                             ITWOBA,NUQEVE,
     *                                      INSIQP,IPSIQP,IDSIQP,
     *                                             IFIBLP,ISABLP,
     *                                      IREQPB,INUQPB,JNUQPB)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              ELSE
C
                  IF (IFERAP.EQ.1) STOP ' ALM METHD NOT IMPLEMENTED YET'
C
                  IF (ITWCEN.EQ.1) THEN
C
                  CALL HFBSIZ(EFERMP,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALP,IFERAP,PARNUP,IZ_FIX,
     *                                             ITWOBA,NUQEVE,
     *                                             INSIZP,IDSIZP,
     *                                             IFIBLP,ISABLP,
     *                               IREMQB,INUMQB,JNUMQB,ISAOCC)
C
                  ELSEIF (ITWCEN.EQ.2) THEN
C
                      CALL TWCSIZ_NATBAS(ICHARG,LDMEFI,MPAHFB,EFERMP,
     *                                   ECUTOF,LAMCUT,INSIZP,IDSIZP,
     *                                   IFIBLP,ISABLP,IREMQB,INUMQB,
     *                                                        JNUMQB)
C
                  END IF
C
              END IF
C
          END IF
C
#if(USE_MPI==1)
          IF (escapeSignal.Eq.1) THEN
C
              WRITE(6,'(''Process '',i6,
     *                  '' - HFBSIM failed for protons. '',
     *                  ''Closing all files and exiting...'')')
     *                    WorldRank
C
              ! Properly close all files that could have been left
              ! opened (with the exclusion of the output unit NFIPRI)
              CALL IOCLOS(NFIWOO,NFIREP,NFIREV,NFIREC,NFICOU,NFIWAV,
     *                    NFIKER,NFIYUP,NFIYUC,NFIGOC,NFIGOP,NFIGPC,
     *                    NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *                    NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP)
C
              EXIT procLoop
C
          END IF
#endif
          EFEPIN=EFERMP
C
          CALL QUABCS(EFERMP,IZ_FIX,FERFIP,IFEFIP,ICHARG,
     *                       IDSIGP,IDSIMP,IDSIQP,IDSIZP,
     *                              IPRGCM,NUQEVE,ITWOBA,
     *                              FERALP,IFERAP,PARNUP,
     *                              IREMQB,INUMQB,JNUMQB,
     *                                     ISIMPY,ISIQTY)
C
#if(USE_MPI==1)
          IF (escapeSignal.Eq.1) THEN
C
              WRITE(6,'(''Process '',i6,
     *                  '' - QUABCS failed for protons. '',
     *                  ''Closing all files and exiting...'')')
     *                    WorldRank
C
              ! Properly close all files that could have been left
              ! opened (with the exclusion of the output unit NFIPRI)
              CALL IOCLOS(NFIWOO,NFIREP,NFIREV,NFIREC,NFICOU,NFIWAV,
     *                    NFIKER,NFIYUP,NFIYUC,NFIGOC,NFIGOP,NFIGPC,
     *                    NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *                    NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP)
C
              EXIT procLoop
C
          END IF
#endif
C
          EFEPOU=EFERMP
C
          IF (PRINIT) THEN
C
              IF (IQUNIL.GE.1) CALL NILAQP(NOSCIL,MREVER,ICHARG,
     *                                            ISIMPY,NILXYZ)
C
              CALL SPTQUA(EMAXQU,ICHARG,NAMEPN,NILXYZ,
     *                    IQUNIL,ISIGNY,ISIMPY,ISIQTY,
     *                    IDSIGP,IDSIMP,IDSIQP,IDSIZP,
     *                           IREMQB,INUMQB,JNUMQB)
C
          END IF
C
      END IF
C
C=======================================================================
C        DIAGONALIZING THE MATRIX OF THE   P R O T O N   MEAN FIELD
C=======================================================================
C
      DISLIP=0.0D0
C
      IF (MPAHFB.GE.1) THEN
C
          IF (ITWCEN.EQ.1) THEN
C
              IF (ISIMPY.EQ.1) THEN
C
                  CALL CANQUA(MREVER,ICHARG,IMFHFB,IREQPB,
     *                        LIPNOP,PARLIP,DISLIP,ESUM_P)
              ELSE
                  CALL CANQUZ(ICHARG,IMFHFB,LIPNOP,PARLIP,DISLIP,ESUM_P)
C
              END IF
C
          END IF
C
      ELSE
C
          LIMPAR=0
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL DIASIG(MREVER,ICHARG,LIMPAR,ECUTOF)
C
              ELSE
C
                  CALL DIASIM(MREVER,ICHARG,LIMPAR,ECUTOF)
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  CALL DIASIQ(ICHARG,LIMPAR,ECUTOF)
C
              ELSE
C
                  IF (ITWCEN.EQ.1) THEN
C
                      CALL DIASIZ(ICHARG,LIMPAR,ECUTOF,LDMEFI,ISAOCC)
C
                  ELSEIF(ITWCEN.EQ.2) THEN
C
                      CALL TWCSIZ_NATBAS(ICHARG,LDMEFI,MPAHFB,EFERMP,
     *                                   ECUTOF,LAMCUT,INSIZP,IDSIZP,
     *                                   IFIBLP,ISABLP,IREMQB,INUMQB,
     *                                                        JNUMQB)
C
                  END IF
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C        CALCULATING VARIOUS SINGLE-PARTICLE AVERAGES FOR PROTONS
C=======================================================================
C=======================================================================
C        SEE COMMENTS TO THE PREVIOUS CALL TO AVANGY
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          IF((ISIMPY.EQ.1.AND.IFLIPI.NE.0.AND.ICHFLI.EQ.ICHARG)     .OR.
     *
     *   (ISIMPY.EQ.1.AND.ISIGNY.EQ.1.AND.(NOFLIG(0,0,ICHARG).NE.0  .OR.
     *                                     NOFLIG(0,1,ICHARG).NE.0  .OR.
     *                                     NOFLIG(1,0,ICHARG).NE.0  .OR.
     *                                     NOFLIG(1,1,ICHARG).NE.0)).OR.
     *
     *   (ISIMPY.EQ.1.AND.ISIGNY.NE.1.AND.(NOFLIM(  0,ICHARG).NE.0  .OR.
     *                                     NOFLIM(  1,ICHARG).NE.0)).OR.
     *
     *   (ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.(NOFLIQ(  0,ICHARG).NE.0  .OR.
     *                                     NOFLIQ(  1,ICHARG).NE.0)).OR.
     *
     *   (ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.(NOFLIZ(    ICHARG).NE.0)).OR.
     *
     *    IS_CON.EQ.1                                               .OR.
     *
     *    IS_PIN.EQ.1                                               .OR.
     *
     *    IS_CHA.EQ.1                                               .OR.
     *
     *    TERMNT                                                    .OR.
     *
     *    PRINIT)                                                   THEN
C
          CALL AVOBSE(MREVER,ICHARG,IPNMIX,NRAORD)
C
          END IF
C
      END IF
C
      CALL AVANGY(MREVER,ICHARG,IPNMIX,ISIMPY,ITWCEN)
C
C=======================================================================
C        CALCULATING SINGLE-PARTICLE AVERAGES FOR PROTONS
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL AVPARI(MREVER,ICHARG,IPNMIX)
C
          IF (TERMNT.OR.PRINIT) THEN
C
              CALL AVSIMP(MREVER,ICHARG,IPNMIX)
C
              CALL NILASP(NOSCIL,MREVER,ICHARG,ISIMPY,NILXYZ)
C
          END IF
C
      END IF
C
C=======================================================================
C        CALCULATING THE PROTON  PAIRING AND DEFINING OCCUPATION FACTORS
C=======================================================================
C
      EPAI_P=0.0
      EREA_P=0.0
      ELIP_P=0.0
C
      IF (MPAIRI.EQ.1) THEN
C
          IF (MPABCS.GT.0) THEN
C
              IF (MPABCS.EQ.1.OR.
     *           (MPABCS.EQ.3.AND.ITERUN.EQ.1))  THEN
C
                  IF (IAVRGG.NE.1) THEN
C
                      CALL SETPAI(IN_FIX,IZ_FIX,FACTGP,ICHARG,GPAIRP)
C
                  ELSE
C
                      CALL GAVRAG(IN_FIX,IZ_FIX,FACTGP,ICHARG,GPAIRP)
C
                  END IF
C
              END IF
C
              EFEPIN=EFERMP
              CALL DELPAI (ICHARG,MREVER,MPABCS,IZ_FIX,ITERUN,
     *                     DELFIP,GPAIRP,EPAI_P,EFERMP,DELTAP)
              EFEPOU=EFERMP
C
              IF (PRINIT)
     *
     *            CALL PAIPRI(NAMEPN,GPAIRP,EPAI_P,EFERMP,DELTAP,
     *                                      LIPKIP,EFER2P,ELIP_P,
     *                                      MPAHFB,MPABCS,IAVRGG,
     *                               IGOGPA,IREGPA,ISEPPA,ICOUPA)
C
          END IF
C
      ELSE
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL CONSIG(MREVER,ICHARG,IZ_FIX,EFERMP,
     *                               ICHFLI,IPAFLI,IREFLI,
     *                               ISPFLI,ISHFLI,IFLIPI)
              ELSE
C
                  CALL CONSIM(MREVER,ICHARG,IZ_FIX,EFERMP,
     *                               ICHFLI,       IREFLI,
     *                               ISPFLI,ISHFLI,IFLIPI)
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  CALL CONSIQ(ICHARG,IZ_FIX,EFERMP,
     *                        ICHFLI,IPAFLI,
     *                        INSIQP,IPSIQP,IDSIQP,
     *                               IFIBLP,ISABLP,
     *                        ISPFLI,ISHFLI,IFLIPI,
     *                               NLSIQP,MXALIP)
              ELSE
C
                  CALL CONSIZ(ICHARG,IZ_FIX,EFERMP,
     *                        ICHFLI,INSIZP,IDSIZP,
     *                               IFIBLP,ISABLP,
     *                        ISPFLI,ISHFLI,IFLIPI,
     *                               NLSIZP,MXALIP,
     *                                      ISAOCC,
     *                                      ITWCEN)
C
              END IF
C
          END IF
C
          DELTAP=0.0D0
C
      END IF
C
C=======================================================================
C        PRINTING SINGLE-PARTICLE SPECTRA FOR PROTONS
C=======================================================================
C
      IF (PRINIT) THEN
C
          CALL SPTALL(EMINAL,EMAXAL,SPMODL,NAMEPN,
     *                ISIGNY,ISIMPY,ISIQTY,MPAHFB,
     *                       MREVER,ICHARG,NILXYZ,
     *                IDSIGP,IDSIMP,IDSIQP,IDSIZP,NRAORD
     *                                           ,ITWCEN)
C
      END IF
C
C=======================================================================
C        CALCULATING THE SUM OF  PROTON SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      IF (MPAHFB.LT.1)
     *
     *    CALL SPENSU(MREVER,ESUM_P,ICHARG,ISIMPY,ITWCEN)
C
C=======================================================================
C        CALCULATING THE SUM OF  PROTON QUASIPARTICLE ENERGIES
C=======================================================================
C
      IF (MPAHFB.GE.1.AND.IQPSTA.EQ.1)
     *
     *    CALL QPENSU(MREVER,ESUM_P,EFERMP,ICHARG)
C
C=======================================================================
C         ZEROING THE PROTON DENSITIES
C=======================================================================
C
      CALL ZEDENS(ITPNMX)
C
C=======================================================================
C        CALCULATING THE PROTON DENSITIES AND CURRENTS
C=======================================================================
C        TWO-CENTRE BASIS OPTION: SEE COMMENTS IN NEUTRON BLOCK
C=======================================================================
C
      IF (ITWCEN.EQ.2) THEN
C
          ISAWAV=1
          IKERNE=0
C
      END IF
C
      CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *            ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,ICHARG,
     *                                 MIN_QP,IPNMIX,ITPNMX,
     *                   ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *            ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                             ITWCEN,1)
C
      IF (ITWCEN.EQ.2) THEN
C
          CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *            ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,ICHARG,
     *                                 MIN_QP,IPNMIX,ITPNMX,
     *                   ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *            ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                        ITWCEN,NDTWHE)
C
          IKERNE=1
          ISAWAV=0
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(WALEFT)) THEN
          ALLOCATE (WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *                                                   STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WALEFT','HFODD ')
          END IF
C
          IF (ITWCEN.GT.NDTWCE) STOP ' ITWCEN.GT.NDTWCE IN HFODD'
C
          DO LTWCEN=1,LDTWDD
C
             IF (LTWCEN.EQ.1.OR.LTWCEN.EQ.16) CYCLE
C
             IF (IDCOPY(LTWCEN,IPAIRI).EQ.0) THEN
C
                 WALEFT(:,:,:)=SARIGH(:,:,:,ICHARG,IND4HK(LTWCEN))
                 WARIGH(:,:,:)=SARIGH(:,:,:,ICHARG,IND4HL(LTWCEN))
C
                 CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *            ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,ICHARG,
     *                                 MIN_QP,IPNMIX,ITPNMX,
     *                   ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *            ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                        ITWCEN,LTWCEN)
C
             ELSEIF (IDCOPY(LTWCEN,IPAIRI).NE.0) THEN
C
                 CALL TWC_MORDEN(LTWCEN,ITPNMX,IGRAIN,IPAIRI)
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C         DOUBLING SINGLE-PARTICLE RESULTS IN CASE OF NO ROTATION
C=======================================================================
C
      IF (MREVER.EQ.0) THEN
C
          CALL DBLING(ITPNMX)
C
          ESUM_P=2*ESUM_P
C
      END IF
C
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C        BY DEFAULT,  HFODD  INITIALIZES THE  MATRIX OF THE  MEAN-FIELD
C        BY  COMPUTING THE  MATRIX ELEMENTS  OF THE  NILSON  POTENTIAL.
C        IN  HFB  MODE IT  INITIALIZES  THE MATRIX OF THE PAIRING FIELD
C        BY COMPUTING THE MATRIX ELEMENTS OF THE  DELTA-PAIRING  INTER-
C        ACTION, WHICH DEPENDS ON THE ISO-SCALAR DENSITY, AND THEREFORE
C        ON BOTH PROTON AND NEUTRON DENSITIES ON THE GAUSS-HERMITE MESH.
C        WHEN RESTARTING FROM HFBTHO, THESE DENSITIES ARE NOT AVAILABLE:
C        THE COMPUTATION OF  ALL  PAIRING OBSERVABLES MUST THEREFORE BE
C        SHIFTED TO  AFTER  THE NEW ISOSCALAR DENSITY HAS BEEN COMPUTED.
C        THIS ONLY AFFECTS THE  FIRST ITERATION, SEE ALSO COMMENT ABOUT
C        NUMITE BELOW.
C=======================================================================
C
      IF (IF_THO.EQ.0.OR.ITERUN.NE.1) THEN
C
C=======================================================================
C        CALCULATING THE  PROTON HFB PAIRING ENERGY AND AVERAGE DELTA
C=======================================================================
C
          IF (MPAHFB.GE.1)
     *
     *        CALL EPAIRI(IN_FIX,IZ_FIX,ITPNMX,EKEPAI,LDTWCE)
C
C=======================================================================
C        CALCULATING THE PROTON LIPKIN-NOGAMI CORRECTION
C=======================================================================
C        WHEN STARTING FROM SCRATCH, THE CODE INITALIZES THE PH AND PP
C        CHANNELS  AT  NUMITE = 0. WHEN  RESTARTING FROM  HFBTHO, THIS
C        INITIALIZATION  MUST BE  SKIPPED,  WHICH IS  DONE BY  SETTING
C        NUMITE = 1. HOWEVER, TO  ENSURE  A  SMOOTH  RESTART OF THE LN
C        LAMBDA_2 PARAMETER,  ONE MUST DO 'AS IF' WE WERE AT THE FIRST
C        ITERATION, HENCE THE TRICK BELOW.
C=======================================================================
C
                           NACTIT=NUMITE
          IF (IF_THO.GE.1) NACTIT=NUMITE-2
C
          IF (LIPKIP.EQ.1) THEN
              EF2PIN=EFER2P
              CALL LIPCOR(GPAIRP,FACTGP,FE2FIP,IF2FIP,I_SLOW,SLOWLI,
     *                                         EFER2P,NACTIT,ICHARG)
              EF2POU=EFER2P
C
              ELIP_P=-2*EFER2P*DISLIP
C
          END IF
C
C=======================================================================
C        CALCULATING THE PROTON PAIRING MATRIX ELEMENTS
C=======================================================================
C
          IF (IDEVAR.EQ.1)
     *
     *        CALL GINTER(ICHARG,MREVER,PRHO_P,PRHODP,POWERP)
C
C=======================================================================
C        PRINTING THE PAIRING RESULTS
C=======================================================================
C
          IF (PRINIT.AND.MPAHFB.GE.1)
     *
     *        CALL PAIPRI(NAMEPN,GPAIRP,EPAI_P,EFERMP,DELTAP,
     *                                  LIPKIP,EFER2P,ELIP_P,
     *                                  MPAHFB,MPABCS,IAVRGG,
     *                           IGOGPA,IREGPA,ISEPPA,ICOUPA)
C
      END IF
C
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C        CALCULATING THE   P R O T O N   D E N S I T Y   M A T R I X
C=======================================================================
C        TWO-CENTRE BASIS OPTION: SEE COMMENTS IN NEUTRON BLOCK
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL DENMAC(MREVER,ICHARG,ISIMPY,MPAHFB,WARIGH,WARIGH,1)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          DO LTWCEN=1,NDTWBL
C
             WARIGH(:,:,:)=SARIGH(:,:,:,ICHARG,IND2HL(LTWCEN))
             WALEFT(:,:,:)=SARIGH(:,:,:,ICHARG,IND2HR(LTWCEN))
C
             CALL DENMAC(MREVER,ICHARG,ISIMPY,MPAHFB,WALEFT,WARIGH,
     *                                                      LTWCEN)
C
             CALL TWCCOP(ICHARG,LTWCEN)
C
          END DO
C
          CALL TWC_BIGDEN(ICHARG)
C
      END IF
C
      IF (ITWCEN.EQ.2.AND.IQPSTA.EQ.0.AND.MPAHFB.EQ.1)
     *  CALL TWC_CANQUZ(ESUM_P)
C
C=======================================================================
C        CALCULATING THE   P R O T O N   P A I R I N G   T E N S O R
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.((COR_CM.OR.CORROT).OR.
     *    ICOUPA.GE.1.OR.MAXVAL(IFSTPA).GE.1.OR.
     *    IFRAGM.EQ.1.OR.
C    *    KETAJ2.EQ.1.OR.KETAT2.EQ.1.OR.
     *    IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1))
     *
     *    CALL PAIMAC(ICHARG,ISIMPY,WARIGH,WARIGH,IKERNE)
C
C=======================================================================
C        ADDING THE PROTON DENSITY MATRIX TO THE BROYDEN VECTOR
C=======================================================================
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
                       NACTIT=NUMITE
      IF (IF_THO.GE.1) NACTIT=NUMITE-2
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C
      IF (LIPKIP.EQ.1.AND.IBROYD.GE.1.AND.MIXMAT.EQ.0)
     *    CALL LIP_IN(ISIMPY,ICHARG,LIPKIN,LIPKIP,EF2PIN,EF2POU,
     *                                                   NACTIT)
C
C=======================================================================
C        SLOWING DOWN AND SAVING THE PROTON DENSITY MATRIX FOR
C        LIPKIN-NOGAMI
C=======================================================================
C            ATTENTION: SEE THE COMMENTS FOR NEUTRONS AVOVE
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.LIPKIP.EQ.1) THEN
                           MIXDEN=0
          IF (IBROYD.LT.1) MIXDEN=1
C
          CALL SAVLIP(ISIMPY,ICHARG,SLOWLD,MIXDEN)
C
      END IF
C
C=======================================================================
C        SLOWING DOWN THE PROTON DENSITY MATRIX AND PAIRING TENSOR
C        FOR THE LIPKIN METHOD
C        ATTENTION: SEE THE COMMENT FOR NEUTRONS
C=======================================================================
C
      IF (IRENMA.GE.1.OR.IRENIN.GE.1) THEN
C
                           MIXDEN=0
          IF (NACTIT.GT.0) MIXDEN=1
C
          CALL SAVLPM(ICHARG,ISIMPY,MPAIRI,SLOWLM,MIXDEN)
C
      END IF
C
C=======================================================================
C        SAVING THE PROTON DENSITY MATRIX
C=======================================================================
C
      IF (I_YUKA.GE.1.OR.I_GOGA.GE.1.OR.I_REGA.GE.1.OR.I_SEPA.GE.1.OR.
     *    I_COUA.GE.1.OR.MAXVAL(I_FSTA).GE.1.OR.MAXVAL(MAG2BC).GE.1.OR.
     *    ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.
     *    COR_CM.OR.CORROT.OR.IFRAGM.EQ.1.OR.
     *    JETACM.GE.1.OR.KETA_R.GE.1)
     *
     *    CALL SAVDEN(ISIMPY,ICHARG)
C
C=======================================================================
C        SAVING THE PROTON PAIRING TENSOR
C=======================================================================
C
      IF (IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1.OR.
     *    ICOUPA.GE.1.OR.MAXVAL(IFSTPA).GE.1.OR.
     *  ((COR_CM.OR.CORROT).AND.MPAHFB.GE.1))
     *
     *    CALL SAVPAI(ISIMPY,ICHARG)
C
C=======================================================================
C         CALCULATING   D I R E C T   YUKAWA ENERGIES FOR PROTONS
C=======================================================================
C
      IF (PRIYUK)
     *
     *    CALL YUKAWD(ISIMPY,ICHARG)
C
C=======================================================================
C        CALCULATING THE   P R O T O N     K I N E T I C     E N E R G Y
C=======================================================================
C
      CALL EKINET(EKIN_P,DLINSP(0),EKEKIN,DKINSP(0),ITWCEN)

C=======================================================================
C        CALCULATING THE   P R O T O N      POTENTIAL   HO   E N E R G Y
C=======================================================================
C
      EPOT_P =0.0D0
C
      IF (IPOTHO.EQ.1) THEN
        CALL EPOTHO(EPOT_P)
      END IF
C
C=======================================================================
C        CALCULATING THE   P R O T O N     M U L T I P O L E     MOMENTS
C=======================================================================
C
      ISHIFY=0
C
      CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,QMUL_P,QMUT_P,
     *                   COMULT,KMULMO,ISHIFY,ITWCEN)
      CALL MOMSIF(ISIMPY,ISIGNY,ISIQTY,SMUL_P,SMUT_P,
     *                                 COMULT,KMULSI)
      IF (ISCHIF.EQ.1)
     *CALL MOMSCH(SMUL_P,SMUT_P,KMULSI,QMUL_P,QMUT_P,KMULMO)
      CALL MOMVMU(ISIMPY,VMUL_P,COMULT,KMULSI)
      IF (IDOPLM.EQ.1)
     *CALL MOMPLM(ISIMPY,ISIGNY,ISIQTY,PMUL_P,COMULT,KMULSI)
C
      IF (PRINIT.AND.IPRI_P.EQ.1) THEN
C
          CALL MOMPRI(ISIMPY,NAMMUL,NAMHAR,NAMEPN,QMUL_P,KMULMO,'Q')
          IF (KMULSI.GT.0)
     *    CALL MOMPRI(ISIMPY,NAMSIF,NAMHAR,NAMEPN,SMUL_P,KMULSI,'S')
          IF (KMULSI.GT.0.AND.IDOPLM.EQ.1)
     *    CALL MOMPRI(ISIMPY,NAMPLM,NAMHAR,NAMEPN,PMUL_P,KMULSI,'P')
C
      END IF
C
C=======================================================================
C         IN THE CASE OF SINGLE-PARTICLE BLOCKING, THE BLOCKED STATE CAN
C         BE EITHER A PARTICLE OR A HOLE. THEREFORE, HERE WE TEST IF THE
C         REQUESTED AND OBTAINED PARTICLE NUMBERS AGREE.
C=======================================================================
C
      IF (MAXVAL(IDSIQP).EQ.2.OR.MAXVAL(IDSIZP).EQ.2) THEN
C
          IF (ABS(QMUL_P(0,0)-IZ_FIX).GT.1.0D-06) THEN
C
              WRITE(NFIPRI,'(/,1X,20(1H/),
     *             '' INCONSISTENT NUMBERS OF  PROTONS'',1X,20(1H/),/,
     *                         1X,20(1H/),
     *             '' Q00='',D17.10,'' IZ_FIX='',I3,     1X,20(1H/),/)')
     *
     *             QMUL_P(0,0),IZ_FIX
C
              STOP ' INCONSISTENT NUMBERS OF PROTONS IN MAIN'
C
          END IF
C
      END IF
C
C=======================================================================
C
C      From now on, proton multipole moments have been computed and
C      are available for the Coulomb INTCOU() routine
      ISQPRO=1
C
C=======================================================================
C        CALCULATING THE   P R O T O N   M A G N E T I C   M O M E N T S
C=======================================================================
C
      CALL MAGMOM(ISIMPY,IROTAT,ICHARG,AMUL_P,AMUT_P,KMULMA,NMAORD)
C
      IF (PRINIT.AND.IPRI_P.EQ.1) THEN
C
          CALL MAGPRI(IROTAT,NAMMAG,NAMHAR,NAMEPN,AMUL_P,KMULMA,NMAORD,
     *                                                             'M')
C
      END IF
C
C=======================================================================
C        CALCULATING THE     P R O T O N     S P I N - ASYMMETRY MOMENTS
C=======================================================================
C
      CALL ASMMOM(ISIMPY,IROTAT,WMUL_P,WMUT_P,KMULAS,NASORD)
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          CALL MAGPRI(IROTAT,NAMASM,NAMHAR,NAMEPN,WMUL_P,KMULAS,NASORD,
     *                                                             'A')
C
      END IF
C
C=======================================================================
C         CALCULATING   P R O T O N    R M S    R A D I I
C=======================================================================
C
      CALL RMSQUA(RADI_P,RMSRAP,IZ_FIX,NRAORD,ITWCEN)
C
      IF (PRINIT.AND.IPRI_P.EQ.1)
     *
     *    CALL RADPRI(NAMEPN,RADI_P,RMSRAP,NRAORD)
C
C=======================================================================
C        CALCULATING THE   P R O T O N    D E F O R M A T I O N S
C=======================================================================
C
      IF (PRIBET.AND.IPRI_P.EQ.1)
     *
     *    CALL BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMHAR,NAMEPN,
     *                              RADI_P,QMUL_P,BMUL_P,KMULMO)
C
C=======================================================================
C         CALCULATING   P R O T O N   S P I N
C=======================================================================
C
      CALL SPIMOM(ISIMPY,IROTAT,ANGU_P,SPIN_P,ITWCEN)
C
C=======================================================================
C        CALCULATING THE   P R O T O N   L I N E A R   M O M E N T A
C=======================================================================
C
      IF (COR_CM)
     *
     *    CALL LINAVR(ISIMPY,ISIGNY,ISIQTY,
     *                MPAHFB,ICHARG,JETACM,IROTAT,MREVER,COR_CM,IKERNE,
     *                DLINSP,ELINSP,PLINSP,TLINSP,ALINLP,PLINLP,PLINKP,
     *                DKINSP,EKINSP,PKINSP,TKINSP,AKINLP,PKINLP,PKINKP)
C
C=======================================================================
C        CALCULATING THE   P R O T O N   A N G U L A R   M O M E N T A
C=======================================================================
C
C     IF (CORROT.OR.KETAJ2.EQ.1)
      IF (CORROT)
     *
     *    CALL ROTAVR(ISIMPY,ISIGNY,ISIQTY,
     *                MPAHFB,ICHARG,KETA_R,IROTAT,MREVER,CORROT,IKERNE,
     *                DROTSP,EROTSP,PROTSP,TROTSP,AROTLP,PROTLP,PROTKP,
     *                DKOTSP,EKOTSP,PKOTSP,TKOTSP,AKOTLP,PKOTLP,PKOTKP)
C
C=======================================================================
C        CALCULATING PROPERTIES OF THE FRAGMENTS (TWO-CENTER BASIS)
C=======================================================================
C
      ENEFRP=0.0D0
      IF (ITWCEN.EQ.2) THEN
C
              CALL TWC_FRGENE(ICHARG,ITWCEN,ENEFRP)
              CALL TWC_FRGMOM(KMULMO,QFRA_P)
C
      END IF
C
C=======================================================================
C          CALCULATING   T R U E   CHARGE DENSITY
C=======================================================================
C
      CALL TRUCHD
C
C=======================================================================
C          ZEROING THE COULOMB ENERGIES
C=======================================================================
C
      EKECOD=C_ZERO
      EKECOE=C_ZERO
      EKESCA=C_ZERO
      EKEVEC=C_ZERO
      EKPSCA=C_ZERO
      EKPVEC=C_ZERO
C
C=======================================================================
C          CALCULATING THE DIRECT COULOMB ENERGIES AND FIELDS BY THE
C          GREEN-FUNCTION METHOD
C=======================================================================
C
      IF (ICOUDI.EQ.1) THEN
C
          CALL COUMAT(NUMCOU,BOUCOU,ISIMPY,IKERNE)
C
          CALL COULOD(ISIMPY,EKECOD)
C
      END IF
C
C=======================================================================
C          CALCULATING SLATER EXCHANGE COULOMB ENERGY
C=======================================================================
C
      IF (ICOUEX.EQ.1) THEN
C
          CALL COULOE(EKECOE)
C
      END IF
C
C=======================================================================
C          CALCULATING THE DIRECT, EXCHANGE AND PAIRING COULOMB ENERGIES
C          AND FIELDS BY THE METHOD OF EXPANDING IN GAUSSIANS
C=======================================================================
C
      IF (ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.I_COUA.GE.1) THEN
C
          IF (NEWCOU.EQ.0) THEN
C
              CALL COUENE(ISIMPY,
     *                    ICOTYP,ICOUDI,ICOUEX,
     *                                  IDOTHC,
     *                    EKECOD,EKESCA,EKEVEC)
C
          ELSE
C
              CALL CO2ENE(ISIMPY,ICOTYP,ICOUDI,ICOUEX,ICOUPA,
     *                    EKECOD,EKESCA,EKEVEC,ITWCEN,LDTWCE)
C
          END IF
C
          IF (ICOUEX.EQ.2) EKECOE=EKESCA+EKEVEC
C
      END IF
C
      ECOULD=REAL(EKECOD)
      ECOULE=REAL(EKECOE)*COUSCA
      ECOULS=REAL(EKESCA)
      ECOULV=REAL(EKEVEC)
C
C=======================================================================
C         CALCULATIONS FOR  MOMENTS OF INERTIA
C         AND MASS PARAMETERS (PROTON PART)
C=======================================================================
C
      if (TERMNT) then
C
          if (imominer.eq.1) then
                  call momsiner(icharg,ipahfb,jpabcs)
          endif
C
          if (imaspar.eq.1) then
                call maspar_v0(ipahfb,jpabcs,icharg,mrever)
          endif
C
          if ((imominer.eq.1).and.(imaspar.eq.1)) then
                call datatobh(innumb,iznumb,r0parm,numite,estabc,if_rpa)
          endif
C
      endif  ! TERMNT
C
C=======================================================================
C         HERE ENDS THE BLOCK FOR  P R O T O N S
C=======================================================================
C
 8971 CONTINUE
C
C=======================================================================
C         HERE ENDS THE CALCULATION WITHOUT THE PROTON-NEUTRON MIXING
C=======================================================================
C
 8972 CONTINUE
C
C=======================================================================
C         HERE STARTS THE CALCULATION FOR THE NEUTRON-PROTON MIXING
C=======================================================================
C
      IF (IPNMIX.NE.1) GO TO 8973
C
      NAMEPN='NEUT-PRO'
C
C=======================================================================
C        SECURITY DEFINITION OF MPAHFB - THIS OPTION DOES NOT APPLY HERE
C=======================================================================
C
      MPAHFB=10
C
C=======================================================================
C        CALCULATING THE MATRIX ELEMENTS OF THE MEAN  FIELD.
C        IN THE FIRST ITERATION AND FOR IFCONT>0, THE MATRIX
C        ELEMENTS ARE SUPPOSED TO BE ALREADY IN MEMORY.
C=======================================================================
C
      IF (NUMITE.GT.0) THEN
C
          IF (NUMITE.GT.ITESTA.OR.(IFCONT.NE.1.AND.IF_THO.EQ.0)) THEN
C
              DO ITPNMX=0,2
C
                 ICHARG=ITPNMX
C
                 IF (ITWCEN.GT.1)
     *               STOP ' INTEGH NOT READY FOR IPNMIX=1 IN HFODD'
C
                 CALL INTEGH(IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                IPNMIX,ITPNMX,IROTAT,ICHARG,ISIMPY,
     *                       MPAHFB,IPOTHO,ISCHIF,IOCONT,
     *                                     NMUCON,NSICON,
     *                       I_YUKA,I_GOGA,I_REGA,I_SEPA,
     *                              ITWOLI,JETACM,ALINLT,
     *                                     KETA_R,AROTLT,
     *                                     ICOUDI,ICOUEX,
     *                                     LIPKIN,LIPKIP,
     *                                     EFER2N,EFER2P,
     *                                            IF_RPA,
     *                                     ILIPON,ILIPOP,
     *                                            NEWGOG,
     *                                               1,1,
     *                                                 1)
C
                 IF (NUMITE.GT.ITESTA.OR.(IFCONT.EQ.1.OR.IF_THO.EQ.1))
     *                                                              THEN
C
                     IF (I_SLOW.EQ.1)
     *               CALL MIXFIL(ISIMPY,ICHARG,SLOWAL,1,1)
C
                 END IF
C
                 CALL PNMCOP(IPNMIX,ITPNMX,ISIMPY)
C
              END DO
C
          END IF
C
          SPMODL='HARTREE-FOCK  '
C
C=======================================================================
C        CALCULATING THE MATRIX ELEMENTS OF THE PAIRING FIELD
C=======================================================================
C
          IF (IPAHFB.GE.1) THEN
C
              STOP 'NOT READY YET 1'
C
              CALL INTEGD(ITPNMX,ISIMPY,ICHARG,
     *                    DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                                  JETACM,KETA_R,
     *                    IGOGPA,IREGPA,ISEPPA,ICOUPA,
     *                                  NEWGOG,NEWCOU,
     *                                          1,1,1)
C
              IF (NUMITE.GT.ITESTA.OR.(IFCONT.EQ.1.OR.IF_THO.EQ.1)) THEN
C
                  IF (I_SLOW.EQ.1) CALL MIXPAI(ICHARG,REA2PP,SLOWAL,1,1)
C
              END IF
C
              IF (IMFHFB.EQ.1) THEN
C
                  SPMODL='HFB MEAN FIELD'
              ELSE
                  SPMODL='CANONICAL     '
C
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C        INITIALIZING THE MATRIX ELEMENTS OF THE MEAN FIELD
C=======================================================================
C
          DO ITPNMX=0,1
C
             ICHARG=ITPNMX
C
             IF (IREAWS.EQ.1) THEN
C
                 CALL WSHAMI(ITILAX,ITISAX,NO_ORB,ICHARG,ISIMPY)
C
                 SPMODL='WOODS-SAXON   '
C
             ELSE
C
            IF (ITWCEN.EQ.1) THEN
C
              CALL NILSON(ITILAX,ITISAX,NO_ORB,INNUMB,IZNUMB,
     *                           ICHARG,NAMEPN,HOMEGA,ISIMPY,
     *                                                  1,1)
C
                 SPMODL='NILSSON       '
             ELSE
               STOP 'TWO CENTER INCOMPATIBLE WITH PN MIXING'
             END IF
C
            END IF
C
             CALL PNMCOP(IPNMIX,ITPNMX,ISIMPY)
C
          END DO
C
C=======================================================================
C        INITIALIZING THE MATRIX ELEMENTS OF THE PAIRING FIELD
C=======================================================================
C
          IF (IPAHFB.GE.1) THEN
C
              STOP 'NOT READY YET 2'
C
              CALL INIPAI(ITPNMX,IPNMIX,ITWCEN,1)
C
              IF (JETACM.EQ.2) CALL ZERLIN(ISIMPY,MPAIRI)
              IF (KETA_R.EQ.2) CALL ZERROT(ISIMPY,MPAIRI)
C
              CALL INTEGD(ITPNMX,ISIMPY,ICHARG,
     *                    DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                                  JETACM,KETA_R,
     *                    IGOGPA,IREGPA,ISEPPA,ICOUPA,
     *                                  NEWGOG,NEWCOU,
     *                                          1,1,1)
C
              IF (NUMITE.GT.ITESTA.OR.(IFCONT.EQ.1.OR.IF_THO.EQ.1)) THEN
C
                  IF (I_SLOW.EQ.1) CALL MIXPAI(ICHARG,REA2PP,SLOWAL,1,1)
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C        DIAGONALIZING THE MATRIX OF THE   H F B   HAMILTONIAN
C=======================================================================
C
      IF (IPAHFB.GE.1) THEN
C
          IREMQB(:)=0
          INUMQB(:)=0
          JNUMQB(:)=0
C
          IF (ISIMPY.EQ.1) THEN
C
              STOP 'NOT READY YET 3'
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL HFBSIG(EFERMP,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALP,IFERAP,PARNUP,IZ_FIX,
     *                                             ITWOBA,IWRIQU,
     *                               INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                                             IFIBLP,ISABLP,
     *                               IREQPB,INUQPB,JNUQPB,IF_RPA)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              ELSE
C
                  CALL HFBSIM(EFERMP,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALP,IFERAP,PARNUP,IZ_FIX,
     *                                             ITWOBA,IWRIQU,
     *                                      INSIMP,IRSIMP,IDSIMP,
     *                                             IFIBLP,ISABLP,
     *                               IREQPB,INUQPB,JNUQPB,IF_RPA)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
             END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  STOP 'NOT READY YET 4'
C
                  CALL HFBSIQ(EFERMP,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                               FERALP,IFERAP,PARNUP,IZ_FIX,
     *                                             ITWOBA,NUQEVE,
     *                                      INSIQP,IPSIQP,IDSIQP,
     *                                             IFIBLP,ISABLP,
     *                                      IREQPB,INUQPB,JNUQPB)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              ELSE

                  CALL HFBMIZ(EFERMA,ECUTOF,LIMQUA,LAMCUT,IMFHFB,
     *                                             PARNUA,IA_FIX,
     *                                             ITWOBA,NUQEVE,
     *                                             INMIZA,IDMIZA,
     *                                             IFIBLA,ISABLA,
     *                               IREQPB,INUQPB,JNUQPB,ISAOCC)
C
                  IREMQB(1)=IREQPB
                  INUMQB(1)=INUQPB
                  JNUMQB(1)=JNUQPB
C
              END IF
C
          END IF
C
          EFEPIN=EFERMA
C
C=======================================================================
C        ATTENTION: WE USE ICHARG=0 TO ACCOMODATE ALL PROTON-NEUTRON
C                   MIXED QUASIPARTICLES
C=======================================================================
C
          ICHARG=0
C
C=======================================================================
C
          CALL QUABCS(EFERMA,IA_FIX,FERFIP,IFEFIP,ICHARG,
     *                       IDMIGA,IDMIMA,IDMIQA,IDMIZA,
     *                              IPRGCM,NUQEVE,ITWOBA,
     *                              FERALA,IFERAA,PARNUA,
     *                              IREMQB,INUMQB,JNUMQB,
     *                                     ISIMPY,ISIQTY)
C
          EFEPOU=EFERMA
C
          IF (PRINIT) CALL SPTQUA(EMAXQU,ICHARG,NAMEPN,NILXYZ,
     *                            IQUNIL,ISIGNY,ISIMPY,ISIQTY,
     *                            IDMIGA,IDMIMA,IDMIQA,IDMIZA,
     *                                   IREMQB,INUMQB,JNUMQB)
C
      END IF
C
C=======================================================================
C        DIAGONALIZING THE DENSITY MATRIX OR MATRIX OF THE MEAN FIELD
C=======================================================================
C
      DISLIA=0.0D0
C
      ICHARG=0
C
      IF (IPAHFB.GE.1) THEN
C
          ICHARG=0
C
          IF (ISIMPY.EQ.1) THEN
C
              STOP ' HFB WITH IPNMIX=1 AND ISIMPY=1 NOT IMPLEMENTED YET'
C
              CALL CANQUA(MREVER,ICHARG,IMFHFB,IREQPB,
     *                    LIPNOA,PARLIP,DISLIA,ESUM_P)
          ELSE
C
              CALL CANMIZ(ICHARG,IMFHFB,LIPNOA,PARLIA,DISLIA,ESUM_A)
C
          END IF
C
      ELSE
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL DIAMIG(MREVER)
C
              ELSE
C
                  CALL DIAMIM(MREVER)
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  CALL DIAMIQ
C
              ELSE
C
                  LIMPAR=0
C
                  IF (ITWCEN.EQ.1) THEN
C
                      CALL DIAMIZ(LIMPAR,ECUTOF,LDMEFI)
C
                  ELSEIF(ITWCEN.EQ.2) THEN
C
                      STOP ' TWO-CENTRE BASIS NOT IMPLMNTD FOR IPNMIX=1'
C
                  END IF
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C        CALCULATING VARIOUS SINGLE-PARTICLE AVERAGES
C=======================================================================
C=======================================================================
C        SEE COMMENTS TO THE PREVIOUS CALL TO AVANGY
C=======================================================================
C
      IF((ISIMPY.EQ.1.AND.IFLIPI.NE.0)                              .OR.
     *
     *   (ISIMPY.EQ.1.AND.ISIGNY.EQ.1.AND.(NOMLIG(0,0       ).NE.0  .OR.
     *                                     NOMLIG(0,1       ).NE.0  .OR.
     *                                     NOMLIG(1,0       ).NE.0  .OR.
     *                                     NOMLIG(1,1       ).NE.0)).OR.
     *
     *   (ISIMPY.EQ.1.AND.ISIGNY.NE.1.AND.(NOMLIM(  0       ).NE.0  .OR.
     *                                     NOMLIM(  1       ).NE.0)).OR.
     *
     *   (ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.(NOMLIQ(  0       ).NE.0  .OR.
     *                                     NOMLIQ(  1       ).NE.0)).OR.
     *
     *   (ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.(NOMLIZ            .NE.0)).OR.
     *
     *    IS_CON.EQ.1                                               .OR.
     *
     *    IS_PIN.EQ.1                                               .OR.
     *
     *    IS_CHA.EQ.1                                               .OR.
     *
     *    TERMNT                                                    .OR.
     *
     *    PRINIT)                                                   THEN
C
          CALL AVANGY(MREVER,ICHARG,IPNMIX,ISIMPY,ITWCEN)
C
          CALL AVOBSE(MREVER,ICHARG,IPNMIX,NRAORD)
C
          CALL AVISOS(MREVER)
C
      END IF
C
C=======================================================================
C        CALCULATING AND PRINTING SINGLE-PARTICLE AVERAGES
C=======================================================================
C
      CALL AVPARI(MREVER,ICHARG,IPNMIX)
C
      IF (TERMNT.OR.PRINIT) THEN
C
          CALL AVSIMP(MREVER,ICHARG,IPNMIX)
C
          CALL NILAPN(NOSCIL,MREVER,ISIMPY,NILXYZ)
C
      END IF
C
C=======================================================================
C        PRINTING THE SINGLE-PARTICLE SPECTRUM
C=======================================================================
C
      IF (PRINIT) THEN
C
          CALL PNTALL(EMINAL,EMAXAL,SPMODL,NAMEPN,
     *                       ISIGNY,ISIMPY,ISIQTY,
     *                       MREVER,       NILXYZ)
C
      END IF
C
C=======================================================================
C        CALCULATING PAIRING AND DEFINING OCCUPATION FACTORS
C=======================================================================
C
      EPAI_T=0.0
      EREA_T=0.0
      ELIP_T=0.0
C
      IF (IPAIRI.EQ.1) THEN
C
          IF (JPABCS.GT.0) THEN
C
              STOP ' BCS WITH IPNMIX=1 NOT IMPLEMENTED'
C
              IF (JPABCS.EQ.1.OR.
     *           (JPABCS.EQ.3.AND.ITERUN.EQ.1))  THEN
C
                  IF (IAVRGG.NE.1) THEN
C
                     CALL SETPAI(IN_FIX,IZ_FIX,FACTGP,ICHARG,GPAIRP)
C
                  ELSE
C
                     CALL GAVRAG(IN_FIX,IZ_FIX,FACTGP,ICHARG,GPAIRP)
C
                  END IF
C
              END IF
C
              EFEPIN=EFERMA
              CALL DELPAI (ICHARG,MREVER,JPABCS,IA_FIX,ITERUN,
     *                     DELFIA,GPAIRA,EPAI_A,EFERMA,DELTAA)
              EFEPOU=EFERMA
C
              IF (PRINIT)
     *
     *            CALL PAIPRI(NAMEPN,GPAIRP,EPAI_P,EFERMP,DELTAP,
     *                                      LIPKIP,EFER2P,ELIP_P,
     *                                      IPAHFB,JPABCS,IAVRGG,
     *                               IGOGPA,IREGPA,ISEPPA,ICOUPA)
C
          END IF
C
      ELSE
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  CALL CONMIG(MREVER,IN_FIX,IZ_FIX,EFERMA,
     *                                      IPAFLI,IREFLI,
     *                               ISPFLI,ISHFLI,IFLIPI)
              ELSE
C
                  CALL CONMIM(MREVER,IN_FIX,IZ_FIX,EFERMA,
     *                                             IREFLI,
     *                               ISPFLI,ISHFLI,IFLIPI)
C
              END IF
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  CALL CONMIQ(IN_FIX,IZ_FIX,EFERMA,
     *                        IPAFLI,
     *                        ISPFLI,ISHFLI,IFLIPI)
              ELSE
C
                  CALL CONMIZ(IN_FIX,IZ_FIX,EFERMA,
     *                        ISPFLI,ISHFLI,IFLIPI)
C
              END IF
C
          END IF
C
          DELTAN=0.0D0
          DELTAP=0.0D0
          DELTAA=0.0D0
C
      END IF
C
C=======================================================================
C        CALCULATING THE SUM OF SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      IF (IPAHFB.LT.1)
     *
     *    CALL PNENSU(MREVER,ESUM_T,ISIMPY)
C
C=======================================================================
C        CALCULATING THE SUM OF QUASIPARTICLE ENERGIES
C=======================================================================
C
      IF (IPAHFB.GE.1.AND.IQPSTA.EQ.1)
     *
     *    STOP ' FOR IPNMIX=1, IQPSTA=1 NOT YET IMPLEMENTED'
C    *    CALL PNQPSU(MREVER,ESUM_T,EFERMI)
C
C=======================================================================
C
      DO ITPNMX=0,2
C
C=======================================================================
C         ZEROING DENSITIES
C=======================================================================
C
         CALL ZEDENS(ITPNMX)
C
C=======================================================================
C        PREPARING CALCULATION OF DENSITIES AND CURRENTS
C=======================================================================
C
         IF (ITPNMX.EQ.0) THEN
C
             IKERNE=0
             ICHARG=0
             ISAWAV=1
C
         END IF
C
         IF (ITPNMX.EQ.1) THEN
C
             IKERNE=0
             ICHARG=1
             ISAWAV=1
C
         END IF
C
         IF (ITPNMX.EQ.2) THEN
C
             IKERNE=1
             ICHARG=0
             ISAWAV=0
C
C=======================================================================
C         FETCHING THE LEFT  WAVE FUNCTIONS FOR NEUTRONS AND
C         FETCHING THE RIGHT WAVE FUNCTIONS FOR PROTONS
C=======================================================================
C
             IALLOC=0
C
             IF (.NOT.ALLOCATED(WALEFT)) THEN
                 ALLOCATE (WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *                                                      STAT=IALLOC)
                 IF (IALLOC.NE.0) CALL NOALLO('WALEFT','HFODD ')
             END IF
C
C=======================================================================
C
             WALEFT(:,:,:)=SARIGH(:,:,:,0,1)
             WARIGH(:,:,:)=SARIGH(:,:,:,1,1)
C
         END IF
C
C=======================================================================
C        CALCULATING DENSITIES AND CURRENTS
C=======================================================================
C
         CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *               ISIGNY,ISIMPY,ISIQTY,IPAHFB,MREVER,ICHARG,
     *                                    MIN_QP,IPNMIX,ITPNMX,
     *                      ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *               ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                           ITWCEN,1)
C
C=======================================================================
C         DOUBLING SINGLE-PARTICLE RESULTS IN CASE OF NO ROTATION
C=======================================================================
C
         IF (IPAHFB.EQ.0) THEN
C
             IF (MREVER.EQ.0)
     *
     *       CALL DBLING(ITPNMX)
         ELSE
             STOP ' DBLING NOT IMPLEMENTED YET FOR IPAHFB>0'
C
         END IF
C
C=======================================================================
C         COPYING THE DENSITIES FROM THE NP BLOCK INTO THE PN BLOCK
C=======================================================================
C
         IF (ITPNMX.EQ.2) THEN
C
             DE_RHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,3,1:LDTWCE)
     *            =CONJG(DE_RHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,2,1:LDTWCE))
             DE_TAU(1:NDXHRM,1:NDYHRM,1:NDZHRM,3,1:LDTWCE)
     *            =CONJG(DE_TAU(1:NDXHRM,1:NDYHRM,1:NDZHRM,2,1:LDTWCE))
             DE_LPR(1:NDXHRM,1:NDYHRM,1:NDZHRM,3,1:LDTWCE)
     *            =CONJG(DE_LPR(1:NDXHRM,1:NDYHRM,1:NDZHRM,2,1:LDTWCE))
             DE_DIV(1:NDXHRM,1:NDYHRM,1:NDZHRM,3,1:LDTWCE)
     *            =CONJG(DE_DIV(1:NDXHRM,1:NDYHRM,1:NDZHRM,2,1:LDTWCE))
C
             DE_SPI(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,1:LDTWCE)
     *            =CONJG(DE_SPI(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2
     *                                                      ,1:LDTWCE))
             DE_KIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,1:LDTWCE)
     *            =CONJG(DE_KIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2
     *                                                      ,1:LDTWCE))
             DE_GRR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,1:LDTWCE)
     *            =CONJG(DE_GRR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2
     *                                                      ,1:LDTWCE))
             DE_LPS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,1:LDTWCE)
     *            =CONJG(DE_LPS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2
     *                                                      ,1:LDTWCE))
             DE_ROS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,1:LDTWCE)
     *            =CONJG(DE_ROS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2
     *                                                      ,1:LDTWCE))
             DE_ROC(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,1:LDTWCE)
     *            =CONJG(DE_ROC(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2
     *                                                      ,1:LDTWCE))
             DE_CUR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,1:LDTWCE)
     *            =CONJG(DE_CUR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2
     *                                                      ,1:LDTWCE))
             DE_KIF(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,1:LDTWCE)
     *            =CONJG(DE_KIF(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2
     *                                                      ,1:LDTWCE))
C
             DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1:NDKART,3,
     *                                                    1:LDTWCE)
     *            = CONJG(DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,
     *                                          1:NDKART,2,1:LDTWCE))
             DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1:NDKART,3,
     *                                                    1:LDTWCE)
     *            = CONJG(DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,
     *                                          1:NDKART,2,1:LDTWCE))
C
C        ADD PAIRING DENSITIES !!!!
C
         END IF
C
      END DO
C
C=======================================================================
C
      IF (MREVER.EQ.0) THEN
C
          ESUM_T=2*ESUM_T
C
      END IF
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   D E N S I T Y   M A T R I X
C=======================================================================
C        ATTENTION: FOR THE PROTON-NEUTRON MIXING, COUNTERS:
C                   LDTOTS, LDSTAT, LDUPPE, AND LDTIMU
C                   MUST BE SET AND EQUAL FOR BOTH ICHARG=0 AND ICHARG=1
C=======================================================================
C
      ICHARG=0
      ITPNMX=0
      IKERNE=0
C
      NAMEPN='NEUTRONS'
C
      WALEFT(:,:,:)=SARIGH(:,:,:,ICHARG,1)

      CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,WALEFT,WALEFT,1)
C
C=======================================================================
C        SAVING  THE   N E U T R O N   D E N S I T Y   M A T R I X
C=======================================================================
C
      IF (I_YUKA.GE.1.OR.I_GOGA.GE.1.OR.I_REGA.GE.1.OR.I_SEPA.GE.1.OR.
     *    I_COUA.GE.1.OR.MAXVAL(I_FSTA).GE.1.OR.MAXVAL(MAG2BC).GE.1.OR.
     *    COR_CM.OR.CORROT.OR.IFRAGM.EQ.1.OR.
     *    JETACM.GE.1.OR.KETA_R.GE.1)
     *
     *    CALL SAVDEN(ISIMPY,ITPNMX)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   P A I R I N G   T E N S O R
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.((COR_CM.OR.CORROT).OR.
     *    ICOUPA.GE.1.OR.MAXVAL(IFSTPA).GE.1.OR.
     *    IFRAGM.EQ.1.OR.
C    *    KETAJ2.EQ.1.OR.KETAT2.EQ.1.OR.
     *    IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1)) THEN
C
          CALL PAIMAC(ICHARG,ISIMPY,WALEFT,WALEFT,IKERNE)
C
          CALL SAVPAI(ISIMPY,ITPNMX)
C
      END IF
C
C=======================================================================
C        CALCULATING THE NEUTRON HFB PAIRING ENERGY AND AVERAGE DELTA
C=======================================================================
C        ATTENTION: PAIRING ENERGIES WITH P-N MIXING NOT FINISHED YET
C=======================================================================
C
      IF (IPAHFB.GE.1)
     *
     *    CALL EPAIRI(IN_FIX,IZ_FIX,ITPNMX,EKEPAI,1)
C
C=======================================================================
C         CALCULATING   D I R E C T   YUKAWA ENERGIES FOR NEUTRONS
C=======================================================================
C
      IF (PRIYUK)
     *
     *    CALL YUKAWD(ISIMPY,ICHARG)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    K I N E T I C    E N E R G Y
C=======================================================================
C
      CALL EKINET(EKIN_N,DLINSN(0),EKEKIN,DKINSN(0),1)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    POTENTIAL   HO   E N E R G Y
C=======================================================================
C
      EPOT_N =0.0D0
C
      IF (IPOTHO.EQ.1) THEN
        CALL EPOTHO(EPOT_N)
      END IF
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    M U L T I P O L E    MOMENTS
C=======================================================================
C
      ISHIFY=0
C
      CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,QMUL_N,QMUT_N,
     *                        COMULT,KMULMO,ISHIFY,1)
      CALL MOMSIF(ISIMPY,ISIGNY,ISIQTY,SMUL_N,SMUT_N,
     *                                 COMULT,KMULSI)
      IF (ISCHIF.EQ.1)
     *CALL MOMSCH(SMUL_N,SMUT_N,KMULSI,QMUL_N,QMUT_N,KMULMO)
      CALL MOMVMU(ISIMPY,VMUL_N,COMULT,KMULSI)
      IF (IDOPLM.EQ.1)
     *CALL MOMPLM(ISIMPY,ISIGNY,ISIQTY,PMUL_N,COMULT,KMULSI)
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          CALL MOMPRI(ISIMPY,NAMMUL,NAMHAR,NAMEPN,QMUL_N,KMULMO,'Q')
          IF (KMULSI.GT.0)
     *    CALL MOMPRI(ISIMPY,NAMSIF,NAMHAR,NAMEPN,SMUL_N,KMULSI,'S')
          IF (KMULSI.GT.0.AND.IDOPLM.EQ.1)
     *    CALL MOMPRI(ISIMPY,NAMPLM,NAMHAR,NAMEPN,PMUL_N,KMULSI,'P')
C
      END IF
C
C=======================================================================
C        CALCULATING THE    N E U T R O N     M A G N E T I C    MOMENTS
C=======================================================================
C
      CALL MAGMOM(ISIMPY,IROTAT,ICHARG,AMUL_N,AMUT_N,KMULMA,NMAORD)
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          CALL MAGPRI(IROTAT,NAMMAG,NAMHAR,NAMEPN,AMUL_N,KMULMA,NMAORD,
     *                                                             'M')
C
      END IF
C
C=======================================================================
C        CALCULATING THE    N E U T R O N    S P I N - ASYMMETRY MOMENTS
C=======================================================================
C
      CALL ASMMOM(ISIMPY,IROTAT,WMUL_N,WMUT_N,KMULAS,NASORD)
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          CALL MAGPRI(IROTAT,NAMASM,NAMHAR,NAMEPN,WMUL_N,KMULAS,NASORD,
     *                                                             'A')
C
      END IF
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    R M S    R A D I I
C=======================================================================
C
      CALL RMSQUA(RADI_N,RMSRAN,IN_FIX,NRAORD,ITWCEN)
C
      IF (PRINIT.AND.IPRI_N.EQ.1)
     *
     *    CALL RADPRI(NAMEPN,RADI_N,RMSRAN,NRAORD)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N    D E F O R M A T I O N S
C=======================================================================
C
      IF (PRIBET.AND.IPRI_N.EQ.1)
     *
     *    CALL BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMHAR,NAMEPN,
     *                              RADI_N,QMUL_N,BMUL_N,KMULMO)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   S P I N
C=======================================================================
C
      CALL SPIMOM(ISIMPY,IROTAT,ANGU_N,SPIN_N,ITWCEN)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   L I N E A R   M O M E N T A
C=======================================================================
C
      IF (COR_CM)
     *
     *    CALL LINAVR(ISIMPY,ISIGNY,ISIQTY,
     *                IPAHFB,ICHARG,JETACM,IROTAT,MREVER,COR_CM,IKERNE,
     *                DLINSN,ELINSN,PLINSN,TLINSN,ALINLN,PLINLN,PLINKN,
     *                DKINSN,EKINSN,PKINSN,TKINSN,AKINLN,PKINLN,PKINKN)
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   A N G U L A R   M O M E N T A
C=======================================================================
C
C     IF (CORROT.OR.KETAJ2.EQ.1)
      IF (CORROT)
     *
     *    CALL ROTAVR(ISIMPY,ISIGNY,ISIQTY,
     *                IPAHFB,ICHARG,KETA_R,IROTAT,MREVER,CORROT,IKERNE,
     *                DROTSN,EROTSN,PROTSN,TROTSN,AROTLN,PROTLN,PROTKN,
     *                DKOTSN,EKOTSN,PKOTSN,TKOTSN,AKOTLN,PKOTLN,PKOTKN)
C
C=======================================================================
C        CALCULATING THE  P R O T O N   D E N S I T Y   M A T R I X
C=======================================================================
C        ATTENTION: FOR THE PROTON-NEUTRON MIXING, COUNTERS:
C                   LDTOTS, LDSTAT, LDUPPE, AND LDTIMU
C                   MUST BE SET AND EQUAL FOR BOTH ICHARG=0 AND ICHARG=1
C=======================================================================
C
      ICHARG=1
      ITPNMX=1
      IKERNE=0
C
      NAMEPN=' PROTONS'
C
      WARIGH(:,:,:)=SARIGH(:,:,:,ICHARG,1)

C=======================================================================
      CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,WARIGH,WARIGH,1)
C
C=======================================================================
C        SAVING  THE    P R O T O N    D E N S I T Y   M A T R I X
C=======================================================================
C
      IF (I_YUKA.GE.1.OR.I_GOGA.GE.1.OR.I_REGA.GE.1.OR.I_SEPA.GE.1.OR.
     *    I_COUA.GE.1.OR.MAXVAL(I_FSTA).GE.1.OR.MAXVAL(MAG2BC).GE.1.OR.
     *    ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.
     *    COR_CM.OR.CORROT.OR.IFRAGM.EQ.1.OR.
     *    JETACM.GE.1.OR.KETA_R.GE.1)
     *
     *    CALL SAVDEN(ISIMPY,ITPNMX)
C
C=======================================================================
C        CALCULATING THE   P R O T O N S   P A I R I N G   T E N S O R
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.((COR_CM.OR.CORROT).OR.
     *    ICOUPA.GE.1.OR.MAXVAL(IFSTPA).GE.1.OR.
     *    IFRAGM.EQ.1.OR.
C    *    KETAJ2.EQ.1.OR.KETAT2.EQ.1.OR.
     *    IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1)) THEN
C
          CALL PAIMAC(ICHARG,ISIMPY,WARIGH,WARIGH,IKERNE)
C
          CALL SAVPAI(ISIMPY,ITPNMX)
C
      END IF
C
C=======================================================================
C         CALCULATING   D I R E C T   YUKAWA ENERGIES FOR PROTONS
C=======================================================================
C
      IF (PRIYUK)
     *
     *    CALL YUKAWD(ISIMPY,ICHARG)
C
C=======================================================================
C        CALCULATING THE   P R O T O N     K I N E T I C     E N E R G Y
C=======================================================================
C
      CALL EKINET(EKIN_P,DLINSP(0),EKEKIN,DKINSP(0),1)
C
C=======================================================================
C        CALCULATING THE   P R O T O N      POTENTIAL   HO   E N E R G Y
C=======================================================================
C
      EPOT_P =0.0D0
C
      IF (IPOTHO.EQ.1) THEN
        CALL EPOTHO(EPOT_P)
      END IF
C
C=======================================================================
C        CALCULATING THE   P R O T O N     M U L T I P O L E     MOMENTS
C=======================================================================
C
      ISHIFY=0
C
      CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,QMUL_P,QMUT_P,
     *                        COMULT,KMULMO,ISHIFY,1)
      CALL MOMSIF(ISIMPY,ISIGNY,ISIQTY,SMUL_P,SMUT_P,
     *                                 COMULT,KMULSI)
      IF (ISCHIF.EQ.1)
     *CALL MOMSCH(SMUL_P,SMUT_P,KMULSI,QMUL_P,QMUT_P,KMULMO)
      CALL MOMVMU(ISIMPY,VMUL_P,COMULT,KMULSI)
      IF (IDOPLM.EQ.1)
     *CALL MOMPLM(ISIMPY,ISIGNY,ISIQTY,PMUL_P,COMULT,KMULSI)
C
      IF (PRINIT.AND.IPRI_P.EQ.1) THEN
C
          CALL MOMPRI(ISIMPY,NAMMUL,NAMHAR,NAMEPN,QMUL_P,KMULMO,'Q')
          IF (KMULSI.GT.0)
     *    CALL MOMPRI(ISIMPY,NAMSIF,NAMHAR,NAMEPN,SMUL_P,KMULSI,'S')
          IF (KMULSI.GT.0.AND.IDOPLM.EQ.1)
     *    CALL MOMPRI(ISIMPY,NAMPLM,NAMHAR,NAMEPN,PMUL_P,KMULSI,'P')
C
      END IF
C
C      From now on, proton multipole moments have been computed and
C      are available for the Coulomb INTCOU() routine
      ISQPRO=1
C
C=======================================================================
C        CALCULATING THE   P R O T O N   M A G N E T I C   M O M E N T S
C=======================================================================
C
      CALL MAGMOM(ISIMPY,IROTAT,ICHARG,AMUL_P,AMUT_P,KMULMA,NMAORD)
C
      IF (PRINIT.AND.IPRI_P.EQ.1) THEN
C
          CALL MAGPRI(IROTAT,NAMMAG,NAMHAR,NAMEPN,AMUL_P,KMULMA,NMAORD,
     *                                                             'M')
C
      END IF
C
C=======================================================================
C        CALCULATING THE     P R O T O N     S P I N - ASYMMETRY MOMENTS
C=======================================================================
C
      CALL ASMMOM(ISIMPY,IROTAT,WMUL_P,WMUT_P,KMULAS,NASORD)
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          CALL MAGPRI(IROTAT,NAMASM,NAMHAR,NAMEPN,WMUL_P,KMULAS,NASORD,
     *                                                             'A')
C
      END IF
C
C=======================================================================
C         CALCULATING   P R O T O N    R M S    R A D I I
C=======================================================================
C
      CALL RMSQUA(RADI_P,RMSRAP,IZ_FIX,NRAORD,ITWCEN)
C
      IF (PRINIT.AND.IPRI_P.EQ.1)
     *
     *    CALL RADPRI(NAMEPN,RADI_P,RMSRAP,NRAORD)
C
C=======================================================================
C        CALCULATING THE   P R O T O N    D E F O R M A T I O N S
C=======================================================================
C
      IF (PRIBET.AND.IPRI_P.EQ.1)
     *
     *    CALL BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMHAR,NAMEPN,
     *                              RADI_P,QMUL_P,BMUL_P,KMULMO)
C
C=======================================================================
C         CALCULATING   P R O T O N   S P I N
C=======================================================================
C
      CALL SPIMOM(ISIMPY,IROTAT,ANGU_P,SPIN_P,ITWCEN)
C
C=======================================================================
C        CALCULATING THE   P R O T O N   L I N E A R   M O M E N T A
C=======================================================================
C
      IF (COR_CM)
     *
     *    CALL LINAVR(ISIMPY,ISIGNY,ISIQTY,
     *                IPAHFB,ICHARG,JETACM,IROTAT,MREVER,COR_CM,IKERNE,
     *                DLINSP,ELINSP,PLINSP,TLINSP,ALINLP,PLINLP,PLINKP,
     *                DKINSP,EKINSP,PKINSP,TKINSP,AKINLP,PKINLP,PKINKP)
C
C=======================================================================
C        CALCULATING THE   P R O T O N   A N G U L A R   M O M E N T A
C=======================================================================
C
C     IF (CORROT.OR.KETAJ2.EQ.1)
      IF (CORROT)
     *
     *    CALL ROTAVR(ISIMPY,ISIGNY,ISIQTY,
     *                IPAHFB,ICHARG,KETA_R,IROTAT,MREVER,CORROT,IKERNE,
     *                DROTSP,EROTSP,PROTSP,TROTSP,AROTLP,PROTLP,PROTKP,
     *                DKOTSP,EKOTSP,PKOTSP,TKOTSP,AKOTLP,PKOTLP,PKOTKP)
C
C=======================================================================
C          CALCULATING   T R U E   CHARGE DENSITY
C=======================================================================
C
      CALL TRUCHD
C
C=======================================================================
C          ZEROING THE COULOMB ENERGIES
C=======================================================================
C
      EKECOD=C_ZERO
      EKECOE=C_ZERO
      EKESCA=C_ZERO
      EKEVEC=C_ZERO
      EKPSCA=C_ZERO
      EKPVEC=C_ZERO
C
C=======================================================================
C          CALCULATING THE DIRECT COULOMB ENERGIES AND FIELDS BY THE
C          GREEN-FUNCTION METHOD
C=======================================================================
C
      IF (ICOUDI.EQ.1) THEN
C
          CALL COUMAT(NUMCOU,BOUCOU,ISIMPY,IKERNE)
C
          CALL COULOD(ISIMPY,EKECOD)
C
      END IF
C
C=======================================================================
C          CALCULATING SLATER EXCHANGE COULOMB ENERGY
C=======================================================================
C
      IF (ICOUEX.EQ.1) THEN
C
          CALL COULOE(EKECOE)
C
      END IF
C
C=======================================================================
C          CALCULATING THE DIRECT, EXCHANGE AND PAIRING COULOMB ENERGIES
C          AND FIELDS BY THE METHOD OF EXPANDING IN GAUSSIANS
C=======================================================================
C
      IF (ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.I_COUA.GE.1) THEN
C
          IF (NEWCOU.EQ.0) THEN
C
              CALL COUENE(ISIMPY,
     *                    ICOTYP,ICOUDI,ICOUEX,
     *                                  IDOTHC,
     *                    EKECOD,EKESCA,EKEVEC)
C
          ELSE
C
              CALL CO2ENE(ISIMPY,ICOTYP,ICOUDI,ICOUEX,ICOUPA,
     *                    EKECOD,EKESCA,EKEVEC,ITWCEN,LDTWCE)
C
          END IF
C
          IF (ICOUEX.EQ.2) EKECOE=EKESCA+EKEVEC
C
      END IF
C
      ECOULD=REAL(EKECOD)
      ECOULE=REAL(EKECOE)*COUSCA
      ECOULS=REAL(EKESCA)
      ECOULV=REAL(EKEVEC)
C
C=======================================================================
C        CALCULATING THE NEUTRON-PROTON   D E N S I T Y   M A T R I X
C=======================================================================
C        ATTENTION: FOR THE PROTON-NEUTRON MIXING, COUNTERS:
C                   LDTOTS, LDSTAT, LDUPPE, AND LDTIMU
C                   MUST BE SET AND EQUAL FOR BOTH ICHARG=0 AND ICHARG=1
C=======================================================================
C
      ICHARG=0
      ITPNMX=2
      IKERNE=1
C
      NAMEPN='NEU-PROT'
C
      WALEFT(:,:,:)=SARIGH(:,:,:,0,1)
      WARIGH(:,:,:)=SARIGH(:,:,:,1,1)
C
C=======================================================================
C
      CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,WALEFT,WARIGH,1)
C
C=======================================================================
C        SAVING  THE  NEUTRON-PROTON   D E N S I T Y   M A T R I X
C=======================================================================
C
      IF (I_YUKA.GE.1.OR.I_GOGA.GE.1.OR.I_REGA.GE.1.OR.I_SEPA.GE.1.OR.
     *    I_COUA.GE.1.OR.MAXVAL(I_FSTA).GE.1.OR.MAXVAL(MAG2BC).GE.1.OR.
     *    ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.
     *    COR_CM.OR.CORROT.OR.IFRAGM.EQ.1.OR.
     *    JETACM.GE.1.OR.KETA_R.GE.1)
     *
     *    CALL SAVDEN(ISIMPY,ITPNMX)
C
C=======================================================================
C        CALCULATING THE    NEUTRON-PROTON   P A I R I N G   T E N S O R
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.((COR_CM.OR.CORROT).OR.
     *    ICOUPA.GE.1.OR.MAXVAL(IFSTPA).GE.1.OR.
     *    IFRAGM.EQ.1.OR.
C    *    KETAJ2.EQ.1.OR.KETAT2.EQ.1.OR.
     *    IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1)) THEN
C
          CALL PAIMAC(ICHARG,ISIMPY,WALEFT,WARIGH,IKERNE)
C
          CALL SAVPAI(ISIMPY,ITPNMX)
C
      END IF
C
C=======================================================================
C        CALCULATING THE AVERAGE ISOSPINS
C=======================================================================
C
C     CALL AVISP2(MREVER,IN_FIX,IZ_FIX,ISIMPY)
C
      CALL AVISO2(MREVER,IN_FIX,IZ_FIX,ISIMPY)
C
C     CALL AVISOT(QMUT_I)
C
C=======================================================================
C         HERE ENDS THE CALCULATION FOR THE NEUTRON-PROTON MIXING
C=======================================================================
C
 8973 CONTINUE
C
C=======================================================================
C          CALCULATING THE "DIV S" DENSITIES FOR NEUTRONS AND PROTONS
C=======================================================================
C
      CALL SAVDIS
C
C=======================================================================
C          CALCULATING THE  D I R E C T  YUKAWA POTENTIALS
C=======================================================================
C
      IF (I_YUKA.GE.1) THEN
C
       CALL YUKMAT(PIMASS,NUMCOU,BOUCOU,ISIMPY)
C
      END IF
C
C=======================================================================
C          CALCULATING THE DIRECT AND EXCHANGE YUKAWA ENERGIES AND
C          FIELDS
C=======================================================================
C
      IF (I_YUKA.GE.1) THEN
C
          CALL YUKENE(PIMASS,PNMASS,IYUTYP,I_YUKA,YUKAGT,YUKAG0,
     *                                     YUKAG1,YUKAG2,ISIMPY)
C
      END IF
C
C=======================================================================
C          CALCULATING   T R U E   TOTAL DENSITY
C=======================================================================
C
      CALL TRUTOD(ITWCEN,LDTWCE)
C
C=======================================================================
C          CALCULATING  T H E   G O G N Y   E N E R G Y
C=======================================================================
C
      IF (I_GOGA.GE.1.AND.NEWGOG.EQ.0) THEN
C
          CALL GOGENE(I_SLOW,SLOWEV,ISGOGA,I_GOGA,ISIMPY,EKEGOG)
C
      END IF
C
C=======================================================================
C          CALCULATING  T H E   G O G N Y   P A I R I N G   E N E R G Y
C=======================================================================
C
      IF ((IGOGPA.EQ.1.OR.IGOGPA.EQ.2).AND.NEWGOG.EQ.0) THEN
C
          CALL GOGPAI(I_SLOW,SLOWPA,ISGOGP,IGOGPA,ISIMPY,IN_FIX,IZ_FIX)
C
      END IF
C
C=======================================================================
C          CALCULATING  T H E   REGULARIZED-SKYRME OR GOGNY  E N E R G Y
C=======================================================================
C          ATTENTION: A SIMULTANEOUS USE OF REGULARIZED  A  N  D   GOGNY
C                     IS NOT PERMITTED YET
C=======================================================================
C
      IF (I_REGA.GE.1.AND.NEWGOG.EQ.0.OR.
     *    I_GOGA.GE.1.AND.NEWGOG.EQ.1) THEN
C
          CALL REGENE(I_SLOW,SLOWEV,SLOWPA,
     *                I_REGA,IREGPA,ISREGA,ISREGP,
     *                I_GOGA,IGOGPA,ISGOGA,ISGOGP,
     *                N3LORD,ISIMPY,IN_FIX,IZ_FIX,EKEREG,NEWGOG)
C
      END IF
C
C=======================================================================
C          CALCULATING  T H E   SEPARABLE-FORCE   E N E R G Y
C=======================================================================
C
      IF (I_SEPA.GE.1.OR.ISEPPA.GE.1) THEN
C
          IF (IPNMIX.NE.1) THEN
C
           CALL SEPENE(ISSEPA,I_SEPA,SLOWPA,ISSEPP,ISEPPA,
     *                 N3SERD,ISIMPY,IN_FIX,IZ_FIX,EKESEP,
     *                               I_SLOW,SLOWEV,LDPNMX)
C
          ELSE
C
          CALL SEPMIE(ISSEPA,I_SEPA,SLOWPA,ISSEPP,ISEPPA,
     *                N3SERD,ISIMPY,IN_FIX,IZ_FIX,EKESEP,
     *                              I_SLOW,SLOWEV,LDPNMX)
C
          END IF
C
      END IF
C
C=======================================================================
C          CALCULATING THE FINITE-RANGE SPIN-ORBIT AND TENSOR ENERGIES
C=======================================================================
C
      IF (MAXVAL(I_FSTA).GE.1.OR.MAXVAL(IFSTPA).GE.1) THEN
C
          CALL FSTENE(I_SLOW,SLOWEV,ISFSTA,
     *                       SLOWPA,ISFSTP,
     *                       ISIMPY,IN_FIX,IZ_FIX,
     *                       EKEFSO,EKEFTO,EKEFTE)
C
      END IF
C
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C        BY DEFAULT,  HFODD  INITIALIZES THE  MATRIX OF THE  MEAN-FIELD
C        BY  COMPUTING THE  MATRIX ELEMENTS  OF THE  NILSON  POTENTIAL.
C        IN  HFB  MODE IT  INITIALIZES  THE MATRIX OF THE PAIRING FIELD
C        BY COMPUTING THE MATRIX ELEMENTS OF THE  DELTA-PAIRING  INTER-
C        ACTION, WHICH DEPENDS ON THE ISO-SCALAR DENSITY, AND THEREFORE
C        ON BOTH PROTON AND NEUTRON DENSITIES ON THE GAUSS-HERMITE MESH.
C        WHEN RESTARTING FROM HFBTHO, THESE DENSITIES ARE NOT AVAILABLE:
C        THE COMPUTATION OF  ALL  PAIRING OBSERVABLES MUST THEREFORE BE
C        SHIFTED TO  AFTER  THE NEW ISOSCALAR DENSITY HAS BEEN COMPUTED.
C        THIS ONLY AFFECTS THE  FIRST ITERATION, SEE ALSO COMMENT ABOUT
C        NUMITE EARLIER.
C=======================================================================
C
      IF (IF_THO.GE.1.AND.ITERUN.EQ.1) THEN
C
          CALL THOPAI
C
          NACTIT=NUMITE-2
C
C          Pairing energy and Lipkin-Nogami correction for neutrons
C
          NAMEPN='NEUTRONS'
C
          ICHARG=0
          ITPNMX=0
C
          IF (IPAHFB.GE.1) THEN
              CALL EPAIRI(IN_FIX,IZ_FIX,ITPNMX,EKEPAI,1)
          END IF
C
          IF (LIPKIN.EQ.1) THEN
              EF2NIN=EFER2N
              CALL LIPCOR(GPAIRN,FACTGN,FE2FIN,IF2FIN,I_SLOW,SLOWLI,
     *                                         EFER2N,NACTIT,ICHARG)
              EF2NOU=EFER2N
C
              ELIP_N=-2*EFER2N*DISLIN
C
          END IF
C
          IF (IDEVAR.EQ.1)
     *        CALL GINTER(ICHARG,MREVER,PRHO_N,PRHODN,POWERN)
C
          IF (PRINIT.AND.IPAHFB.GE.1)
     *
     *        CALL PAIPRI(NAMEPN,GPAIRN,EPAI_N,EFERMN,DELTAN,
     *                                  LIPKIN,EFER2N,ELIP_N,
     *                                  IPAHFB,JPABCS,IAVRGG,
     *                           IGOGPA,IREGPA,ISEPPA,ICOUPA)
C
C          Pairing energy and Lipkin-Nogami correction for protons
C
          NAMEPN='PROTONS '
C
          ICHARG=1
          ITPNMX=1
C
          IF (IPAHFB.GE.1) THEN
              CALL EPAIRI(IN_FIX,IZ_FIX,ITPNMX,EKEPAI,1)
          END IF
C
          IF (LIPKIP.EQ.1) THEN
              EF2PIN=EFER2P
              CALL LIPCOR(GPAIRP,FACTGP,FE2FIP,IF2FIP,I_SLOW,SLOWLI,
     *                                         EFER2P,NACTIT,ICHARG)
              EF2POU=EFER2P
C
              ELIP_P=-2*EFER2P*DISLIP
C
          END IF
C
          IF (IDEVAR.EQ.1)
     *        CALL GINTER(ICHARG,MREVER,PRHO_P,PRHODP,POWERP)
C
          IF (PRINIT.AND.IPAHFB.GE.1)
     *
     *        CALL PAIPRI(NAMEPN,GPAIRP,EPAI_P,EFERMP,DELTAP,
     *                                  LIPKIP,EFER2P,ELIP_P,
     *                                  IPAHFB,JPABCS,IAVRGG,
     *                           IGOGPA,IREGPA,ISEPPA,ICOUPA)
C
      END IF
C
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C
C=======================================================================
C         CALCULATING THE THREE-BODY-GRADIENT DENSITIES BASED
C         ON THE EV4 SUBROUTINES
C=======================================================================
C
      IF (IGRAIN.EQ.1) CALL TRADEN
C
C=======================================================================
C          CALCULATING  T H E   S K Y R M E   E N E R G Y
C=======================================================================
C
         CALL ESKYRM(ENESKY,ENEVEN,ENEODD,ENREAR,ENE_W0,EEVEW0,EODDW0,
     *                                                  EKESKY,LDPNMX,
     *                                                  IVIPRI,LDTWCE)
C
      IF (IPNMIX.EQ.1)
     *
     *    CALL ESKYNP(ENESKY,ENEVEN,ENEODD,ENREAR,ENE_W0,EEVEW0,
     *                                     EODDW0,EKESKY,LDPNMX)
C
      IF (PRINIT)
     *
     *    CALL PRIFUN(IROTAT,PRIYUK,I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                                     NEWGOG,I_SEPA,ISEPPA,
     *                       JETA_T,JETAPA,IVIPRI,N3LORD,N3SERD)
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C=======================================================================
C          CALCULATING THE NUMBER OF PARTICLES IN THE NECK
C=======================================================================
C
      IF (IFNECK.GE.1) THEN
C
C          We find the position of the neck
          CALL QNFIND(NXHERM,NYHERM,NZHERM,SLOWOD,ITERUN,ISIMPY,
     *                                            ISIGNY,IPARTY)
C
      END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C=======================================================================
C         CALCULATING THE LINEAR CONSTRAINT CORRELATION MATRIX
C=======================================================================
C
      IF (IPAIRI.EQ.1.AND.IPAHFB.GE.1.AND.
     *    ISIMPY.EQ.1.AND.IF_RPA.EQ.1) THEN
C
          CALL QMULCM(COMULT,IBROYD,MIXMAT,SLOWEV,
     *                       SLOWOD,NUMITE,NZMAXX)
C
      END IF
C
C=======================================================================
C         DETERMINING THE LINEAR MIXING FACTORS
C=======================================================================
C
      CALL LINMIX(ITERUN,NUMITE,IPCONT,IWRIOL,TERMNT,IF_THO,
     *                          I_SLOW,SLOWEV,SLOWOD,SLOWPA,
     *                                 XOLDEV,XOLDOD,XOLDPA)
C
C=======================================================================
C         CALCULATING THE FIELDS CORRESPONDING TO SKYRME HAMILTONIAN
C=======================================================================
C         TWO-CENTRE BASIS OPTION: SIXTEEN FIELDS ARE BUILT FROM THE
C         SIXTEEN DENSITIES FROM DENSHF+TWC_MORDEN
C=======================================================================
C
      IF (IBROYD.GE.1.AND.MIXMAT.EQ.0)
     *
     *    CALL SKF_IN(IROTAT)
C
      DO LTWCEN=1,LDTWCE
C
         CALL SKFILD(XOLDEV,XOLDOD,IPNMIX,ITWCEN,LTWCEN)
C
      END DO
C
      IF (IPNMIX.EQ.1)
     *
     *    CALL SKFINP(XOLDEV,XOLDOD,LDPNMX)
C
      IF (IBROYD.GE.1.AND.MIXMAT.EQ.0)
     *
     *    CALL SKF_OU(IROTAT)
C
C=======================================================================
C         CALCULATING THE PAIRING FIELDS
C=======================================================================
C
      IF (IPAHFB.GE.1) THEN
C
          IF (IBROYD.GE.1.AND.MIXMAT.EQ.0)
     *
     *        CALL SKP_IN
C
          DO LTWCEN=1,LDTWCE
C
             CALL SKPAIR(XOLDPA,LTWCEN)
C
          END DO
C
          IF (IBROYD.GE.1.AND.MIXMAT.EQ.0)
     *
     *        CALL SKP_OU
C
      END IF
C
C=======================================================================
C         CALCULATING THE THREE-BODY GRADIENT FIELDS
C         ATTENTION! BOTH P-H AND P-P FIELDS ARE HERE ADDED.
C=======================================================================
C
      IF (IGRAIN.EQ.1) CALL TRAFLD
C
C=======================================================================
C
      IF (IBROYD.GE.1.AND.MIXMAT.EQ.0.AND.
     *  ((NUMITE.GT.2.AND.IF_THO.GE.1).OR.
     *   (NUMITE.GT.0.AND.IF_THO.EQ.0)))
     *
     *    CALL DOBROY_FIELDS(ITERUN,NOFBRO,NSWBRO,ITAKEN,IROTAT,
     *                       IPAHFB,SLOWEV,ESTABN,IF_RPA,LDPNMX)
C
C      After the first iteration, IF_THO flag is not relevant anymore
      IF (ITERUN.EQ.1) IF_THO=0
C
C=======================================================================
C        READING THE NEW DENSITY MATRICES AFTER THE BROYDEN PROCEDURE
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.39Y) AND (2.78), AFTER  CALL
C                       TO "DOBROY", PARAMETERS  "EFER2N"  AND  "EFER2P"
C                       WERE AGAIN SLOWED DOWN WITH PARAMETER  "SLOWLI".
C                       THIS DUPPLICATED THE IDENTICAL SLOWING DOWN THAT
C                       IS PERFORMED IN "LIPCOR", AND THUS HAD AN EFFECT
C                       OF THE FINAL SLOWING DOWN BEING PERFORMED WITH A
C                       FACTOR OF  (2-SLOWLI)*SLOWLI,  WHICH  IS  ALWAYS
C                       LARGER THAN SLOWLI. THIS BUG  WAS  CORRECTED  ON
C                       11/10/2016 IN VERSION (2.78A).
C=======================================================================
C
      IF ((LIPKIN.EQ.1.OR.LIPKIP.EQ.1).AND.IBROYD.GE.1
     *                                .AND.MIXMAT.EQ.0)
     *    CALL LIP_OU(ISIMPY,LIPKIN,LIPKIP,EFER2N,EFER2P)
C
C=======================================================================
C          A D D I N G   THE  PROTON   AND   NEUTRON   CONTRIBUTIONS
C=======================================================================
C
      NAMEPN='   TOTAL'
C
      CALL NPLUSP(IN_FIX,IZ_FIX,IDOPLM,NRAORD,ITWCEN)
C
C=======================================================================
C          PRINTING THE MULTIPOLE CONSTRAINTS FOR THE AUGMENTED
C          LAGRANGE METHOD
C=======================================================================
C
      IF (PRINIT) CALL FINPRI(NMUCON,NSICON,ISCHIF)
C
C=======================================================================
C          PRINTING THE SPIN CONSTRAINTS FOR THE AUGMENTED
C          LAGRANGE METHOD
C=======================================================================
C
      IF (PRINIT) CALL FINSPI
C
C=======================================================================
C          PRINTING THE ISOSPIN CONSTRAINTS FOR THE AUGMENTED
C          LAGRANGE METHOD
C=======================================================================
C
      IF (PRINIT.AND.IPNMIX.EQ.1) CALL FINISO
C
C=======================================================================
C          CALCULATING THE CENTER-OF-MASS COORDINATES. SWITCH "ISHIFT"
C          IS SET TO ISHIFT=1 IF THE SYMMETRY CONDITIONS ALLOW  FOR  A
C          SHIFT BETWEEN THE C-O-M AND LABORATORY FRAMES.
C=======================================================================
C
      CALL COMASS(ISIMPY,ISIGNY,ISIQTY,QMUL_T,KMULMO,ISHIFT)
C
      IF (PRINIT.AND.ISHIFT.EQ.1)
     *
     *    CALL CMSPRI(NAMEPN)
C
C=======================================================================
C          CALCULATING MOMENTS AND RADII IN THE CENTER-OF-MASS FRAME
C=======================================================================
C          ATTENTION!  CALCULATION OF  THE  SCHIFF  MOMENTS  IN  THE
C                      CENTER-OF-MASS FRAME IS  NOT  YET  PROGRAMMED
C                      AND THEREFORE THEY WILL NOT BE LATER PRINTED.
C=======================================================================
C
      CALL SHICOE(KMULMO,KSHIMO,ISHIFT)
      CALL SHIMOM(KMULMO,KSHIMO,ISHIFT)
C
      CALL SHICOE(KMULSI,KSHISI,ISHIFT)
      CALL SHISIF(KMULSI,KSHISI,ISHIFT)
C
      CALL SHIRMS(KMULMO,ISHIFT)
      CALL SHIMAG(KMULMA,KSHIMA,ISHIFT,NOSHIM)
C
C=======================================================================
C          PRINTING THE RESULTS IN THE CENTER-OF-MASS FRAME FOR NEUTRONS
C=======================================================================
C
      IF (PRINIT.AND.IPRI_N.EQ.1) THEN
C
          NAMEPN='NEUTRONS'
C
          IF (ISHIFT.EQ.1.AND.KSHIMO.GT.0) THEN
C
              CALL MOMPRI(ISIMPY,NAMMUL,NAMSHI,NAMEPN,QSHI_N,KSHIMO,'Q')
C
              IF (KMULSI.GT.0.AND.ISCHIF.LT.1)
     *        CALL MOMPRI(ISIMPY,NAMSIF,NAMSHI,NAMEPN,SSHI_N,KMULSI,'S')
C
              IF (PRIBET)
     *        CALL BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMSHI,NAMEPN,
     *                                  RSHI_N,QSHI_N,BSHI_N,KSHIMO)
          END IF
C
          IF (ISHIFT.EQ.1.AND.NOSHIM.NE.1)
     *
     *        CALL MAGPRI(IROTAT,NAMMAG,NAMSHI,NAMEPN,ASHIXN,KMULMA,0,
     *                                                             'M')
C
          NAMEPN='   TOTAL'
C
      END IF
C
C=======================================================================
C          PRINTING THE RESULTS IN THE CENTER-OF-MASS FRAME FOR PROTONS
C=======================================================================
C
      IF (PRINIT.AND.IPRI_P.EQ.1) THEN
C
          NAMEPN=' PROTONS'
C
          IF (ISHIFT.EQ.1.AND.KSHIMO.GT.0) THEN
C
              NAMEPN=' PROTONS'
              CALL MOMPRI(ISIMPY,NAMMUL,NAMSHI,NAMEPN,QSHI_P,KSHIMO,'Q')
C
              IF (KMULSI.GT.0.AND.ISCHIF.LT.1)
     *        CALL MOMPRI(ISIMPY,NAMSIF,NAMSHI,NAMEPN,SSHI_P,KMULSI,'S')
C
              IF (PRIBET)
     *        CALL BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMSHI,NAMEPN,
     *                                  RSHI_P,QSHI_P,BSHI_P,KSHIMO)
          END IF
C
          IF (ISHIFT.EQ.1.AND.NOSHIM.NE.1)
     *
     *        CALL MAGPRI(IROTAT,NAMMAG,NAMSHI,NAMEPN,ASHIXP,KMULMA,0,
     *                                                             'M')
C
          NAMEPN='   TOTAL'
C
      END IF
C
C=======================================================================
C     CALCULATING THE EULER ANGLES OF THE PRINCIPAL-AXES FRAME. THEY ARE
C     DETERMINED IRRESPECTIVE OF ANY SYMMETRY CONDITIONS,  BECAUSE  EVEN
C     IN THE SIGNATURE/PARITY CASE, THE INTRINSIC FRAME CAN DIFFER  FROM
C     THE LABORATORY FRAME DUE TO THE BRINGING OF THE INTRINSIC FRAME TO
C     THE FIRST SECTOR OF BOHR'S VARIABLE 0<=GAMMA<=60. BECAUSE  OF  THE
C     SAME REASON, ALL MOMENTS IN THE INTRINSIC FRAME ARE ALWAYS PRINTED
C     UNLESS THE INPUT DATA SWITCH INTRIP=0 IS SET.
C=======================================================================
C
      CALL EULROT(KSHIMO,KROTMO)
C
      IF (PRINIT) CALL EULPRI(NAMEPN)
C
C=======================================================================
C          CALCULATING MULTIPOLE MOMENTS IN THE PRINCIPAL-AXES FRAME
C=======================================================================
C
      CALL PAXMOM(KSHIMO,KROTMO,QUNITS,QSHI_N,QSHI_P,QSHI_T,
     *            ALPEUL,BETEUL,GAMEUL,QROT_N,QROT_P,QROT_T)
      CALL PAXMOM(KSHISI,KROTSI,SUNITS,SSHI_N,SSHI_P,SSHI_T,
     *            ALPEUL,BETEUL,GAMEUL,SROTNN,SROTNP,SROTNT)
      CALL PAXMOM(KSHIMA,KROTMA,AUNITS,ASHI_N,ASHI_P,ASHI_T,
     *            ALPEUL,BETEUL,GAMEUL,AROTNN,AROTNP,AROTNT)
C
C=======================================================================
C          CALCULATING THE TWO-BODY-CURRENT CONTRIBUTIONS TO THE  DIPOLE
C          MAGNETIC MOMENTS
C=======================================================================
C
      IF (PRINIT.AND.MAXVAL(MAG2BC).GE.1) THEN
C
          CALL ADD2BC(ISIMPY)
C
          AMUL_T(1,-1,0)=AMUL_T(1,-1,0)+REAL(A2BCIN(-1))
     *                                 +REAL(A2BCSA(-1))
          AMUL_T(1, 0,0)=AMUL_T(1, 0,0)+REAL(A2BCIN( 0))
     *                                 +REAL(A2BCSA( 0))
          AMUL_T(1,+1,0)=AMUL_T(1,+1,0)+REAL(A2BCIN(+1))
     *                                 +REAL(A2BCSA(+1))
C
      END IF
C
C=======================================================================
C          CALCULATING THE TOTAL ANAPOLE MOMENTS
C=======================================================================
C
      IF (PRINIT.AND.MAXVAL(MAGANL).GE.1) THEN
C
C         CALL ANLMOM(ISIMPY)
C
          ANLTOT(-1)=+REAL(ANLJSQ(-1,1))+REAL(ANLJSQ(-1,2))
          ANLTOT( 0)=+REAL(ANLJSQ( 0,1))+REAL(ANLJSQ( 0,2))
          ANLTOT(+1)=+REAL(ANLJSQ(+1,1))+REAL(ANLJSQ(+1,2))
C
      END IF
C
C=======================================================================
C          THE TRANSFER OF MOMENTS BELOW IS USED FOR PRINTING ONLY
C=======================================================================
C
      AROTXN(:,:,0)=AROTNN(:,:)
      AROTXP(:,:,0)=AROTNP(:,:)
      AROTXT(:,:,0)=AROTNT(:,:)
C
C=======================================================================
C          PRINTING THE RESULTS FOR NUCLEONS
C=======================================================================
C
      IF (PRINIT.AND.IPRI_T.EQ.1) THEN
C
          CALL RADPRI(NAMEPN,RADI_T,RMSRAT,NRAORD)
C
          CALL MOMPRI(ISIMPY,NAMMUL,NAMHAR,NAMEPN,QMUL_T,KMULMO,'Q')
C
          IF (KMULSI.GT.0)
     *    CALL MOMPRI(ISIMPY,NAMSIF,NAMHAR,NAMEPN,SMUL_T,KMULSI,'S')
          IF (KMULSI.GT.0.AND.IDOPLM.EQ.1)
     *    CALL MOMPRI(ISIMPY,NAMPLM,NAMHAR,NAMEPN,PMUL_T,KMULSI,'P')
C
          CALL MAGPRI(IROTAT,NAMMAG,NAMHAR,NAMEPN,AMUL_T,KMULMA,NMAORD,
     *                                                             'M')
C
          CALL TBCPRI
C
          CALL MAGPRI(IROTAT,NAMASM,NAMHAR,NAMEPN,WMUL_T,KMULAS,NASORD,
     *                                                             'A')
C
          IF (PRIBET.OR.IWRIBA.NE.-1)
     *    CALL BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMHAR,NAMEPN,
     *                              RADI_T,QMUL_T,BMUL_T,KMULMO)
C
          IF (ISHIFT.EQ.1.AND.KSHIMO.GT.0) THEN
C
              CALL MOMPRI(ISIMPY,NAMMUL,NAMSHI,NAMEPN,QSHI_T,KSHIMO,'Q')
C
              IF (KMULSI.GT.0.AND.ISCHIF.LT.1)
     *        CALL MOMPRI(ISIMPY,NAMSIF,NAMSHI,NAMEPN,SSHI_T,KMULSI,'S')
C
              IF (PRIBET)
     *        CALL BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMSHI,NAMEPN,
     *                                  RSHI_T,QSHI_T,BSHI_T,KSHIMO)
          END IF
C
          IF (ISHIFT.EQ.1.AND.NOSHIM.NE.1)
     *
     *        CALL MAGPRI(IROTAT,NAMMAG,NAMSHI,NAMEPN,ASHIXT,KMULMA,0,
     *                                                             'M')
C
          IF (KROTMO.GT.0.AND.INTRIP.NE.0) THEN
C
C=======================================================================
C         HERE WE ENFORCE PRINTING ALL COMPONENTS OF THE ROTATED MOMENTS
C=======================================================================
C
              ISIMPP=0
C
              CALL MOMPRI(ISIMPP,NAMMUL,NAMROT,NAMEPN,QROT_T,KROTMO,'Q')
C
              IF (KMULSI.GT.0.AND.ISCHIF.LT.1)
     *        CALL MOMPRI(ISIMPP,NAMSIF,NAMROT,NAMEPN,SROTNT,KMULSI,'S')
C
              IF (PRIBET)
     *        CALL BOHDEF(ISIMPP,NEXBET,IPRIBE,IPRIBL,NAMROT,NAMEPN,
     *                                  RSHI_T,QROT_T,BROT_T,KROTMO)
          END IF
C
          IF (NOSHIM.NE.1.AND.INTRIP.NE.0)
     *        CALL MAGPRI(IROTAT,NAMMAG,NAMROT,NAMEPN,AROTXT,KMULMA,0,
     *                                                             'M')
C
          IF (COR_CM.OR.
     *       (IROTAT.EQ.1.AND.((ISIMPY.EQ.1.AND.ISIGNY.NE.1).OR.
     *                         (ISIMPY.NE.1.AND.ISIQTY.NE.1)))) THEN
C
              CALL LINPRI(NAMEPN,COR_CM,ALINLT,TLINST(0))
C
          END IF
C
          IF (CORROT) THEN
C
              CALL ROTPRI(NAMEPN,CORROT,AROTLT,TROTST)
C
          END IF
C
          IF (IPNMIX.EQ.1) THEN
C
              CALL ISOPRI
C
          END IF
C
      END IF
C
      IF (PRINIT) THEN
C
          IF (IROTAT.EQ.1) THEN
C
C=======================================================================
C           CALCULATING ALL ANGULAR MOMENTA IN THE C-O-M AND INTRINSIC
C           FRAMES.
C=======================================================================
C
              CALL ANGSHI(ALINLN,ANGU_N,ANGS_N)
              CALL ANGSHI(ALINLP,ANGU_P,ANGS_P)
              CALL ANGSHI(ALINLT,ANGU_T,ANGS_T)
C
              CALL ANGROT(ALPEUL,BETEUL,GAMEUL,ANGS_N,ANGS_P,ANGS_T,
     *                                         ANGR_N,ANGR_P,ANGR_T)
              CALL ANGROT(ALPEUL,BETEUL,GAMEUL,SPIN_N,SPIN_P,SPIN_T,
     *                                         SPIR_N,SPIR_P,SPIR_T)
C
              CALL ANGPRI(IMOVAX,ISIMPY,ISHIFT,INTRIP)
C
          END IF
C
C=======================================================================
C         PRINTING THE BLOCKED STATES
C=======================================================================
C
          CALL BLOPRI(SPMODL,ISIGNY,ISIMPY,ISIQTY,NILXYZ)
C
C=======================================================================
C         PRINTING THE CONFIGURATION DATA
C=======================================================================
C      ATTENTION! UP TO VERSION (2.80G), THE CODE PRINTED THE  REQUESTED
C                 AND NOT THE REALIZED CONFIGURATONS, WHICH COULD DIFFER
C                 FROM ONE ANOTHER WHEN DIABATIC BLOCKING WAS ACTIVE. ON
C                 29/04/2017  IN  VERSION  (2.80H),  THE   PRINTING   OF
C                 CONFIGURATONS AFTER DIABATIC BLOCKING WAS IMPLEMENTED.
C                 NOTE HOWEVER, THAT FOR THE PROTON-NEUTRON MIXING,  THE
C                 CORRESPONDING IMPLEMENTATION IS STILL MISSING.
C=======================================================================
C
          IF (IPAIRI.NE.1.OR.MINVAL(KPAHFB).EQ.0) THEN
C
              IF (IPNMIX.NE.1) THEN
C
                  IF (ISIMPY.EQ.1) THEN
C
                      IF (ISIGNY.EQ.1) THEN
C
                          CALL TABSIG(ICHFLI,IPAFLI,IREFLI,
     *                                ISPFLI,ISHFLI,IFLIPI,
     *                                MREVER,IPAIRI,KPAHFB)
                      ELSE
C
                          CALL TABSIM(ICHFLI,       IREFLI,
     *                                ISPFLI,ISHFLI,IFLIPI,
     *                                MREVER,IPAIRI,KPAHFB)
                      END IF
C
                  ELSE
C
                      IF (ISIQTY.EQ.1) THEN
C
                          CALL TABSIQ(ICHFLI,IPAFLI,
     *                                ISPFLI,ISHFLI,IFLIPI,
     *                                       IPAIRI,KPAHFB)
                      ELSE
C
                          CALL TABSIZ(ICHFLI,
     *                                ISPFLI,ISHFLI,IFLIPI,
     *                                       IPAIRI,KPAHFB)
                      END IF
C
                  END IF
C
              ELSE
C
                  IF (ISIMPY.EQ.1) THEN
C
                      IF (ISIGNY.EQ.1) THEN
C
                          CALL TABMIG(MREVER,       IPAFLI,IREFLI,
     *                                       ISPFLI,ISHFLI,IFLIPI)
                      ELSE
C
                          CALL TABMIM(MREVER,       IREFLI,
     *                                ISPFLI,ISHFLI,IFLIPI)
                      END IF
C
                  ELSE
C
                      IF (ISIQTY.EQ.1) THEN
C
                          CALL TABMIQ(IPAFLI,
     *                                ISPFLI,ISHFLI,IFLIPI)
                      ELSE
C
                          CALL TABMIZ(
     *                                ISPFLI,ISHFLI,IFLIPI)
                      END IF
C
                  END IF
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C          C A L C U L A T I N G  MULTIPOLE-CONSTRAINT   E N E R G I E S
C=======================================================================
C
      IF (KMULMO.LT.NMUCON) STOP 'KMULMO.LT.NMUCON IN MAIN HFODD'
C
      CALL QCNTRS(NMUCON,EMULCO,EMUSLO,EMUREA,IF_RPA,ITWCEN)
C
C=======================================================================
C          C A L C U L A T I N G    SURFACE-CONSTRAINT   E N E R G I E S
C=======================================================================
C
      IF (KMULSI.LT.NSICON) STOP 'KMULSI.LT.NSICON IN MAIN HFODD'
C
      CALL SCNTRS(NSICON,ESIFCO,ESISLO,ESIREA)
C
C=======================================================================
C          C A L C U L A T I N G     SPIN-CONSTRAINT     E N E R G I E S
C=======================================================================
C
      CALL ICNTRS(ITILAX,ITISAX,XOLDOD,ESPICO,ESPSLO,ESPREA)
C
C=======================================================================
C          C A L C U L A T I N G   ISOSPIN-CONSTRAINT    E N E R G I E S
C=======================================================================
C
      IF (IPNMIX.EQ.1) CALL TCNTRS(XOLDEV,XOLDOD,EISOCO,EISSLO,EISREA)
C
C=======================================================================
C          C A L C U L A T I N G   THE STABILITY
C=======================================================================
C
      IF (IPNMIX.NE.1) ESUM_T=ESUM_N+ESUM_P
C
      EKIN_T=EKIN_N+EKIN_P
C
      EPOT_T=EPOT_N+EPOT_P
C
      ESIN_T=0.5D0*(ESUM_T+EKIN_T+EPOT_T)
C
C=======================================================================
C          BELOW WE CORRECT FOR THE LIPKIN-NOGAMI ONE-BODY TERM, WHICH
C          IS EQUAL TO -2*LAMBDA2*IDENTITY. THIS TERM MUST BE ADDED TO
C          THE KINETIC-ENERGY OPERATOR. IN THE SUBROUTINE "INTEGH"  IT
C          IS ADDED TO THE MEAN-FIELD OPERATOR. HOWEVER, BELOW WE  USE
C          THE EXPRESSION FOR THE TOTAL ENERGY AS EQUAL TO HALF OF THE
C          SUM OF AVERAGE VALUES OF THE KINETIC-ENERGY AND  MEAN-FIELD
C          OPERATORS. THEREFORE, AT THIS POINT, THE AVERAGE  VALUE  OF
C          THE KINETIC-ENERGY OPERATOR MUST BE CORRECTED BY -LAMBDA2*N
C          WHERE N IS THE NUMBER OF PARTICLES, THAT  IS,  THE TRACE OF
C          THE IDENTITY AND DENSITY MATRIX.
C=======================================================================
C
      IF (LIPKIN.EQ.1) ESIN_T=ESIN_T-EFER2N*PARLIN
      IF (LIPKIP.EQ.1) ESIN_T=ESIN_T-EFER2P*PARLIP
C
C=======================================================================
C
      IF (ILIPON.GE.2) ESIN_T=ESIN_T- LAM2_N*IN_FIX
C
      IF (ILIPON.GE.4) ESIN_T=ESIN_T+ELAM4N
      IF (ILIPON.GE.6) ESIN_T=ESIN_T+ELAM6N
C
      IF (ILIPOP.GE.2) ESIN_T=ESIN_T- LAM2_P*IZ_FIX
C
      IF (ILIPOP.GE.4) ESIN_T=ESIN_T+ELAM4P
      IF (ILIPOP.GE.6) ESIN_T=ESIN_T+ELAM6P
C
C=======================================================================
C
      IF (JETACM.EQ.2) THEN
C
          DO KARTEZ=1,NDKART
C
             ESIN_T=ESIN_T+0.5D0*HBMREN(KARTEZ)*DLINST(KARTEZ)
C
             IF (IPAHFB.GE.1.AND.IQPSTA.NE.1)
     *           ESIN_T=ESIN_T+HBMREN(KARTEZ)*PLINST(KARTEZ)
C
          END DO
C
      END IF
C
      IF (KETA_R.EQ.2) THEN
C
          DO KARTEZ=1,NDKART
C
             ESIN_T=ESIN_T+0.5D0*ROTREN(KARTEZ)*DROTST(KARTEZ)
C
             IF (IPAHFB.GE.1.AND.IQPSTA.NE.1)
     *           ESIN_T=ESIN_T+ROTREN(KARTEZ)*PROTST(KARTEZ)
C
          END DO
C
      END IF
C
      IF (IPNMIX.EQ.1)
     *
     *    ESIN_T=ESIN_T+0.5D0*FERISO(0)*(QMUL_N(0,0)+QMUL_P(0,0))
C
      ECOULT=ECOULD+ECOULE
C
      IF (IGOGPA.GE.1.AND.NEWGOG.EQ.0) THEN
          EPAI_N=EPAI_N+REAL(EGOGSP(0)+EGOGVP(0))
          EPAI_P=EPAI_P+REAL(EGOGSP(1)+EGOGVP(1))
      END IF
      IF (IREGPA.GE.1.OR.(IGOGPA.GE.1.AND.NEWGOG.EQ.1)) THEN
          EPAI_N=EPAI_N+REAL(EREGSP(0)+EREGVP(0))
          EPAI_P=EPAI_P+REAL(EREGSP(1)+EREGVP(1))
      END IF
      IF (ICOUPA.GE.1) THEN
          EPAI_P=EPAI_P+REAL(EKPSCA+EKPVEC)
      END IF
      IF (ISEPPA.GE.1) THEN
          EPAI_N=EPAI_N+REAL(ESEPSP(0)+ESEPVP(0))
          EPAI_P=EPAI_P+REAL(ESEPSP(1)+ESEPVP(1))
      END IF
      IF (MAXVAL(IFSTPA).GE.1) THEN
          EPAI_N=EPAI_N+REAL(EFSOSP(0))+REAL(EFTOSP(0))+REAL(EFTESP(0))
          EPAI_P=EPAI_P+REAL(EFSOSP(1))+REAL(EFTOSP(1))+REAL(EFTESP(1))
      END IF
C
      EPAI_T=EPAI_N+EPAI_P
C
      IF (IGRAIN.EQ.1) EPAI_T=EPAI_T+ETGRAP
C
      EREA_T=EREA_N+EREA_P
C
      ELIP_T=ELIP_N+ELIP_P
C
      ECOREA=0.0D0
      IF (ICOUEX.EQ.1) ECOREA=-ECOULE/3
C
      FTHREE=REAL(E3BEVE+E3BODD)
      IF (IGRAIN.EQ.1) FTHREE=FTHREE+ETGRAF
C
      FFOURB=REAL(E4BEVE+E4BODD)
C
      ETOTSP=ESIN_T-ENREAR-ECOREA-EMUREA-ESIREA
     *      -ESPREA-EISREA-EREA_T-FTHREE/2-FFOURB
C
      IF (IPAHFB.GE.1.AND.IQPSTA.EQ.1) THEN
C
          ETOTSP=ETOTSP-(EPAI3N+EPAI3P)/2-ETGRAP/2-EPAI4N-EPAI4P
C
      ELSE
          ETOTSP=ETOTSP+EPAI_T
C
      ENDIF
C
      IF (ITWCEN.EQ.2) ETOTSP=ETOTSP-ENEFRN-ENEFRP
C
      ETOTFU=ENESKY+EKIN_T+EPOT_T+ECOULT+EPAI_T+FTHREE+FFOURB
     *      +REAL(FR2CBR)+REAL(FS2CBR)+REAL(FR3CBR)+REAL(FS3CBR)
     *      +REAL(FT2CBR)+REAL(FK2CBR)+REAL(FT3CBR)+REAL(FK3CBR)
     *      +REAL(FL2CBR)+REAL(FP2CBR)+REAL(FL3CBR)+REAL(FP3CBR)
     *      +REAL(FC2CBR)+REAL(FJ2CBR)+REAL(FC3CBR)+REAL(FJ3CBR)
C
      IF (I_YUKA.EQ.2.OR.I_YUKA.EQ.3) ETOTFU=ETOTFU+EYUKDT
      IF (I_YUKA.EQ.2.OR.I_YUKA.EQ.4) ETOTFU=ETOTFU+EYUKET
C
      IF ((I_GOGA.EQ.2.OR.I_GOGA.EQ.3).AND.NEWGOG.EQ.0)
     *                                ETOTFU=ETOTFU+EGOGDT
      IF ((I_GOGA.EQ.2.OR.I_GOGA.EQ.4).AND.NEWGOG.EQ.0)
     *                                ETOTFU=ETOTFU+EGOGET
C
      IF ((I_REGA.EQ.2.OR.I_REGA.EQ.3).OR.
     *   ((I_GOGA.EQ.2.OR.I_GOGA.EQ.3).AND.NEWGOG.EQ.1))
     *                                ETOTFU=ETOTFU+EREGDT
      IF ((I_REGA.EQ.2.OR.I_REGA.EQ.4).OR.
     *   ((I_GOGA.EQ.2.OR.I_GOGA.EQ.3).AND.NEWGOG.EQ.1))
     *                                 ETOTFU=ETOTFU+EREGET
C
      IF (I_SEPA.EQ.2.OR.I_SEPA.EQ.3) ETOTFU=ETOTFU+ESEPDT
      IF (I_SEPA.EQ.2.OR.I_SEPA.EQ.4) ETOTFU=ETOTFU+ESEPET
C
      IF (I_FSTA(1).EQ.2.OR.I_FSTA(1).EQ.3) ETOTFU=ETOTFU+EFSODT
      IF (I_FSTA(1).EQ.2.OR.I_FSTA(1).EQ.4) ETOTFU=ETOTFU+EFSOET
C
      IF (I_FSTA(2).EQ.2.OR.I_FSTA(2).EQ.3) ETOTFU=ETOTFU+EFTODT
      IF (I_FSTA(2).EQ.2.OR.I_FSTA(2).EQ.4) ETOTFU=ETOTFU+EFTOET
C
      IF (I_FSTA(3).EQ.2.OR.I_FSTA(3).EQ.3) ETOTFU=ETOTFU+EFTEDT
      IF (I_FSTA(3).EQ.2.OR.I_FSTA(3).EQ.4) ETOTFU=ETOTFU+EFTEET
C
C=======================================================================
C          BELOW WE ADD THE LIPKIN-NOGAMI CORRECTION TO THE TOTAL ENERGY
C          -2*Tr[RHO*(1-RHO)]
C          DENSITY MATRICES RHO THAT DEFINE THE LIPKIN-NOGAMI  TERM  ARE
C          DETERMINED IN SUBROUTINES "CANQUA" AND "CANQUZ". THAT IS  WHY
C          THE CORRESPONDING CORRECTIONS TO  ENERGY  ARE  BASED  ON  THE
C          PARTICLE-NUMBER DISPERSIONS CALCULATED THERE.
C=======================================================================
C
      IF (LIPKIN.EQ.1) ETOTFU=ETOTFU+ELIP_N
      IF (LIPKIP.EQ.1) ETOTFU=ETOTFU+ELIP_P
C
C=======================================================================
C          BELOW WE ADD THE LIPKIN CORRECTION TO THE TOTAL ENERGY
C=======================================================================
C
      IF (ILIPON.EQ.2) ETOTFU=ETOTFU+ELIP2N
C
      IF (ILIPON.EQ.4) ETOTFU=ETOTFU+ELIP4N
C
      IF (ILIPON.EQ.6) ETOTFU=ETOTFU+ELIP6N
C
      IF (ILIPOP.EQ.2) ETOTFU=ETOTFU+ELIP2P
C
      IF (ILIPOP.EQ.4) ETOTFU=ETOTFU+ELIP4P
C
      IF (ILIPOP.EQ.6) ETOTFU=ETOTFU+ELIP6P
C
      ECORCM=0.0D0
C
      IF (COR_CM) THEN
C
          DO KARTEZ=1,NDKART
C
             ECORCM=ECORCM+HBMREN(KARTEZ)*TLINST(KARTEZ)
C
          END DO
C
      END IF
C
      ECOR_R=0.0D0
C
      IF (CORROT) THEN
C
          DO KARTEZ=1,NDKART
C
             ECOR_R=ECOR_R+ROTREN(KARTEZ)*TROTST(KARTEZ)
C
          END DO
C
      END IF
C
      ETOTFU=ETOTFU+ECORCM+ECOR_R
C
      ESTABN=ETOTSP-ETOTFU
C
      IF (JETACM.EQ.1) ESTABN=ESTABN+ECORCM
      IF (KETA_R.EQ.1) ESTABN=ESTABN+ECOR_R
C
C@@@ FISSION - FISSION - FISSION - FISSION - FISSION - FISSION - FISSION
C=======================================================================
C         CALCULATING THE MASSES OF THE LEFT AND RIGHT FRAGMENTS
C         ASSUMING THE NECK IS AT ZPOINT
C=======================================================================
C
      IF (IFRAGM.EQ.1 .AND. TERMNT) THEN
C
#if(USE_MPI==1)
          IF ( NUDATA.EQ.number_batch ) THEN
#endif
C
C          This flag is used in DENSHF to symmetrize (True) or not
C          the Skyrme densities
          do_symmetrize = .False.
C
C          Doing a backup of all HFODD densities, since we will write
C          them on disk afterward
          CALL backup_density()
C
C          Allocating various arrays used to characterize fragments
          CALL allocate_loc(MIN_QP)
C
C          Initializing a bunch of arrays relevant to the localization
C          of qp at T>0
          IF (MIN_QP.EQ.1.AND.IFTEMP.GE.0) THEN
              CALL allocate_qp(NDBASE)
          END IF
C
C          Finding the position of the neck
          CALL QNFIND(NXHERM,NYHERM,NZHERM,SLOWOD,ITERUN,ISIMPY,
     *                                            ISIGNY,IPARTY)
C
C          Computing the auxiliary summation over z, SFACTO(MZ,NZ),
C          in [zN, +\infty[
          ALLOCATE(SFACTO(0:NZMAXX,0:NZMAXX))
          CALL DEFMAS(NZHERM,NZMAXX,Z_NECK,SFACTO)
C
C          Passing some inout variables to fission module
          IF (MIN_QP.EQ.1) THEN
              CALL fission_wrapper(DELTAE,XLOCMX,V2_MIN,ITRMAX,NTHETA)
          END IF
C
C          Computing the mass and charge of the fragments
          CALL RFRAGM(NZHERM,NZMAXX,Z_NECK,RIGMAS,RIGCHA)
C
          ICHARG=0
C
C          Defining the localization of the q.p. (neutrons)
          CALL wave_localization(NZHERM,NZMAXX,Z_NECK,ICHARG,SFACTO)
          CALL print_localization(EFERMN,ICHARG)
C
C          Minimizing the tails of the wave-functions (neutrons)
          IF (MIN_QP.EQ.1) THEN
              CALL minimize_tails(EFERMN,NZHERM,NZMAXX,Z_NECK,ICHARG)
              CALL print_rotation(EFERMN,ICHARG)
          END IF
C
          ICHARG=1
C
C          Defining the localization of the q.p. (protons)
          CALL wave_localization(NZHERM,NZMAXX,Z_NECK,ICHARG,SFACTO)
          CALL print_localization(EFERMP,ICHARG)
C
C          Minimizing the tails of the wave-functions (protons)
          IF (MIN_QP.EQ.1) THEN
              CALL minimize_tails(EFERMP,NZHERM,NZMAXX,Z_NECK,ICHARG)
              CALL print_rotation(EFERMP,ICHARG)
          END IF
C
C          Computes the positions of the centers of mass of the
C          left and right fragments
          CALL center_of_mass(NXHERM,NYHERM,NZHERM,Z_NECK,
     *                                      CENLEF,CENRIG)
C
C          Computing the multipole moments of the fragments
          QLMTOT(:,:,:) = 0.0D0
          QLMPRO(:,:,:) = 0.0D0
          QLMNEU(:,:,:) = 0.0D0
C
          DO LAMBDA=0,NMUPRI
             DO MIU=0,LAMBDA
C
                IF (MIU.EQ.0.OR.(LAMBDA.EQ.2.AND.MIU.EQ.2)) THEN
C
C                    Calculating multipole moments in the intrinsic
C                    frame of each fragment
C
                    I_TYPE=1
C
                    CALL QLMFRA(NXHERM,NYHERM,NZHERM,Z_NECK,LAMBDA,
     *                                           MIU,QLMLEF,QLMRIG,
     *                                               CENLEF,CENRIG,
     *                                                      I_TYPE)
C
                    QLMTOT(LAMBDA,MIU,0) = QLMLEF
                    QLMTOT(LAMBDA,MIU,1) = QLMRIG
C
                    I_TYPE=2
C
                    CALL QLMFRA(NXHERM,NYHERM,NZHERM,Z_NECK,LAMBDA,
     *                                           MIU,QLMLEF,QLMRIG,
     *                                               CENLEF,CENRIG,
     *                                                      I_TYPE)
C
                    QLMPRO(LAMBDA,MIU,0) = QLMLEF
                    QLMPRO(LAMBDA,MIU,1) = QLMRIG
C
C                    Calculating multipole moments in the intrinsic
C                    frame of the compound nucleus (= the original
C                    reference frame)
C
                    I_TYPE=1
                    CEFLEF=0.0D0
C
                    CALL QLMFRA(NXHERM,NYHERM,NZHERM,Z_NECK,LAMBDA,
     *                                           MIU,QLMLEF,QLMRIG,
     *                                               CEFLEF,CEFLEF,
     *                                                      I_TYPE)
C
                    QORTOT(LAMBDA,MIU,0) = QLMLEF
                    QORTOT(LAMBDA,MIU,1) = QLMRIG
C
                    I_TYPE=2
C
                    CALL QLMFRA(NXHERM,NYHERM,NZHERM,Z_NECK,LAMBDA,
     *                                           MIU,QLMLEF,QLMRIG,
     *                                               CEFLEF,CEFLEF,
     *                                                      I_TYPE)
C
                    QORPRO(LAMBDA,MIU,0) = QLMLEF
                    QORPRO(LAMBDA,MIU,1) = QLMRIG
C
                END IF
C
             END DO
          END DO
C
          ! Artificially enforces the calculation of the density in
          ! full space because densities for the fragments may have
          ! arbitrary symmetries (or lack thereof)
          IGOGNY=2
C
C          Computes the nuclear and Coulomb energies of the fragments,
C          and the interaction energy between the fragments
C          Note: proton multipole moments for the fragments are necessary
C                to evaluate the Coulomb energy and interaction energy.
C
          CALL interaction_energy_total(ICOUDI,ICOUEX,I_YUKA,NXHERM,
     *                                  NYHERM,NZHERM,ISIMTX,JSIMTY,
     *                                  ISIMTZ,ISIGNY,ISIMPY,ISIQTY,
     *                                  IPAHFB,MREVER,IGOGNY,IGOGPA,
     *                                  NAMEPN,PRINIT,IDEVAR,ITERUN,
     *                                  ISYMDE,INIROT,INIINV,INIKAR,
     *                                  ISAWAV,IKERNE,NUMCOU,BOUCOU,
     *                                  IN_FIX,IZ_FIX,IPAIRI,JETACM,
     *                                  IROTAT,EFERMN,EFERMP,INDJOB,
     *                                  IDEALL,IDELOC,IDECON,IPNMIX,
     *                                  ITIREP,MIN_QP,I_REGA)
     *
C
C          Computing the distance between the 2 fragments (rather, their
C          respective centers of mass)
          DISFRA = ABS(CENRIG - CENLEF)
C
C          Printing out the mass, charge and deformations of the
C          fragments
          CALL PRIFRA(IN_FIX,IZ_FIX,Z_NECK,Q_NECK,RIGMAS,RIGCHA,
     *                              QLMTOT,QORTOT,DISFRA,NMUPRI)
C
C          Restoring the localization flag so as to take all q.p.
          F_FLAG(:,:,:)=1.0D0
C
          DEALLOCATE(SFACTO)
C
C          Deallocating arrays relevant to the localization of qp at T>0
          IF (MIN_QP.EQ.1.AND.IFTEMP.GE.0) THEN
              CALL deallocate_qp()
          END IF
C
C          Deallocating arrays used to characterize fragments
          CALL deallocate_loc(MIN_QP)
C
C          Restoring all HFODD densities from the backup copy
          CALL restore_density()
C
C          Restore the symmetrization flag to True (default)
          do_symmetrize = .True.
C
#if(USE_MPI==1)
      END IF
#endif
      END IF
C
C@@@ FISSION - FISSION - FISSION - FISSION - FISSION - FISSION - FISSION
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C=======================================================================
C         CALCULATING THE SHELL CORRECTIONS FROM THE EQUIVALENT
C         SIGNLE-PARTICLE SPECTRUM
C=======================================================================
C
      IF (IFSHEL.EQ.1 .AND. TERMNT) THEN
C
          DO I=1,NDNUCL
             DSHELN(I)=0.0D0
             DSHELP(I)=0.0D0
          END DO
C
          IN_LOW=IN_FIX
          NOSTPN=1
          INSTEP=2
C
          IZ_LOW=IZ_FIX
          NOSTPZ=1
          IZSTEP=2
C
          CALL WSHELL(IN_FIX,IZ_FIX,IFSHEL,MREVER,IPAHFB,IMFHFB,
     *                IZ_LOW,NOSTPZ,IZSTEP,IN_LOW,NOSTPN,INSTEP,
     *                       IZNUCL,INNUCL,LDNUCL,DSHELP,DSHELN,
     *                                     EFERMP,EFERMN,NDBASE)
C
          IF (IPAHFB.EQ.0) THEN
              WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          ''*      SHELL CORRECTION (BASED ON HARTREE-FOCK'',
     *          '' SINGLE-PARTICLE ENERGIES)      *'')')
          END IF
          IF (IPAHFB.EQ.1) THEN
              IF (IMFHFB.EQ.0) THEN
                  WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          ''*           SHELL CORRECTION (BASED ON HFB'',
     *          '' EQUIVALENT SPECTRUM)               *'')')
              END IF
              IF (IMFHFB.EQ.1) THEN
                  WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          ''*           SHELL CORRECTION (BASED ON HFB'',
     *          '' CANONICAL SPECTRUM)                *'')')
              END IF
          END IF
C
          WRITE(NFIPRI,'(''*'',77X,''*'',/,
     *          ''*  SHELL CORR. - NEUTRONS:  '',F9.4,41X,
     *          ''*'',/,''*  SHELL CORR. - PROTONS :  '',
     *                F9.4,41X,''*'',/,''*'',77X,''*'')')
     *
     *              DSHELN(1),DSHELP(1)
C
      END IF
C
C=======================================================================
C   NICOLA: CALCULATION OF THE KINETIC ENERGY EIGENVALUES
C=======================================================================
C
      IF (IFSHEL.EQ.2.AND.TERMNT) THEN
C
          ISHELL=2
C
          DO I=1,NDNUCL
             DSHELN(I)=0.0D0
             DSHELP(I)=0.0D0
          END DO
C
          IN_LOW=IN_FIX
          NOSTPN=1
          INSTEP=2
C
          IZ_LOW=IZ_FIX
          NOSTPZ=1
          IZSTEP=2
C
          IF (ISIMPY.EQ.1) THEN
C
              CALL KINSIG(NUMCOU,BOUCOU,IKERNE,ISIMPY,ISIGNY,ISIQTY,
     *                    0,KMULMO,ISHIFY,MREVER)
C
              CALL KINSIG(NUMCOU,BOUCOU,IKERNE,ISIMPY,ISIGNY,ISIQTY,
     *                    1,KMULMO,ISHIFY,MREVER)
C
          ELSE
C
              CALL KINSIZ(NUMCOU,BOUCOU,IKERNE,ISIMPY,ISIGNY,ISIQTY,
     *                    0,KMULMO,ISHIFY0)
C
              CALL KINSIZ(NUMCOU,BOUCOU,IKERNE,ISIMPY,ISIGNY,ISIQTY,
     *                    1,KMULMO,ISHIFY)
C
          END IF
C
          CALL WSHELL(IN_FIX,IZ_FIX,IFSHEL,MREVER,IPAHFB,IMFHFB,
     *                IZ_LOW,NOSTPZ,IZSTEP,IN_LOW,NOSTPN,INSTEP,
     *                       IZNUCL,INNUCL,LDNUCL,DSHELP,DSHELN,
     *                                     EFERMP,EFERMN,NDBASE)
C
          IF (IPAHFB.EQ.0) THEN
              WRITE(NFIPRI,'(79(''*''),/,
     *          ''*      SHELL CORRECTION (BASED ON HARTREE-FOCK'',
     *          '' SINGLE-PARTICLE ENERGIES)     *'')')
          END IF
          IF (IPAHFB.EQ.1) THEN
              IF (IMFHFB.EQ.0) THEN
                  WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          ''*           SHELL CORRECTION (BASED ON HFB'',
     *          '' EQUIVALENT SPECTRUM)               *'')')
              END IF
              IF (IMFHFB.EQ.1) THEN
                  WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          ''*           SHELL CORRECTION (BASED ON HFB'',
     *          '' CANONICAL SPECTRUM)                *'')')
              END IF
          END IF
C
          WRITE(NFIPRI,'(''*'',77X,''*'',/,
     *          ''*  SHELL CORR. - NEUTRONS:  '',F9.4,41X,
     *          ''*'',/,''*  SHELL CORR. - PROTONS :  '',
     *                F9.4,41X,''*'')')
     *
     *              DSHELN(1),DSHELP(1)
C
      END IF
C
C@@@ SHELL -SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C=======================================================================
C         P R I N T I N G   T H E    E N E R G I E S
C=======================================================================
C
      IF (PRINIT) THEN
C
          CALL PRIENE(JETACM,KETA_R,IPOTHO,I_YUKA,I_GOGA,IGOGPA,
     *                                            I_REGA,IREGPA,
     *                                            I_SEPA,ISEPPA,
     *                                                   ICOUPA,
     *                                            LIPKIN,LIPKIP,
     *                                                   NEWGOG,
     *                                                   ICOUEX,
     *                                                   JETA_T)
C
          IF (TERMNT) THEN
              IF (IPAHFB.GE.1.AND.ISIMPY.EQ.1.AND.IFTEMP.EQ.1) THEN
                  CALL PRI_FT()
              END IF
          END IF
C
          IF (ITWCEN.EQ.2) CALL TWC_PRIFRA(KMULMO)
C
      END IF
C
C=======================================================================
C         S T O R I N G   T H E   C O N V E R G E N C E   R E P O R T
C=======================================================================
C
      IF (ITERUN.LE.NDITER+1) THEN
C
          ETOTFI(ITERUN)=ETOTFU
          ETOTSI(ITERUN)=ETOTSP
          ESTABI(ITERUN)=ESTABN
          QUA20I(ITERUN)=QMUL_T(2,0)
          QUA22I(ITERUN)=QMUL_T(2,2)
          ANGUTI(ITERUN)=ANGU_T(2)
C
      ELSE
C
          WRITE(NFIPRI,'(/,1X,19(1H/),
     *          ''  NO PLACE TO STORE ITERATION NO.='',
     *              I5,2X,19(1H/),/)') ITERUN
C
      END IF
C
C=======================================================================
C         SAVING THE WAVE FUNCTIONS FOR CALCULATION OF THE GCM KERNELS
C=======================================================================
C
      IF (TERMNT.AND.IWRWAV.EQ.1) THEN
C
          IWRBLO=1
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.11A) AND  (3.15H), THE ARGUMENT
C                    "ISIMPY" WAS NOT TRANSFERRED TO SUBROUTINE "SAVEWF"
C                    THIS  BUG  WAS  CORRECTED  IN  VERSION  (3.15I)  ON
C                    05/11/2022.
C=======================================================================
C
          CALL SAVEWF(NFIWAV,ITOWAV,FILWAV,IWRBLO,
     *                                        1,1,
     *                       KPROJE,ISIQTY,ISIMPY,
     *                IDSIQN,IDSIQP,IDSIZN,IDSIZP)
C
      END IF
C
C=======================================================================
C     CALCULATING THE LIPKIN VAPNP PARAMETERS AND CORRESPONDING ENERGY
C     CORRECTION
C=======================================================================
C
      IF (ILIPON.GT.1.OR.ILIPOP.GT.1) THEN
C
          ISAWAV=0
          IKERNE=1
C
          IF (ILIPON.GT.1)
     *        CALL LIPNAP(IN_FIX,ILIPON,GAUSHI,ISIMPY,MREVER,0)
C
          IF (ILIPOP.GT.1)
     *        CALL LIPNAP(IZ_FIX,ILIPOP,GAUSHI,ISIMPY,MREVER,1)
C
          CALL LIPVAP(IN_FIX,IZ_FIX,ILIPON,ILIPOP,
     *                                     GAUSHI,
     *                       ISIMTX,JSIMTY,ISIMTZ,
     *                       ISIGNY,ISIMPY,ISIQTY,
     *                IPAHFB,MREVER,IPNMIX,NUMCOU,
     *                BOUCOU,ICOTYP,ICOUDI,ICOUEX,
     *                                     IDOTHC,
     *                COUSCA,NAMEPN,PRINIT,IDEVAR,
     *                ITERUN,ISYMDE,INIROT,INIINV,
     *                       INIKAR,ISAWAV,IKERNE,
     *                                     MIN_QP,
     *                                     ITWCEN)
C
       END IF
C
C=======================================================================
C         PROJECTING THE ANGULAR MOMENTUM
C=======================================================================
C
      IF (TERMNT.AND.IPRGCM.EQ.1) THEN
C
          IDIAGO=1
          ISAWAV=0
          IKERNE=1
          KONMIX=0
          N_CALL=1
C
          INDBRA=1
          INDKET=1
C
          INLWAV=INLKER
          INRWAV=INRKER
C
          INUWAV=ITOWAV
C
          KPLEFT=KPROJE
C
          NMRMIX=0
          LMRMIX=0
          NMURMI=0
          LMURMI=0
          I_PASS=0
C
          IDIMUR=0
C
          IPROAN=1
C
          CALL PROANG(  IPROAN,
     *                  ISIMTX,JSIMTY,ISIMTZ,
     *                  ISIGNY,ISIMPY,ISIQTY,
     *           IPAHFB,IROTAT,ITIREP,MREVER,
     *                                IPNMIX,
     *                         IDEVAR,ITERUN,
     *                         NMUCOU,ISHIFY,
     *           INLWAV,INRWAV,ICOMIX,EPSMIX,
     *           INDBRA,INDKET,KONMIX,ICMPRI,
     *           IDIAGO,IDIMUR,IPROMI,IPROMA,
     *                  NATKNO,NBTKNO,ISOSTZ,
     *           NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *           ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *           NUAKNO,NUBKNO,KPROJE,KPLEFT,
     *                  INUWAV,ITOWAV,IWRWAV,
     *           ISAKER,ICHKER,NFIKER,FILKER,
     *           IPAKER,IPAK3D,IPAALL,KFIKER,
     *           NUASTA,NUASTO,NUGSTA,NUGSTO,
     *           NATSTA,NATSTO,NGTSTA,NGTSTO,
     *           NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *           NMUMAX,NMAMAX,NSIMAX,NASMAX,
     *                         NMAORD,NASORD,
     *    ISCHIF,NMURED,NMARED,NASRED,NSIRED,
     *                  ICUTOV,CUTOVE,CUTOVF,
     *                  IONISH,ISLPRI,ISUPRI,
     *                  IENPRI,ISRPRI,IMIPRI,
     *                  IKEPRI,IRMPRI,IELPRI,
     *                         IWRIRM,NFIRED,
     *           QMUCUT,QMACUT,QASCUT,QSICUT,
     *                         NUMCOU,BOUCOU,
     *                  ICOTYP,ICOUDI,ICOUEX,
     *                                IDOTHC,
     *           ISYMDE,INIROT,INIINV,INIKAR,
     *                         ISAWAV,IKERNE,
     *                                IBETME,
     *                         NFIWAV,FILWAV,
     *                         I_SLOW,SLOWEV,
     *                         NEWGOG,NEWCOU,
     *           I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                         I_SEPA,ISEPPA,
     *                         I_COUA,ICOUPA,
     *                         N3LORD,N3SERD,
     *                         LDPNMX,MIN_QP,
     *                         IN_FIX,IZ_FIX,
     *                  NFIFER,FILFER,N_CALL,
     *                         ISOADD,NBTKNT,
     *                         JETACM,KETA_R,
     *                         KETAJ2,KETAT2,
     *                         IDSIQN,IDSIQP,
     *                         IDSIZN,IDSIZP,
     *    NMRMIX,LMRMIX,NMURMI,LMURMI,I_PASS,
     *                         ISWIND,NUANGU,
     *                         IVIPRI,ITWCEN)
C
      END IF
C
C=======================================================================
C         PROJECTING PARTICLE NUMBERS
C=======================================================================
C
      IF (TERMNT.AND.IPNPRJ.EQ.1) THEN
          CALL PNPROJ(IN_FIX,IZ_FIX,NPPNPN,NPPNPP,
     *                ISIMTX,JSIMTY,ISIMTZ,ISIGNY,ISIMPY,ISIQTY,
     *                                            IPAHFB,MREVER,
     *                                            MIN_QP,IDOTHC,
     *                IPNMIX,NUMCOU,BOUCOU,ICOTYP,ICOUDI,ICOUEX,
     *                COUSCA,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *                ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,EPNPRJ)
      END IF
C
C=======================================================================
C         CALCULATING THE GCM KERNELS (VERSION NO.1, FIXED LEFT STATE)
C=======================================================================
C
      IF (TERMNT.AND.IPRGCM.EQ.2) THEN
C
          IDIAGO=0
          ISAWAV=0
          IKERNE=1
          KONMIX=0
          N_CALL=1
C
          INDBRA=1
          INDKET=1
C
          INLWAV=INLKER
          INRWAV=INRKER
C
          NMRMIX=0
          LMRMIX=0
          NMURMI=0
          LMURMI=0
          I_PASS=0
C
          IDIMUR=0
C
          DO INUWAV=IABS(IFRWAV),ITOWAV
C
             IWRBLO=1
C
             CALL READWF(NFIWAV,INUWAV,FILWAV,IWRBLO,1,1,KPLEFT)
C
             IPROAN=2
C
             CALL PROANG(IPROAN,
     *                   ISIMTX,JSIMTY,ISIMTZ,
     *                   ISIGNY,ISIMPY,ISIQTY,
     *            IPAHFB,IROTAT,ITIREP,MREVER,
     *                                 IPNMIX,
     *                          IDEVAR,ITERUN,
     *                          NMUCOU,ISHIFY,
     *            INLWAV,INRWAV,ICOMIX,EPSMIX,
     *            INDBRA,INDKET,KONMIX,ICMPRI,
     *            IDIAGO,IDIMUR,IPROMI,IPROMA,
     *                   NATKNO,NBTKNO,ISOSTZ,
     *            NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *            ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *            NUAKNO,NUBKNO,KPROJE,KPLEFT,
     *                   INUWAV,ITOWAV,IWRWAV,
     *            ISAKER,ICHKER,NFIKER,FILKER,
     *            IPAKER,IPAK3D,IPAALL,KFIKER,
     *            NUASTA,NUASTO,NUGSTA,NUGSTO,
     *            NATSTA,NATSTO,NGTSTA,NGTSTO,
     *            NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *            NMUMAX,NMAMAX,NSIMAX,NASMAX,
     *                          NMAORD,NASORD,
     *     ISCHIF,NMURED,NMARED,NASRED,NSIRED,
     *                   ICUTOV,CUTOVE,CUTOVF,
     *                   IONISH,ISLPRI,ISUPRI,
     *                   IENPRI,ISRPRI,IMIPRI,
     *                   IKEPRI,IRMPRI,IELPRI,
     *                          IWRIRM,NFIRED,
     *            QMUCUT,QMACUT,QASCUT,QSICUT,
     *                          NUMCOU,BOUCOU,
     *                   ICOTYP,ICOUDI,ICOUEX,
     *                                 IDOTHC,
     *            ISYMDE,INIROT,INIINV,INIKAR,
     *                          ISAWAV,IKERNE,
     *                                 IBETME,
     *                          NFIWAV,FILWAV,
     *                          I_SLOW,SLOWEV,
     *                          NEWGOG,NEWCOU,
     *            I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                          I_SEPA,ISEPPA,
     *                          I_COUA,ICOUPA,
     *                          N3LORD,N3SERD,
     *                          LDPNMX,MIN_QP,
     *                          IN_FIX,IZ_FIX,
     *                   NFIFER,FILFER,N_CALL,
     *                          ISOADD,NBTKNT,
     *                          JETACM,KETA_R,
     *                          KETAJ2,KETAT2,
     *                          IDSIQN,IDSIQP,
     *                          IDSIZN,IDSIZP,
     *     NMRMIX,LMRMIX,NMURMI,LMURMI,I_PASS,
     *                          ISWIND,NUANGU,
     *                          IVIPRI,ITWCEN)
C
             IF (IFRWAV.LT.0) GO TO 5555
C
          END DO
C
 5555     CONTINUE
C
      END IF
C
C=======================================================================
C         SETTINGS TO CALCULATE OFF-DIAGONAL KERNELS
C         (VERSION NO.2, ALL LEFT AND RIGHT STATES):
C=======================================================================
C
      IF (TERMNT.AND.IPRGCM.EQ.3) THEN
C
          IDIAGO=0
          ISAWAV=0
          IKERNE=1
          KONMIX=0
          N_CALL=1
C
          KPLEFT=KPROJE
C
          NMRMIX=0
          LMRMIX=0
          NMURMI=0
          LMURMI=0
          I_PASS=0
C
          IDIMUR=0
C
C=======================================================================
C        SETTINGS TO CALCULATE CONFIGURATION MIXING:
C=======================================================================
C
          IF (ICOMIX.EQ.1) THEN
C
              INLMIN=IFRWAV
              INLMAX=ITOWAV
C
              INDBRA=0
              DO INDWAV=IFRWAV,ITOWAV
                 IF (INDWAV.GT.ND_EXC) STOP 'INCREASE ND_EXC'
                 IF (IN_EXC(INDWAV).GT.0) THEN
                    DO INDSTA=1,IN_EXC(INDWAV)
                       INDBRA=INDBRA+1
                       IF (INDBRA.GT.NDCONF) STOP 'INCREASE NDCONF'
                       MIXIND(INDBRA,1)=INDWAV
                       MIXIND(INDBRA,2)=INDSTA
                    END DO
                 END IF
              END DO
C
              MIXDIM=INDBRA
C
              WRITE(*,769)
  769            FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *           1H*,26X,'CONFIGURATION ASSIGNMENT',27X,1H*,/,
     *           1H*,22X,'STATE No',4X,'KERNEL No',4X,
     *                   'EXCIT No',22X,1H*)
C
              DO INDBRA=1,MIXDIM
              WRITE(*,770) INDBRA,MIXIND(INDBRA,1),MIXIND(INDBRA,2)
  770            FORMAT(1H*,22X,I5,7X,I5,8X,I5,25X,1H*)
              END DO
C
          END IF
C
C=======================================================================
C         SETTINGS TO CALCULATE OFF-DIAGONAL KERNELS:
C=======================================================================
C
          IF (ICOMIX.EQ.0) THEN
C
              MIXDIM=1
C
          END IF
C
C=======================================================================
C
          DO INDBRA=1,MIXDIM
C
             IF (ICOMIX.EQ.1) THEN
                INLWAV=MIXIND(INDBRA,1)
                INLSTA=MIXIND(INDBRA,2)
             ELSE
                INLWAV=INLKER
                INLSTA=1
             END IF
C
             CALL REA_WL(NFIWAV,INLWAV,INLSTA,FILWAV,
     *                   ISOMIL,ISOMAL,ISOTZL)
C
             EIGINI(INDBRA)=EIGE_L
C
             WRITE(*,771) INDBRA,INLWAV,INLSTA,ISOMIL,ISOMAL,ISOTZL,
     *                    IIFERL,EIGE_L
  771        FORMAT(1H*,2X,'LEFT  STATE:',7I3,5X,'EBRA =',F12.6,
     *                                                  19X,1H*)
             DO MPROJE=-IIFERL,IIFERL,2
                DO IT=1,IDIM_L
                   C_KT_L(MPROJE,IT,INDBRA)=F_KT_L(MPROJE,IT,0)
                   IF (ICMPRI.GE.2)
     *                WRITE(*,772) MPROJE,IT,F_KT_L(MPROJE,IT,0)
  772                 FORMAT(1H*,14X,2I3,6X,2F16.10,19X,1H*)
                END DO
             END DO
C
             DO INDKET=INDBRA,MIXDIM
C
                IF (ICOMIX.EQ.1) THEN
                   INRWAV=MIXIND(INDKET,1)
                   INRSTA=MIXIND(INDKET,2)
                ELSE
                   INRWAV=INRKER
                   INRSTA=1
                END IF
C
                CALL REA_WR(NFIWAV,INRWAV,INRSTA,FILWAV,
     *                      ISOMIR,ISOMAR,ISOTZR)
C
                WRITE(*,773) INDKET,INRWAV,INRSTA,ISOMIR,ISOMAR,ISOTZR,
     *                       IIFERR,EIGE_R
  773           FORMAT(1H*,2X,'RIGHT STATE:',7I3,5X,'EKET =',F12.6,
     *                                                     19X,1H*)
                IF (ICMPRI.GE.2) THEN
                   DO MPROJE=-IIFERR,IIFERR,2
                      DO IT=1,IDIM_R
                         WRITE(*,772) MPROJE,IT,F_KT_R(MPROJE,IT,0)
                      END DO
                   END DO
                END IF
C=======================================================================
C                      BASIC CROSS-CHECKS OF INPUT DATA
C=======================================================================
                IF (IIFERL.NE.IIFERR.OR.IIFERL.NE.IIFERR) THEN
                   WRITE(*,774) IIFERL,IIFERR,IIFERR
  774              FORMAT(1H*,12X,'STOP: IIFERL.NE.IIFERR',
     *                            '  OR  IIFERL.NE.IIFERR',3I3,12X,1H*)
                   STOP
                END IF
C
                IF (ISOMIL.NE.ISOMIR.OR.ISOMIL.NE.ISOSMI) THEN
                   WRITE(*,775) ISOMIL,ISOMIR,ISOSMI
  775              FORMAT(1H*,12X,'STOP: ISOMIL.NE.ISOMIR',
     *                            '  OR  ISOMIL.NE.ISOSMI',3I3,12X,1H*)
                   STOP
                END IF
C
                IF (ISOMAL.NE.ISOMAR.OR.ISOMAL.NE.ISOSMA) THEN
                   WRITE(*,776) ISOMAL,ISOMAR,ISOSMA
  776              FORMAT(1H*,12X,'STOP: ISOMAL.NE.ISOMAR',
     *                            '  OR  ISOMAL.NE.ISOSMA',3I3,12X,1H*)
                   STOP
                END IF
C
                IF (ISOTZL.NE.ISOTZR.OR.ISOTZL.NE.ISOSTZ) THEN
                   WRITE(*,777) ISOTZL,ISOTZR,ISOSTZ
  777              FORMAT(1H*,12X,'STOP: ISOTZL.NE.ISOTZR',
     *                            '  OR  ISOTZL.NE.ISOSTZ',3I3,12X,1H*)
                   STOP
                END IF
C=======================================================================
C
                WRITE(*,778)
  778           FORMAT(1H*,77(1H*),1H*)
C
                IF (ICOMIX.EQ.1.AND.INDBRA.EQ.MIXDIM
     *                         .AND.INDKET.EQ.MIXDIM) KONMIX=1
C
                IPROAN=3
C
                CALL PROANG(IPROAN,
     *                      ISIMTX,JSIMTY,ISIMTZ,
     *                      ISIGNY,ISIMPY,ISIQTY,
     *               IPAHFB,IROTAT,ITIREP,MREVER,
     *                                    IPNMIX,
     *                             IDEVAR,ITERUN,
     *                             NMUCOU,ISHIFY,
     *               INLWAV,INRWAV,ICOMIX,EPSMIX,
     *               INDBRA,INDKET,KONMIX,ICMPRI,
     *               IDIAGO,IDIMUR,IPROMI,IPROMA,
     *                      NATKNO,NBTKNO,ISOSTZ,
     *               NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *               ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *               NUAKNO,NUBKNO,KPROJE,KPLEFT,
     *                      INUWAV,ITOWAV,IWRWAV,
     *               ISAKER,ICHKER,NFIKER,FILKER,
     *               IPAKER,IPAK3D,IPAALL,KFIKER,
     *               NUASTA,NUASTO,NUGSTA,NUGSTO,
     *               NATSTA,NATSTO,NGTSTA,NGTSTO,
     *               NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *               NMUMAX,NMAMAX,NSIMAX,NASMAX,
     *                             NMAORD,NASORD,
     *        ISCHIF,NMURED,NMARED,NASRED,NSIRED,
     *                      ICUTOV,CUTOVE,CUTOVF,
     *                      IONISH,ISLPRI,ISUPRI,
     *                      IENPRI,ISRPRI,IMIPRI,
     *                      IKEPRI,IRMPRI,IELPRI,
     *                             IWRIRM,NFIRED,
     *               QMUCUT,QMACUT,QASCUT,QSICUT,
     *                             NUMCOU,BOUCOU,
     *                      ICOTYP,ICOUDI,ICOUEX,
     *                                    IDOTHC,
     *               ISYMDE,INIROT,INIINV,INIKAR,
     *                             ISAWAV,IKERNE,
     *                                    IBETME,
     *                             NFIWAV,FILWAV,
     *                             I_SLOW,SLOWEV,
     *                             NEWGOG,NEWCOU,
     *               I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                             I_SEPA,ISEPPA,
     *                             I_COUA,ICOUPA,
     *                             N3LORD,N3SERD,
     *                             LDPNMX,MIN_QP,
     *                             IN_FIX,IZ_FIX,
     *                      NFIFER,FILFER,N_CALL,
     *                             ISOADD,NBTKNT,
     *                             JETACM,KETA_R,
     *                             KETAJ2,KETAT2,
     *                             IDSIQN,IDSIQP,
     *                             IDSIZN,IDSIZP,
     *        NMRMIX,LMRMIX,NMURMI,LMURMI,I_PASS,
     *                             ISWIND,NUANGU,
     *                             IVIPRI,ITWCEN)
C
                N_CALL=N_CALL+1
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         SETTINGS TO PERFORM MULTI-REFERENCE MIXING
C=======================================================================
C
      IF (TERMNT.AND.IPRGCM.EQ.4) THEN
C
          IDIAGO=0
          ISAWAV=0
          IKERNE=1
          KONMIX=0
C
          NMRMIX=0
          LMRMIX=0
          NMURMI=0
          LMURMI=0
          I_PASS=1
C
          IDIMUR=1
C
C=======================================================================
C        SETTINGS TO CALCULATE CONFIGURATION MIXING:
C=======================================================================
C
 5349     CONTINUE
C
          N_CALL=1
          IWRBLO=1
C
          MIXCOL(:,:,:)=0
C
          DO INDKET=1,MIXNUM
C
             INRWAV=MICONF(INDKET)
C
C=======================================================================
C            BELOW THE WAVE FUNCTIONS ARE READ FOR THE SOLE  PURPOSE  OF
C            DEFINING KPRIGH AND KPLEFT.
C            ATTENTION: FOR IPROAN=4, VALUE OF KPRIGH IS TRANSMITTED  TO
C            PROANG INSTEAD OF KPROJE.
C=======================================================================
C
             CALL READWF(NFIWAV,INRWAV,FILWAV,IWRBLO,1,1,KPRIGH)
C
C=======================================================================
C            HERE THE INDEX OF THE LEFT SINGLE-REFERENCE STATE  (THE BRA
C            STATE) IS SMALLER THAN  THAT  OF  THE  RIGHT STATE (THE KET
C            STATE), THAT IS, WE ARE GOING TO CALCULATE ONLY  THE  UPPER
C            TRIANGLE OF THE OVERLAP AND HAMILTONIAN MATRICES.
C=======================================================================
C
            DO INDBRA=1,INDKET
C
                INLWAV=MICONF(INDBRA)
C
                CALL READWF(NFIWAV,INLWAV,FILWAV,IWRBLO,1,1,KPLEFT)
C
                IF (INDBRA.EQ.MIXNUM.AND.INDKET.EQ.INDBRA) KONMIX=1
C
                IPROAN=4
C
                CALL PROANG(IPROAN,
     *                      ISIMTX,JSIMTY,ISIMTZ,
     *                      ISIGNY,ISIMPY,ISIQTY,
     *               IPAHFB,IROTAT,ITIREP,MREVER,
     *                                    IPNMIX,
     *                             IDEVAR,ITERUN,
     *                             NMUCOU,ISHIFY,
     *               INLWAV,INRWAV,ICOMIX,EPSMIX,
     *               INDBRA,INDKET,KONMIX,ICMPRI,
     *               IDIAGO,IDIMUR,IPROMI,IPROMA,
     *                      NATKNO,NBTKNO,ISOSTZ,
     *               NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *               ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *               NUAKNO,NUBKNO,KPRIGH,KPLEFT,
     *                      INLWAV,INRWAV,IWRWAV,
     *               ISAKER,ICHKER,NFIKER,FILKER,
     *               IPAKER,IPAK3D,IPAALL,KFIKER,
     *               NUASTA,NUASTO,NUGSTA,NUGSTO,
     *               NATSTA,NATSTO,NGTSTA,NGTSTO,
     *               NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *               NMUMAX,NMAMAX,NSIMAX,NASMAX,
     *                             NMAORD,NASORD,
     *        ISCHIF,NMURED,NMARED,NASRED,NSIRED,
     *                      ICUTOV,CUTOVE,CUTOVF,
     *                      IONISH,ISLPRI,ISUPRI,
     *                      IENPRI,ISRPRI,IMIPRI,
     *                      IKEPRI,IRMPRI,IELPRI,
     *                             IWRIRM,NFIRED,
     *               QMUCUT,QMACUT,QASCUT,QSICUT,
     *                             NUMCOU,BOUCOU,
     *                      ICOTYP,ICOUDI,ICOUEX,
     *                                    IDOTHC,
     *               ISYMDE,INIROT,INIINV,INIKAR,
     *                             ISAWAV,IKERNE,
     *                                    IBETME,
     *                             NFIWAV,FILWAV,
     *                             I_SLOW,SLOWEV,
     *                             NEWGOG,NEWCOU,
     *               I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                             I_SEPA,ISEPPA,
     *                             I_COUA,ICOUPA,
     *                             N3LORD,N3SERD,
     *                             LDPNMX,MIN_QP,
     *                             IN_FIX,IZ_FIX,
     *                      NFIFER,FILFER,N_CALL,
     *                             ISOADD,NBTKNT,
     *                             JETACM,KETA_R,
     *                             KETAJ2,KETAT2,
     *                             IDSIQN,IDSIQP,
     *                             IDSIZN,IDSIZP,
     *        NMRMIX,LMRMIX,NMURMI,LMURMI,I_PASS,
     *                             ISWIND,NUANGU,
     *                             IVIPRI,ITWCEN)
C
                N_CALL=N_CALL+1
C
             END DO
          END DO
C
          IF (I_PASS.EQ.2) GO TO 5349
C
      END IF
C
C=======================================================================
C         ADIABATIC CALCULATIONS
C=======================================================================
C
      IF (TERMNT.AND.IADBAT.EQ.1) THEN
C
          CALL PUSH_DSI_PARA(
     *                    ISIMTX,JSIMTY,ISIMTZ,ISIGNY,ISIMPY,ISIQTY,
     *                    IPAHFB,MREVER,MIN_QP,IPNMIX,ITPNMX,ITIREP,
     *                    IDEVAR,ITERUN,ISYMDE,INIROT,INIINV,INIKAR,
     *                    ISAWAV,IKERNE,IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                    IROTAT,MPAHFB,IPOTHO,ISCHIF,IOCONT,NMUCON,
     *                    NSICON,I_YUKA,I_GOGA,I_REGA,I_SEPA,ITWOLI,
     *                    JETACM,KETA_R,ICOUDI,ICOUEX,LIPKIN,LIPKIP,
     *                    IF_RPA,ILIPON,ILIPOP,NEWGOG,NEWCOU,
     *                    ITWCEN,LTWCEN,LDTWCE,ICOTYP,IDOTHC,INDCOE,
     *                    IDEFIN,IDEFIP,IGOGPA,IREGPA,ISEPPA,ICOUPA,
     *                    ISREGA,ISREGP,N3LORD,I_SLOW,ISGOGA,ISGOGP,
     *                                                IN_FIX,IZ_FIX,
     *                                                       NAMEPN,
     *             AROTLT,ALINLT,PRINIT,XOLDEV,XOLDOD,EFER2N,EFER2P,
     *                                  SLOWEV,SLOWPA,DELFIN,DELFIP)
C
          CALL ADBATI(IPAHFB)
C
      END IF
C
C=======================================================================
C         INTRISIC MULTIPOLE TOMOGRAPHY
C=======================================================================
C
      IF (TERMNT.AND.(ITOMOZ.EQ.1.OR.ITOMOZ.EQ.-1)) THEN
C
          CALL INTOMO(ISIMPY,ISIGNY,ISIQTY,KMULMO,LDBASE,
     *                              IN_FIX,IZ_FIX,NAMHAR)
C
      ENDIF
C
C=======================================================================
C         PROJECTED MULTIPOLE TOMOGRAPHY
C=======================================================================
C
      IF (TERMNT.AND.ABS(ITOMOZ).EQ.2) THEN
C
          CALL PJTOMO(ISIMPY,ISIGNY,ISIQTY,KMULMO,LDBASE,
     *                MPAHFB,IKERNE,IN_FIX,IZ_FIX,NAMHAR,
     *                MREVER,NEWWIG,ISWIND,NUANGU)
      ENDIF
C
C=======================================================================
C         RENORMALIZING THE MASS
C=======================================================================
C
      IF (IRENMA.GE.1) THEN
C
          IF (IPRGCM.GE.1) STOP ' IRENMA>0 NOT ALLOWED FOR IPRGCM>0'
C
          ISAWAV=0
          IKERNE=1
C ICANTP=1 :USE CANONICAL BASIS INSIDE RENMAS
          ICANTP=0
C
          CALL RENMAS(MIN_QP,IRENMA,IDOGOA,ISIMTX,JSIMTY,ISIMTZ,
     *                                     ISIGNY,ISIMPY,ISIQTY,
     *                              IPAHFB,IROTAT,ITIREP,MREVER,
     *                                                   IPNMIX,
     *                                            IDEVAR,ITERUN,
     *                                            NMUCOU,ISHIFY,
     *                                            NUMCOU,BOUCOU,
     *                              ISYMDE,INIROT,INIINV,INIKAR,
     *                                            ISAWAV,IKERNE,
     *                NOSCIL,NUMETA,NFICOU,FILCOU,ICOULI,ICOULO,
     *                       IN_FIX,IZ_FIX,ICANTP,I_SLOW,SLOWTP)
C
          IF (PRINIT.AND.IPRI_T.EQ.1)
     *
     *        CALL REMPRI(NAMEPN,TRAMAS,IDOGOA)
C
      END IF
C
C=======================================================================
C         RENORMALIZING THE INERTIA
C=======================================================================
C
      IF (IRENIN.GE.1) THEN
C
          IF (IPRGCM.GE.1) STOP ' IRENIN>0 NOT ALLOWED FOR IPRGCM>0'
C
          ISAWAV=0
          IKERNE=1
C ICANRP=1 :USE CANONICAL BASIS INSIDE RENINE
          ICANRP=0
C
          CALL RENINE(MIN_QP,IRENIN,IDOGOA,ISIMTX,JSIMTY,ISIMTZ,
     *                                     ISIGNY,ISIMPY,ISIQTY,
     *                              IPAHFB,IROTAT,ITIREP,MREVER,
     *                                                   IPNMIX,
     *                                            IDEVAR,ITERUN,
     *                                            NMUCOU,ISHIFY,
     *                                            NUMCOU,BOUCOU,
     *                              ISYMDE,INIROT,INIINV,INIKAR,
     *                                            ISAWAV,IKERNE,
     *                NOSCIL,NUMETA,NFICOU,FILCOU,ICOULI,ICOULO,
     *                                            IN_FIX,IZ_FIX,
     *                                     ICANRP,I_SLOW,SLOWRP)
C
          IF (PRINIT.AND.IPRI_T.EQ.1)
     *
     *        CALL REIPRI(NAMEPN,IDOGOA)
C
      END IF
C
C=======================================================================
C
      IF (IWRISO.EQ.1)  CALL IWRPRI(NFIISO)
C
C=======================================================================
C=======================================================================
C          P R I N T I N G   T H E   C O N V E R G E N C E   R E P O R T
C=======================================================================
C=======================================================================
C
      IF (NUMITE.EQ.ITESTA.AND..NOT.TERMNT) THEN
C
          IF (ICONTI.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *            1H*,1X,'' ITERATION RESTARTED FROM THE DISC,'',
     *                   '' THE FOLLOWING FILE(S) READ:'',  13X,1H*,/,
     *            1H*,2X,A68,''VER='',I2,                    1X,1H*)')
     *
     *        FILREP,IVEREP
C
              IF (IYCONT.EQ.1.AND.IFCONT.NE.1)
     *
     *            WRITE(NFIPRI,'(1H*,2X,A68,7X,1H*)') FILYUP
C
              IF (IGCONT.EQ.1)
     *
     *            WRITE(NFIPRI,'(1H*,2X,A68,7X,1H*)') FILGOP
C
              IF (IGPCON.EQ.1)
     *
     *            WRITE(NFIPRI,'(1H*,2X,A68,7X,1H*)') FILGPP
C
              IF (IECONT.EQ.1)
     *
     *            WRITE(NFIPRI,'(1H*,2X,A68,7X,1H*)') FILROP
C
              IF (ILCONT.EQ.1.AND.IFCONT.NE.1)
     *
     *            WRITE(NFIPRI,'(1H*,2X,A68,7X,1H*)') FILLIP
C
              IF (IFCONT.EQ.1)
     *
     *            WRITE(NFIPRI,'(1H*,2X,A68,''VER='',I2,1X,1H*)')
     *                                                FILFIP,IVEFIP
C
              WRITE(NFIPRI,'(1H*,77X,1H*)')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (.NOT.TERMNT) THEN
C
C=======================================================================
C         PRINTING THE HEADER
C=======================================================================
C
          IF (I1LINE.EQ.1.AND.(NUMITE.EQ.ITESTA.OR.IPRMID.EQ.1))
     *
     *        WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *             1H*,1X,''CONVERGENCE REPORT'',       37X,
     *                    ''                     '',        1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *             1H*,1X,''ITER     ENERGY     STABILITY    Q_2    '',
     *                    ''GAMMA   SPIN  OMEGA   ANGLE   EPAIR'',
     *                                 1X,1H*,/,    1H*,77X,1H*)')
C
          IF (I1LINE.EQ.2.AND.(NUMITE.EQ.ITESTA.OR.IPRMID.EQ.1))
     *
     *        WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *             1H*,1X,''CONVERGENCE REPORT'',       37X,
     *                    ''                     '',        1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *             1H*,1X,''ITER     ENERGY     STABILITY    Q_2  '',
     *                    ''DELTAN DELTAP  LAMBD2N LAMBD2P  EPAIR'',
     *                                 1X,1H*,/,    1H*,77X,1H*)')
C
          IF (I1LINE.EQ.3.AND.(NUMITE.EQ.ITESTA.OR.IPRMID.EQ.1))
     *
     *        WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *             1H*,1X,''CONVERGENCE REPORT'',       37X,
     *                    ''                     '',        1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *             1H*,1X,''ITER     ENERGY   STABILITY    Q_2  '',
     *                  '' GAMMA   S   lam_n  lamb_p  EpN    EpP '',
     *                                 1X,1H*,/,    1H*,77X,1H*)')
C
          IF (I1LINE.GE.4.AND.I1LINE.LE.6.AND.
     *       (NUMITE.EQ.ITESTA.OR.IPRMID.EQ.1))
     *
     *        WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *             1H*,1X,''CONVERGENCE REPORT'',       37X,
     *                    ''                     '',        1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *             1H*,1X,''ITER     ENERGY     STABILITY    Q_2   '',
     *                    ''GAMMA      ISOSPIN  FERMI EN.  EPAIR'',
     *                                 1X,1H*,/,    1H*,77X,1H*)')
C
C=======================================================================
C         CALCULATING THE SCALAR TOTAL QUADRUPOLE MOMENT
C=======================================================================
C
          QROT2T=SQRT(QROT_T(2,0)**2+QROT_T(2,2)**2)
C
C=======================================================================
C         CALCULATING THE BOHR GAMMA ANGLE IN THE INTRINSIC FRAME
C=======================================================================
C
          IF (ABS(QROT_T(2,0)).GT.1.0D-30) THEN
C
              GAMMMA=ATAN(QROT_T(2,2)/QROT_T(2,0))*45.0/ATAN(1.0D0)
C
              IF (QROT_T(2,0).LT.0) GAMMMA=GAMMMA+180.0
C
          ELSE
C
              IF (QROT_T(2,2).GE.0.0) THEN
                  GAMMMA= 90.0
              ELSE
                  GAMMMA=-90.0
              END IF
C
          END IF
C
C=======================================================================
C         CALCULATING THE LENGTHS OF THE ANGULAR MOMENTUM AND ROTATIONAL
C         FREQUENCY VECTORS AND THE ANGLE BETWEEN THEM
C=======================================================================
C
          IF (ISIMPY.EQ.1) THEN
C
              OMETOT=OMOVAY
              ANGTOT=ANGU_T(2)
              ANGLET=0.0
C
          ELSE
C
              OMETOT=OMOVAX   **2+OMOVAY   **2+OMOVAZ   **2
              ANGTOT=ANGU_T(1)**2+ANGU_T(2)**2+ANGU_T(3)**2
              ANGLET=0.0
C
              IF (OMETOT.GT.0.0.AND.ANGTOT.GT.0.0) THEN
C
                  SINANG=1-( OMOVAX*ANGU_T(1)
     *                      +OMOVAY*ANGU_T(2)
     *                      +OMOVAZ*ANGU_T(3))**2/OMETOT/ANGTOT
C
                  IF (ABS(SINANG).LE.1.0D0)
     *
     *                ANGLET=ASIN(SINANG)*45.0D0/ATAN(1.0D0)
C
              END IF
C
              OMETOT=SQRT(OMETOT)
              ANGTOT=SQRT(ANGTOT)
C
          END IF
C
C=======================================================================
C
          IF (ABS(ANGLET).GE.1E-2.OR.ANGLET.EQ.0.0) THEN
C
              WRITE(ANGLEC,'(F8.3)')     ANGLET
          ELSE
              WRITE(ANGLEC,'((1PE8.1))') ANGLET
C
          END IF
C
C=======================================================================
C
          IF (ABS(ESTABN).GE.1E-5.AND.ABS(ESTABN).LT.1E+3) THEN
C
              WRITE(ESTABC,'(F12.6)')     ESTABN
          ELSE
              WRITE(ESTABC,'((1PE12.2))') ESTABN
C
          END IF
C
C=======================================================================
C
          IF (ABS(QROT2T).GE.1E-5.AND.ABS(QROT2T).LT.1E+3) THEN
C
              WRITE(QROT2C,'(F8.3)')     QROT2T
          ELSE
              WRITE(QROT2C,'((1PE8.1))') QROT2T
C
          END IF
C
C=======================================================================
C         PRINTING THE ONE-LINE REPORT FOR THE CURRENT ITERATION
C=======================================================================
C
          IF (NUMITE.LT.100) THEN
C
              IF (I1LINE.EQ.1)
     *            WRITE(NFIPRI,'(1H*,I4,1X,F13.6,A12,A8,
     *                               F8.2,F7.2,F7.3,A8,F8.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,ANGTOT,OMETOT,ANGLEC,EPAI_T
C
              IF (I1LINE.EQ.2)
     *            WRITE(NFIPRI,'(1H*,I4,1X,F13.6,A12,A8,
     *                               F7.3,F7.3,F8.3,F8.3,F8.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            DELTAN,DELTAP,EFER2N,EFER2P,EPAI_T
C
              IF (I1LINE.EQ.3.AND.IPNMIX.EQ.1.AND.IPAHFB.EQ.1)
     *            STOP ' I1LINE.EQ.3 IS INCOMP. WITH IPNMIX/IPAHFB.EQ.1'
C
              IF (I1LINE.EQ.3)
     *            WRITE(NFIPRI,'(1H*,I4,1X,F11.4,A12,A8,
     *                      F6.1,F6.2,1X,F6.2,1X,F6.2,2F7.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,ENTRPY(0)+ENTRPY(1),
     *                  EFERMN,EFERMP,EPAI_N,EPAI_P
C
              IF (I1LINE.EQ.4)
     *            WRITE(NFIPRI,'(1H*,I4,1X,F13.6,A12,A8,
     *                      F7.2,'' X'',F11.6,F11.6,F7.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,TOTISO(1),FERMOV(1),EPAI_T
C
              IF (I1LINE.EQ.5)
     *            WRITE(NFIPRI,'(1H*,I4,1X,F13.6,A12,A8,
     *                      F7.2,'' Y'',F11.6,F11.6,F7.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,TOTISO(2),FERMOV(2),EPAI_T
C
              IF (I1LINE.EQ.6)
     *            WRITE(NFIPRI,'(1H*,I4,1X,F13.6,A12,A8,
     *                      F7.2,'' Z'',F11.6,F11.6,F7.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,TOTISO(3),FERMOV(3),EPAI_T
C
          ELSE
C
              IF (I1LINE.EQ.1)
     *            WRITE(NFIPRI,'(1H*,I5,F13.6,A12,A8,
     *                               F8.2,F7.2,F7.3,A8,F8.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,ANGTOT,OMETOT,ANGLEC,EPAI_T
C
              IF (I1LINE.EQ.2)
     *            WRITE(NFIPRI,'(1H*,I5,F13.6,A12,A8,
     *                               F7.3,F7.3,F8.3,F8.3,F8.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            DELTAN,DELTAP,EFER2N,EFER2P,EPAI_T
C
              IF (I1LINE.EQ.3.AND.IPNMIX.EQ.1.AND.IPAHFB.EQ.1)
     *            STOP ' I1LINE.EQ.3 IS INCOMP. WITH IPNMIX/IPAHFB.EQ.1'
C
              IF (I1LINE.EQ.3)
     *            WRITE(NFIPRI,'(1H*,I5,F11.4,A12,A8,
     *                        F6.1,F6.2,1X,F6.2,1X,F6.2,2F7.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,ENTRPY(0)+ENTRPY(1),
     *                  EFERMN,EFERMP,EPAI_N,EPAI_P
C
              IF (I1LINE.EQ.4)
     *            WRITE(NFIPRI,'(1H*,I5,F13.6,A12,A8,
     *                      F7.2,'' X'',F11.6,F11.6,F7.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,TOTISO(1),FERMOV(1),EPAI_T
C
              IF (I1LINE.EQ.5)
     *            WRITE(NFIPRI,'(1H*,I5,F13.6,A12,A8,
     *                      F7.2,'' Y'',F11.6,F11.6,F7.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,TOTISO(2),FERMOV(2),EPAI_T
C
              IF (I1LINE.EQ.6)
     *            WRITE(NFIPRI,'(1H*,I5,F13.6,A12,A8,
     *                      F7.2,'' Z'',F11.6,F11.6,F7.2,1X,1H*)')
     *            NUMITE,ETOTFU,ESTABC,QROT2C,
     *            GAMMMA,TOTISO(3),FERMOV(3),EPAI_T
C
          END IF
C
          IF (IPRMID.EQ.1)
     *
     *        WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
      END IF
C
C=======================================================================
C         RECORDING THE    F I E L D S   AFTER THIS  I T E R A T I O N
C=======================================================================
C
      IENDPR=0
C
      IF ((TERMNT.OR.IWRIRE.EQ.1).AND.IWRIRE.NE.-1) THEN
C
          IENDPR=1
C
          IF (TERMNT)
     *        WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECORD" TO SAVE'',
     *             '' THE RECORD FILE CONTAINING THE RESULTS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILREC
C
          IF (TERMNT) THEN
              IF (IWRIOL.EQ.1) THEN
                  WRITE(NFIPRI,'(
     *            1H*,''  THE MEAN FIELDS IN SPACE FROM THE'',
     *                ''  LAST-BUT-ONE ITERATION HAVE BEEN STORED'',
     *                                                         1X,1H*)')
              ELSE
                  WRITE(NFIPRI,'(
     *            1H*,''  THE MEAN FIELDS IN SPACE FROM THE'',
     *                ''  L  A  S  T   ITERATION HAVE BEEN STORED'',
     *                                                         1X,1H*)')
              END IF
          END IF
C
C=======================================================================
C          ATTENTION!  BETWEEN VERSIONS (1.78 hf78.f)  AND  (3.03K), THE
C                      VARIABLES:
C                                   REFERN,REFERP,
C                                   REDELN,REDELP,
C                                   REFE2N,REFE2P,
C
C                      WERE STORED ON THE RECORD FILE INSTEAD OF
C                      VARIABLES:
C                                   EFERMN,EFERMP,
C                                   DELTAN,DELTAP,
C                                   EFER2N,EFER2P,
C
C                      AS  A  RESULT,  FOR  CALCULATIONS WITH   PAIRING,
C                      A SMOOTH CONTINUATION OF  ITERATIONS  COULD  HAVE
C                      BEEN  IMPOSSIBLE.  THIS  BUG  WAS  CORRECTED   ON
C                      26/02/2021 IN VERSION (3.03L).
C=======================================================================
C
          INPFLD=0
          IERROR=0
C
          CALL RECORD(NFIREP,NFIREC,INPFLD,NUMITE,
     *                IVEREP,NXHERM,NYHERM,NZHERM,
     *                              IPCONT,ILCONT,
     *                       ISCONT,ITCONT,IACONT,
     *                              IMCONT,IRCONT,
     *                              IRENMA,IRENIN,
     *                              LIPKIN,LIPKIP,
     *                              EFERMN,EFERMP,
     *                              DELTAN,DELTAP,
     *                              EFER2N,EFER2P,
     *                              IDSIGN,IDSIGP,
     *                              IDSIMN,IDSIMP,
     *                              IDSIQN,IDSIQP,
     *                              IDSIZN,IDSIZP,
     *                                     INIBLN,
     *                                     INIBLP,
     *                              NMUMAX,NSIMAX,
     *                              IPNMIX,ISHIFT,
     *                              JETA_T,JETAPA,IERROR,
     *                                     LDTWCE,LDTWDD,
     *                                            IFRCNT)
C
C=======================================================================
C          ATTENTION!  BETWEEN VERSIONS  (2.59)  AND  (2.69O),  THE  TWO
C                      LINES BELOW HAVE  BEEN  COMMENTED  OUT.  ON  SOME
C                      COMPILERS  (E.G.  "GFORTRAN")  THIS  WAS  CAUSING
C                      PROBLEMS WITH THE OUTSTANDING BUFFERS OF THE  REC
C                      FILE  NOT  BEING  WRITTEN  TO  DISC  AFTER   EACH
C                      ITERATION,  WHICH  WAS  RENDERING  THE  REC  FILE
C                      UNUSABLE. THIS BUG WAS CORRECTED ON 14/04/2014 IN
C                      VERSION (2.69P).
C=======================================================================
C
          CLOSE(NFIREC)
C
          OPEN(NFIREC,FILE=FILREC,STATUS='OLD',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C
      IF ((TERMNT.OR.IWRIYU.EQ.1).AND.IWRIYU.NE.-1.AND.I_YUKA.GE.2) THEN
C
          IF (TERMNT.AND.IENDPR.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
          IENDPR=1
C
          IF (TERMNT)
     *        WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECYUK" TO SAVE'',
     *             '' THE YUKAWA FILE CONTAINING THE RESULTS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILYUC
C
          INPYUK=0
C
          CALL RECYUK(NFIYUP,NFIYUC,INPYUK)
C
          CLOSE(NFIYUC)
C
          OPEN(NFIYUC,FILE=FILYUC,STATUS='OLD',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C
      IF ((TERMNT.OR.IWRIGO.EQ.1).AND.IWRIGO.NE.-1.AND.
     *                               (I_GOGA.GE.2.AND.NEWGOG.EQ.0)) THEN
C
          IF (TERMNT.AND.IENDPR.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
          IENDPR=1
C
          IF (TERMNT)
     *        WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECGOG" TO SAVE'',
     *             '' THE GOGNY  FILE CONTAINING THE RESULTS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILGOC
C
          INPGOG=0
C
          CALL RECGOG(NFIGOP,NFIGOC,INPGOG)
C
          CLOSE(NFIGOC)
C
          OPEN(NFIGOC,FILE=FILGOC,STATUS='OLD',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C
      IF ((TERMNT.OR.IWRIGO.EQ.1).AND.IWRIGO.NE.-1.AND.
     *                               (IGOGPA.GE.2.AND.NEWGOG.EQ.0)) THEN
C
          IF (TERMNT.AND.IENDPR.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
          IENDPR=1
C
          IF (TERMNT)
     *        WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECGPA" TO SAVE'',
     *             '' THE GOGNY  FILE CONTAINING THE RESULTS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILGPC
C
          INPGPA=0
C
          CALL RECGPA(NFIGPP,NFIGPC,INPGPA)
C
          CLOSE(NFIGPC)
C
          OPEN(NFIGPC,FILE=FILGPC,STATUS='OLD',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C
      IF ((TERMNT.OR.IWRIRO.EQ.1).AND.IWRIRO.NE.-1.AND.
     *              ((I_GOGA.GE.2.AND.NEWGOG.EQ.1).OR.I_REGA.GE.2)) THEN
C
          IF (TERMNT.AND.IENDPR.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
          IENDPR=1
C
          IF (TERMNT)
     *        WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECREG" TO SAVE'',
     *             '' THE REGUL  FILE CONTAINING THE RESULTS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILROC
C
          INPREG=0
C
          CALL RECREG(NFIROP,NFIROC,INPREG)
C
          CLOSE(NFIROC)
C
          OPEN(NFIROC,FILE=FILROC,STATUS='OLD',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C
      IF ((TERMNT.OR.IWRILI.EQ.1).AND.IWRILI.NE.-1.AND.
     *    (IWRILI.NE.1.OR.IWRIFI.EQ.-1).AND.
     *    (LIPKIN.EQ.1.OR.LIPKIP.EQ.1)) THEN
C
          IF (TERMNT.AND.IENDPR.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
          IENDPR=1
C
          IF (TERMNT)
     *        WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECLIP" TO SAVE'',
     *             '' THE LIPKIN FILE CONTAINING THE RESULTS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILLIC
C
          INPLIP=0
C
          CALL RECLIP(NFILIP,NFILIC,INPLIP,ISIMPY)
C
          CLOSE(NFILIC)
C
          OPEN(NFILIC,FILE=FILLIC,STATUS='OLD',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C
      IF ((TERMNT.OR.IWRIFI.EQ.1).AND.IWRIFI.NE.-1) THEN
C
          IF (TERMNT.AND.IENDPR.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
          IENDPR=1
C
          IF (TERMNT)
     *        WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECFIL" TO SAVE'',
     *             '' THE FIELDS FILE CONTAINING THE RESULTS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILFIC
C
          INPFIL=0
          IFWTHO=0
C
          CALL RECFIL(NFIFIP,NFIFIC,INPFIL,ISIMPY,IPAHFB,
     *                              IPNMIX,NOSCIL,NUMITE,
     *                       EFERMN,EFERMP,EFER2N,EFER2P,
     *                              DELTAN,DELTAP,IFWTHO,
     *                                     NLIMIT,FILTHO,
     *                       ISGOGP,ISREGP,REA2PP,IVEFIP,
     *                                            ITWCEN)
C
          CLOSE(NFIFIC)
C
          OPEN(NFIFIC,FILE=FILFIC,STATUS='OLD',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C
      IF ((TERMNT.OR.IWRIQU.EQ.1).AND.IWRIQU.NE.-1) THEN
C
          IF (TERMNT.AND.IENDPR.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
          IENDPR=1
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECQUA" TO SAVE'',
     *             '' THE FILE CONTAINING QUASIPARTICLE W-FS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILQUA
C
          CALL RECQUA(NFIQUA,ISIMPY,IPAHFB,IPNMIX)
C
          CLOSE(NFIQUA)
C
          OPEN(NFIQUA,FILE=FILQUA,STATUS='OLD',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C         RECORDING THE BASIS DEFORMATION AFTER THIS  I T E R A T I O N
C=======================================================================
C
      IF ((TERMNT.OR.IWRIBA.EQ.1).AND.IWRIBA.NE.-1) THEN
C
          IENDPR=1
C
          IF (TERMNT)
     *        WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,''  CALLING SUBROUTINE "RECBAS" TO SAVE'',
     *             '' THE BASIS  FILE CONTAINING THE RESULTS'',1X,1H*,/,
     *         1H*,2X,A68,                                     7X,1H*)')
     *
     *         FILBAC
C
          INPFLD=0
          IERROR=0
C
          CALL RECBAS(NFIBAP,NFIBAC,INPFLD,IERROR)
C
          CLOSE(NFIBAC)
C
          OPEN(NFIBAC,FILE=FILBAC,STATUS='OLD',FORM='FORMATTED')
C
      END IF
C
C=======================================================================
C
      IF (TERMNT.AND.IENDPR.EQ.1)WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
C=======================================================================
C
      IF (.NOT.TERMNT) THEN
C
          CALL CNVRGE(ESTABN,EPSITE,IS_YES,ITERUN,NULAST,
     *                              EPSCON,IS_CON,NUCONS)
C
          IF (IS_YES.EQ.1.OR.NUMITE+1.GE.ITESTO) THEN
C
C=======================================================================
C             HERE WE DEAL WITH THE SITUATION WHEN EITHER THE
C             CONVERGENCE HAS BEEN ACHIEVED, OR THE LIMIT  OF
C             ALLOWED ITERATIONS IS ABOUT TO BE EXCEEDED. THE
C             NEXT INTERATION WILL BE THE TERMINAL ONE.
C=======================================================================
C
              WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
              TERMNT=.TRUE.
C
          ELSE
C
              IF (IS_CON.EQ.1) THEN
C
C=======================================================================
C             HERE WE DEAL WITH THE SITUATION WHEN CONSTANT-STABILITY
C             CONDITION HAS BEEN DETECTED IN THE PREVIOUS ITARATION.
C             THE NEXT INTERATION WILL BE THE TERMINAL ONE.
C=======================================================================
C
                  WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                  1H*,1X,''CONSTANT STAB. COND.'',
     *                         '' DETECTED, ITERATIO'',
     *                         ''N FOR THIS DATA SET'',
     *                         '' IS BEING ABORTED '',1H*,/,
     *                  1H*,77X,1H*,/,79(1H*),/)')
C
                  TERMNT=.TRUE.
C
              END IF
C
              IF (IS_PIN.EQ.1) THEN
C
C=======================================================================
C             HERE WE DEAL WITH THE SITUATION  WHEN  THE  PING-PONG
C             CONDITION HAS BEEN DETECTED IN THE PREVIOUS ITARATION.
C             THE NEXT INTERATION WILL BE THE TERMINAL ONE.
C=======================================================================
C
                  WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                  1H*,1X,''PING-PONG CONDITION'',
     *                         '' DETECTED, ITERATIO'',
     *                         ''N FOR THIS DATA SET'',
     *                         '' IS BEING  ABORTED '',1H*,/,
     *                  1H*,77X,1H*,/,79(1H*),/)')
C
                  TERMNT=.TRUE.
C
              ELSE
C
C=======================================================================
C             HERE WE DEAL WITH THE  SITUATION  WHEN  THE  PING-PONG
C             CONDITION HAS NOT YET BEEN DETECTED. IF IT IS DETECTED
C             NOW, WE SHOULD CONTINUE AS IF NOTHING HAPPENED BECAUSE
C             IN  THE  NEXT  ITERATION  WE  HAVE  TO  CALCULATE  THE
C             SINGLE-PARTICLE PROPERTIES REQUIRED BY FLISIG, FLISIM,
C             FLISIQ, OR FLISIZ
C=======================================================================
C
                  CALL PINGPO(EPSPNG,IS_PIN,ITERUN,NUPING)
C
              END IF
C
              IF (IS_CHA.EQ.1) THEN
C
C=======================================================================
C             HERE WE DEAL WITH  THE  SITUATION  PERTAINING  TO  THE
C             CHAOTIC-DIVERGENCE CONDITION DETECTED IN THE  PREVIOUS
C             ITERATION. THE NEXT INTERATION WILL BE TERMINAL.
C=======================================================================
C
                  WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                  1H*,1X,''CHAOTIC  DIVERGENCE'',
     *                         '' DETECTED, ITERATIO'',
     *                         ''N FOR THIS DATA SET'',
     *                         '' IS BEING  ABORTED '',1H*,/,
     *                  1H*,77X,1H*,/,79(1H*),/)')
C
                  TERMNT=.TRUE.
C
              ELSE
C
C=======================================================================
C             HERE WE DEAL WITH  THE  SITUATION  PERTAINING  TO  THE
C             CHAOTIC-DIVERGENCE CONDITION NOT YET DETECTED  IN  THE
C             PREVIOUS ITARATION. IF IT IS DETECTED NOW,  WE  SHOULD
C             CONTINUE AS IF NOTHING HAPPENED  BECAUSE  IN  THE  THE
C             NEXT INTERATION WE HAVE TO CALCULATE THE
C             S I N G L E - P A R T I C L E      P R O P E R T I E S
C=======================================================================
C
                  CALL CHAODI(IS_CHA,ITERUN,NUCHAO)
C
              END IF
C
          END IF
C
          GO TO 1
C
      ELSE
C
          IF (IS_CON.EQ.1) THEN
C
              WRITE(NFIPRI,'(//,79(1H*),/,1H*,77X,1H*,/,
     *          ''*  WARNING! ITERATION WAS ABORTED BECAUSE '',
     *          ''OF THE "CONSTANT STABILITY CONDIT"  *'',/,
     *          ''*  WARNING! ITERATION WAS ABORTED BECAUSE '',
     *          ''OF THE "CONSTANT STABILITY CONDIT"  *'',/,
     *            1H*,77X,1H*,/,79(1H*),/,1H*,77X,1H*)')
C
          END IF
C
          IF (IS_PIN.EQ.1) THEN
C
              WRITE(NFIPRI,'(//,79(1H*),/,1H*,77X,1H*,/,
     *          ''*  WARNING! ITERATION WAS ABORTED BECAUSE '',
     *          ''OF THE "PING-PONG"-TYPE DIVERGENCE  *'',/,
     *          ''*  WARNING! ITERATION WAS ABORTED BECAUSE '',
     *          ''OF THE "PING-PONG"-TYPE DIVERGENCE  *'',/,
     *            1H*,77X,1H*,/,79(1H*),/,1H*,77X,1H*)')
C
              IF (IPNMIX.NE.1) THEN
C
                  IF (ISIMPY.EQ.1) THEN
C
                      IF (ISIGNY.EQ.1) THEN
C
                          CALL FLISIG(MREVER)
                      ELSE
                          CALL FLISIM(MREVER)
C
                      END IF
C
                  ELSE
C
                      IF (ISIQTY.EQ.1) THEN
C
                          CALL FLISIQ
                      ELSE
                          CALL FLISIZ
C
                      END IF
C
                  END IF
C
              ELSE
C
                  IF (ISIMPY.EQ.1) THEN
C
                      IF (ISIGNY.EQ.1) THEN
C
                          CALL FLIMIG(MREVER)
                      ELSE
                          CALL FLIMIM(MREVER)
C
                      END IF
C
                  ELSE
C
                      IF (ISIQTY.EQ.1) THEN
C
                          CALL FLIMIQ
                      ELSE
                          CALL FLIMIZ
C
                      END IF
C
                  END IF
C
              END IF
C
          END IF
C
          IF (IS_CHA.EQ.1) THEN
C
              WRITE(NFIPRI,'(//,79(1H*),/,1H*,77X,1H*,/,
     *          ''*   WARNING! ITERATION WAS ABORTED BECAUSE'',
     *          '' OF THE "C H A O T I C" DIVERGENCE  *'',/,
     *          ''*   WARNING! ITERATION WAS ABORTED BECAUSE'',
     *          '' OF THE "C H A O T I C" DIVERGENCE  *'',/,
     *            1H*,77X,1H*,/,79(1H*),/,1H*,77X,1H*)')
C
          END IF
C
          CALL CNVRGE(ESTABN,EPSITE,IS_YES,ITERUN,NULAST,
     *                              EPSCON,IS_CON,NUCONS)
C
          IF (IS_YES.NE.1.AND.EPSITE.GT.0.0.AND.
     *                        NUMITE.GE.ITESTO) THEN
C
              WRITE(NFIPRI,'(//,79(1H*),/,1H*,77X,1H*,/,
     *              ''* WARNING! THE STABILITY REQUIRED WAS NOT '',
     *              ''ACHIEVED. NO-OF-ITERATIONS EXCEEDED *'',/,
     *              ''* WARNING! THE STABILITY REQUIRED WAS NOT '',
     *              ''ACHIEVED. NO-OF-ITERATIONS EXCEEDED *'',/,
     *                1H*,77X,1H*,/,79(1H*),/,1H*,77X,1H*)')
C
          END IF
C
C=======================================================================
C         STORING THE REVIEW OF RESULTS FOR THIS DATA SET
C=======================================================================
C
C
          IF (ABS(IREVIE).GE.8.AND.ITWCEN.EQ.2)
     *    CALL TWC_REVDEN(ISIMTX,JSIMTY,ISIMTZ,
     *            ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,
     *                                 MIN_QP,IPNMIX,
     *                   ITIREP,PRINIT,IDEVAR,ITERUN,
     *            ISYMDE,INIROT,INIINV,INIKAR,ITWCEN)
C
          IF (IREVIE.NE.0)
     *        CALL REVIEW(NFIREV,VERSIO,IN_FIX,IZ_FIX,
     *                           SKYRME,GOGNAM,ISTAND,
     *             KETA_J,KETA_W,KETACM,KETA_M,KETA_P,KETA_T,KETAPA,
     *                                         NOZEPA,
     *             JETA_J,JETA_W,JETACM,JETA_M,JETA_P,JETA_T,JETAPA,
     *                                  ITWOLI,KETA_R,
     *             LANODD,LANSCA,HBMSAT,RHOSAT,EFFSAT,
     *                    NMUMAX,NMUCON,NMUCOU,NMUPRI,
     *                                  ICOUMD,ICOUMX,
     *                    ISCHIF,NSIMAX,NSICON,NSIPRI,
     *                    NMAMAX,NMACON,NMAPRI,NMAORD,
     *                    NASMAX,NASCON,NASPRI,NASORD,
     *                                         NRAORD,
     *                    NMURED,NMARED,NASRED,NSIRED,
     *                           LAMMAX,NOSCIL,NLIMIT,
     *                    DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                    FERFIN,FERFIP,IFEFIN,IFEFIP,
     *                    FE2FIN,FE2FIP,IF2FIN,IF2FIP,
     *                    FERALN,FERALP,IFERAN,IFERAP,
     *                                         NUQEVE,
     *                    INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *                    INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                           INSIMN,IRSIMN,IDSIMN,
     *                           INSIMP,IRSIMP,IDSIMP,
     *                           INSIQN,IPSIQN,IDSIQN,
     *                           INSIQP,IPSIQP,IDSIQP,
     *                                  INSIZN,IDSIZN,
     *                                  INSIZP,IDSIZP,
     *                                  IFIBLN,INIBLN,
     *                                  IFIBLP,INIBLP,
     *                                  IQUNIL,NILXYZ,
     *                           ECUTOF,LIMQUA,LAMCUT,
     *                                         IPOTHO,
     *             IPAIRI,IPAHFB,ITWOBA,JPABCS,IMFHFB,
     *                                  LIPKIN,LIPKIP,
     *                                  LIPNON,LIPNOP,
     *             IROTAT,ITIREP,IREVIE,IQPSTA,MREVER,
     *                    FILREP,FILREC,FILWOO,
     *                    FILREV,FILCOU,FILWAV,FILKER,
     *                    FILYUP,FILYUC,
     *                    FILGOP,FILGOC,
     *                    FILGPP,FILGPC,
     *                    FILROP,FILROC,
     *                    FILLIP,FILLIC,
     *                    FILFIP,FILFIC,
     *                    FILQUA,FILRED,
     *                    FILBAP,FILBAC,
     *                    CMSXFC,CMSYFC,CMSZFC,
     *                    XMOMFC,YMOMFC,ZMOMFC,
     *                    EPSHER,
     *                    ICOMIX,INLKER,INRKER,
     *                    ICMPRI,IN_EXC,EPSMIX,
     *                           ISOADD,NBTKNT,
     *                    HOMEGA,FCHOM0,ENECUT,
     *                    CVOLFC,R0PARM,
     *                                  ISOTRO,
     *                    NUMCOU,NUMETA,FURMAX,
     *                    ICOTYP,ICOUDI,ICOUEX,
     *             PIMASS,PNMASS,IYUTYP,I_YUKA,
     *             YUKAGT,YUKAG0,YUKAG1,YUKAG2,
     *                           I_GOGA,IGOGPA,
     *                           I_REGA,IREGPA,
     *                           I_SEPA,ISEPPA,
     *                           I_COUA,ICOUPA,
     *                    N3LORD,N3SERD,IDOTHC,
     *                    ISPHER,ISIMPY,ISIGNY,
     *                           IPARTY,ISIQTY,
     *                    ISIMTX,JSIMTY,ISIMTZ,
     *             NULAST,EPSITE,NUCONS,EPSCON,
     *                    INIROT,INIINV,INIKAR,
     *                    NUCHAO,NUPING,EPSPNG,
     *                    ICHFLI,IPAFLI,IREFLI,
     *                    ISPFLI,ISHFLI,IFLIPI,
     *             SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                           I_SLOW,SLOWAL,
     *             SLOWLD,SLOWTP,SLOWRP,SLOWLM,
     *             IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                    IS_YES,IS_PIN,IS_CHA,
     *      NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,
     *      NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,
     *                           LASTAN,LASTAP,
     *                    IAXIAP,KAPASY,INUNIL,
     *                                  ITWCEN)
C
C=======================================================================
C         HERE ENDS THE SUCCESSFUL CALCULATION STEP
C=======================================================================
C
          WRITE(NFIPRI,'(79(1H*),/,             1H*,77X,1H*,/,
     *             1H*,2X,''CALCULATION OF THE DATA SET NO.'',
     *                 I3,'' HAS BEEN SUCCESSFULLY COMPLETED'',
     *                                           9X,1H*,/,
     *                                      1H*,77X,1H*,/,
     *                                          79(1H*),/)')
     *
     *                                           NUDATA
C
C=======================================================================
C         DEALLOCATING BIG ARRAYS ALLOCATED IN ALLODE,  ALLORH,  ALLOKA,
C         AND ALLOVF
C=======================================================================
C
          CALL DEALDE
          CALL DEALVF
C
C=======================================================================
          JUMFIT=0
#if(USE_FITS==1)
          CALL FITOUT(PAROUT,NUMOUT)
          CALL CPUTIM('HFODD ', 0)
          JUMFIT=1
#endif
C=======================================================================
C         THE FOLLOWING "GO TO 3" CORRESPONDS TO A NEW READ "NAMELI"
C=======================================================================
C
#if(USE_MPI==0)
          IF (JUMFIT.EQ.0) GO TO 3
#endif
C
      END IF ! end of TERMNT.EQ.TRUE
C
C=======================================================================
C         GATHERING EXECUTION TIMES FROM ALL PROCESSORS AND
C         CLOSING MPI ENVIRONMENT
C=======================================================================
C
#if(USE_MPI==1)
C
               NUDATA=NUDATA+1
C
C               Move back to the next point in the batch sequence
               IF (NUDATA.GT.number_batch) EXIT
C
            END DO ! end DO (NUDATA<=number_batch)
C
            ! Properly close all files that could have been left
            ! opened (with the exclusion of the output unit NFIPRI)
            CALL IOCLOS(NFIWOO,NFIREP,NFIREV,NFIREC,NFICOU,NFIWAV,
     *                  NFIKER,NFIYUP,NFIYUC,NFIGOC,NFIGOP,NFIGPC,
     *                  NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *                  NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP)
C
            ! In batch mode, copy all common restart/rec files in from the
            ! ./restart/ directory to the ./rec/ directory
            IF (batch_mode.EQ.1) THEN
                Write(optimal,'("./restart/HFODD_",I8.8,".REC")')
     *                INDFIL
                Write(optimal,'("./rec/HFODD_",I8.8,".REC")')
     *                INDFIL
                commande = 'cp '//Trim(optimal)//' '//Trim(courant)
                Call system(commande)
            END IF
C
         END IF ! end of 'if (worldRank.eq.mod(...))'
C
      END DO procLoop ! end of job loop (name: procLoop)
C
      ! Switching off the time counters
      CALL CPUTIM('HFODD ',0)
C
      ! Printing all times by local routines
      CALL TIMPRI
C
      CALL DATE_AND_TIME(MYDATE,MYTIME,MYZONE,MYVALU)
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,2X,
     *      ''EXECUTION ENDS ON '',A4,''.'',A2,''.'',A2,'' AT '',
     *                               A2,'':'',A2,'':'',A6,
     *                              31X,1H*,/,1H*,77X,1H*,/,79(1H*))')
     *
     *      MYDATE(1:4),MYDATE(5:6),MYDATE(7:8),
     *      MYTIME(1:2),MYTIME(3:4),MYTIME(5:10)
C
      ! closing the unit containing the output file
      CLOSE(NFIPRI)
C
      ! Record system and CPU starting times
      call cpu_time(cput_end)
      call system_clock(syst_cnt, syst_rate)
      syst_end = real(syst_cnt)
     *         / real(syst_rate)
C
      my_evals(0) = counter_eval
      my_cputime(0) = cput_end  - cput_start
C
      call mpi_gather(my_evals, 1, MPI_INTEGER, all_evals, 1,
     *                MPI_INTEGER, 0, MPI_COMM_WORLD, mpi_err)
C
      if (mpi_err .NE. 0) then
          if ( worldRank == 0 ) then
              write(nfisum,'(''Error when gathering evaluations '',
     *                       ''counters'')')
              write(nfisum,'(''Error code: mpi_err = '',i12)') mpi_err
          end if
      end if
C
      call mpi_gather(my_cputime, 1, MPI_DOUBLE_PRECISION, all_cputimes,
     *                            1, MPI_DOUBLE_PRECISION,
     *                            0, MPI_COMM_WORLD, mpi_err)
C
      if (mpi_err .NE. 0) then
          if ( worldRank == 0 ) then
              write(nfisum,'(''Error when gathering CPU times'')')
              write(nfisum,'(''Error code: mpi_err = '',i12)') mpi_err
          end if
      end if
C
      deallocate(my_cputime, my_evals)
C
      if ( worldRank == 0 ) then
C
          write(nfisum,'(''  Rank     Evals  CPU time'')')
          write(nfisum,'(28(''-''))')
C
          do mpi_rank = 0, worldSize-1
             write(nfisum,'(1x,i7,i10,f10.3)')
     *             mpi_rank, all_evals(mpi_rank),
     *                       all_cputimes(mpi_rank)
          end do
          write(nfisum,'(''System time = '',F20.14)')
     *                     syst_end - syst_start
C
          close(nfisum)
C
          ! In batch mode, we remove the restart directory, the content
          ! of which has been copied to rec/, and rename our backup
          ! directory. At the end, we thus have the following structure:
          !  - ./rec/ contains all record files
          !  - ./restart/ contains the restart files associated with each
          !    of the record files in rec/
          !  - ./restart_old/ contains the original set of restart files.
          IF (batch_mode.EQ.1) THEN
              commande = 'rm -rf restart'
              Call system(commande)
              commande = 'mv restart_tmp restart'
              Call system(commande)
          END IF
C
      end if
C
C=======================================================================
C         CLOSING MPI ENVIRONMENT
C=======================================================================
C
      CALL mpi_barrier(MPI_COMM_WORLD, mpi_err)
C
#if(USE_SCALAPACK==1)
      CALL BLACS_EXIT(1)
#endif
C
      ! Close MPI environment
      CALL mpi_finalize(mpi_err)
C
#endif
C
      END
C
C=======================================================================
C
      SUBROUTINE PROANG(IPROAN,
     *                  ISIMTX,JSIMTY,ISIMTZ,
     *                  ISIGNY,ISIMPY,ISIQTY,
     *           IPAHFB,IROTAT,ITIREP,MREVER,
     *                                IPNMIX,
     *                         IDEVAR,ITERUN,
     *                         NMUCOU,ISHIFY,
     *           INLWAV,INRWAV,ICOMIX,EPSMIX,
     *           INDBRA,INDKET,KONMIX,ICMPRI,
     *           IDIAGO,IDIMUR,IPROMI,IPROMA,
     *                  NATKNO,NBTKNO,ISOSTZ,
     *           NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *           ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *           NUAKNO,NUBKNO,KPROJE,KPLEFT,
     *                  ILFWAV,IRGWAV,IWRWAV,
     *           ISAKER,ICHKER,NFIKER,FILKER,
     *           IPAKER,IPAK3D,IPAALL,KFIKER,
     *           NUASTA,NUASTO,NUGSTA,NUGSTO,
     *           NATSTA,NATSTO,NGTSTA,NGTSTO,
     *           NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *           NMUMAX,NMAMAX,NSIMAX,NASMAX,
     *                         NMAORD,NASORD,
     *    ISCHIF,NMURED,NMARED,NASRED,NSIRED,
     *                  ICUTOV,CUTOVE,CUTOVF,
     *                  IONISH,ISLPRI,ISUPRI,
     *                  IENPRI,ISRPRI,IMIPRI,
     *                  IKEPRI,IRMPRI,IELPRI,
     *                         IWRIRM,NFIRED,
     *           QMUCUT,QMACUT,QASCUT,QSICUT,
     *                         NUMCOU,BOUCOU,
     *                  ICOTYP,ICOUDI,ICOUEX,
     *                                IDOTHC,
     *           ISYMDE,INIROT,INIINV,INIKAR,
     *                         ISAWAV,IKERNE,
     *                                IBETME,
     *                         NFIWAV,FILWAV,
     *                         I_SLOW,SLOWEV,
     *                         NEWGOG,NEWCOU,
     *           I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                         I_SEPA,ISEPPA,
     *                         I_COUA,ICOUPA,
     *                         N3LORD,N3SERD,
     *                         LDPNMX,MIN_QP,
     *                         IN_FIX,IZ_FIX,
     *                  NFIFER,FILFER,N_CALL,
     *                         ISOADD,NBTKNT,
     *                         JETACM,KETA_R,
     *                         KETAJ2,KETAT2,
     *                         IDSIQN,IDSIQP,
     *                         IDSIZN,IDSIZP,
     *    NMRMIX,LMRMIX,NMURMI,LMURMI,I_PASS,
     *                         ISWIND,NUANGU,
     *                         IVIPRI,ITWCEN)
C
C=======================================================================
      USE SAVLEF
      USE SAVRIG
      USE WAVR_L
      USE REDMOM
      USE COUMOM
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE OVRHFB
      USE BLOSAV
      USE TXXX_Y
      USE HAMMIX
      USE MURMIX
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
      PARAMETER (NDCOLE=1)
      PARAMETER (NDF2BC=5)
C=======================================================================
      CHARACTER
     *          FILKER*68,FILWAV*68,FILACT*83,FILINP*83,FILFER*68
      CHARACTER
     *          FILLEF*68,FILRIG*68
      CHARACTER
     *          FILAC2*149,FILIN2*149,FILHE2*15
      CHARACTER
     *          NAMEPN*8
      CHARACTER
     *          CHALF_*2
      CHARACTER
     *          NAMMUL*45,NAMSUR*45,NAMSCH*45,NAMMAG*45,NAMMAR*45,
     *                                        NAMASM*45,NAMASR*45
      CHARACTER
     *          NAMWRK*45
      CHARACTER
     *          HAFLIN*38
      CHARACTER
     *          LINE_0*1,LINE_1*1,LINE_2*1,LINE_3*1
      CHARACTER
     *          REEFIC*9
C
      LOGICAL
     *          PRINIT
      LOGICAL
     *          BORROT
C
      COMPLEX
     *          SOURCE
      COMPLEX
     *          Q00T,Q10T,Q1PT,Q1MT
      COMPLEX
     *          EKEKIN,EKEPAI,EKESKY,EKECOD,EKECOE,EKESCA,EKEVEC,EKEGOG,
     *          EKEREG,EKESEP
      COMPLEX
     *          OVRLAP
      COMPLEX
     *          AUXDIA,C_ZERO,C_UNIT,UNIT_I
      COMPLEX
     *          DETWRK
      COMPLEX
     *          WARAUX,TARIGH,TALEFT
      COMPLEX
     *          CD0000,CD0010,CD001P,CD001M,CD1010,CD101P,
     *                        CD101M,CD1P1M,CD1P1P,CD1M1M,
     *          CX0000,CX0010,CX001P,CX001M,CX1010,CX101P,
     *                        CX101M,CX1P1M,CX1P1P,CX1M1M
      COMPLEX
     *          QPKERN,ATKERN,WTKERN,SPKERN
      COMPLEX
C TER*          TEKERN,
     *          OVKERN,SKKERN,EKKERN,EPKERN,
     *          CDKERN,CDKE10,CDKE1P,
     *          CXKERN,CXKE10,CXKE1P,
     *          CDKE1M,CDKE20,CDK21P,
     *          CDK21M,CDK22P,CDK22M,
     *          CXKE1M,CXKE20,CXK21P,
     *          CXK21M,CXK22P,CXK22M,
     *          PNKE00,PNKE10,PNKE1P,PNKE1M,
     *          TZKERN,T2KERN,
     *          BZKERN,B2KERN
      COMPLEX
C TER*          TETERN,
     *          OVTERN,SKTERN,EKTERN,EPTERN,
     *          CDTERN,CDTE10,CDTE1P,
     *          CXTERN,CXTE10,CXTE1P,
     *          CDTE1M,CDTE20,CDT21P,
     *          CDT21M,CDT22P,CDT22M,
     *          CXTE1M,CXTE20,CXT21P,
     *          CXT21M,CXT22P,CXT22M,
     *          PNTE00,PNTE10,PNTE1P,PNTE1M,
     *          TZTERN,T2TERN,
     *          BZTERN,B2TERN
      COMPLEX
     *          FACINT,FACI1P,FACI1M,FACI2P,FACI2M,
     *          FACMOM
      COMPLEX
     *          QMUT_N,QMUT_P,QMUT_T
      COMPLEX
     *          AMUT_N,AMUT_P,AMUT_T
      COMPLEX
     *          WMUT_N,WMUT_P,WMUT_T
      COMPLEX
     *          SMUT_N,SMUT_P,SMUT_T
      COMPLEX
     *          A2BCIN,A2BCSA
      COMPLEX
     *          EPROJE,OPROJE
      COMPLEX
     *          ZMUL_P,ZMAG_T,ZASM_T,ZSIF_P
      COMPLEX
C TER*          UTER_T,
     *          UKER_T,USKY_T,UKIN_N,UKIN_P,UCOU_D,UCOU_X,
     *                 UPAI_N,UPAI_P,UC10_D,UC1P_D,UC1M_D,
     *                               UC10_X,UC1P_X,UC1M_X,
     *                               UC20_D,UC21PD,UC21MD,UC22PD,UC22MD,
     *                               UC20_X,UC21PX,UC21MX,UC22PX,UC22MX,
     *                               UPNU00,UPNU10,UPNU1P,UPNU1M,
     *                               UTZISO,UT2ISO,UBZROT,UB2ROT
      COMPLEX
C TER*          WTER_T,
     *          WKER_T,WSKY_T,WKIN_N,WKIN_P,WCOU_D,WCOU_X,
     *                 WPAI_N,WPAI_P,WC10_D,WC1P_D,WC1M_D,
     *                               WC10_X,WC1P_X,WC1M_X,
     *                               WC20_D,WC21PD,WC21MD,WC22PD,WC22MD,
     *                               WC20_X,WC21PX,WC21MX,WC22PX,WC22MX,
     *                               WPNU00,WPNU10,WPNU1P,WPNU1M,
     *                               WTZISO,WT2ISO,WBZROT,WB2ROT
      COMPLEX
C TER*          CTER_T,
     *          CKER_T,CSKY_T,CKIN_N,CKIN_P,CCOU_D,CCOU_X,CMUL_P,CMAG_T,
     *                                                           CASM_T,
     *          CPAI_N,CPAI_P,CSIF_P,CC10_D,CC1P_D,CC1M_D,
     *                               CC10_X,CC1P_X,CC1M_X,
     *                               CC20_D,CC21PD,CC21MD,CC22PD,CC22MD,
     *                               CC20_X,CC21PX,CC21MX,CC22PX,CC22MX,
     *                               CPNU00,CPNU10,CPNU1P,CPNU1M,
     *                               CTZISO,CT2ISO,CBZROT,CB2ROT
      COMPLEX
     *          TMUL_P,TMAG_T,TASM_T,TSIF_P
      COMPLEX
     *          RKER_T,RSKY_T,RKIN_T,RCOU_D,RCOU_X,RPAI_T,
     *          RMUL_P,RMAG_T,RASM_T,RSIF_P,
     *          RPARTN,RISOSP,
     *          RTZISO,RT2ISO,
     *          RBZROT,RB2ROT
      COMPLEX
     *          BNN_PP,BNN_PM,BNP_PP,BNP_PM,
     *          BPP_PP,BPP_PM,BPN_PP,BPN_PM
      COMPLEX
     *          DKINSQ
C     COMPLEX
C    *          ECC_NP,ECCALL
      COMPLEX
     *          F_KT_L,F_KT_R,OCNMIX,HCNMIX,CODMIX,COXMIX,OVEMIX,ESKMIX
      COMPLEX
     *          TKEISO,TKEIS2
      COMPLEX
     *          PREPFA,TREPFA,PFAWRK,
     *          BTAPLF,BTAPRG,TBTALF,TBTARG,
     *          WARITP
      COMPLEX
     *          PREONI,TREONI,ONIWRK
      COMPLEX
     *          DKOTSN,DKOTSP,DKOTST,
     *          EKOTSN,EKOTSP,EKOTST,
     *          PKOTSN,PKOTSP,PKOTST,
     *          TKOTSN,TKOTSP,TKOTST,
     *          AKOTLN,AKOTLP,AKOTLT,
     *          PKOTLN,PKOTLP,PKOTLT,
     *          PKOTKN,PKOTKP,PKOTKT
      COMPLEX
     *          FACGAP,FACOVT,FACOVR(0:NDISOS)
      COMPLEX
     *          DENSIC,DENCHC,DENSIU
      COMPLEX
     *          QMRMIY,AMRMIY,WMRMIY,SMRMIY
C
C=======================================================================
C          ATTENTION!  BEGINNING WITH VERSION 2.54N, PARAMETER  "NDPROT"
C                      ACQUIRES MODIFIED MEANING, NAMELY, IT NOW DENOTES
C                      THE  MAXIMUM  ALLOWED  VALUE  OF  THE   PROJECTED
C                      ISOSPIN. NOTE THAT  PARAMETER  "NDPROT"  MUST  BE
C                      PROPERLY SET IN ACCORDANCE WITH THE ACTUAL  VALUE
C                      OF ISOSMA, EVEN IF IN  A  GIVEN  RUN  NO  ISOSPIN
C                      PROJECTION IS PERFORMED.
C                      NOTE ALSO THAT BEFORE THE FULL TRANSITION TO  THE
C                      NEW MEANING  IS  FULLY  IMPLEMENTED,  THE  LOWEST
C                      ALLOWED VALUE IS NDPROT=1.
C=======================================================================
C
      DIMENSION
     *          HAMEIG(1:NDPROT)
      DIMENSION
     *          LINE_0(NUMCOL+1),LINE_1(NUMCOL+1),
     *          LINE_2(NUMCOL+1),LINE_3(NUMCOL+1)
C
C=======================================================================
      ALLOCATABLE BNN_PP(:,:,:)
      ALLOCATABLE BNN_PM(:,:,:)
      ALLOCATABLE BNP_PP(:,:,:)
      ALLOCATABLE BNP_PM(:,:,:)
      ALLOCATABLE BPP_PP(:,:,:)
      ALLOCATABLE BPP_PM(:,:,:)
      ALLOCATABLE BPN_PP(:,:,:)
      ALLOCATABLE BPN_PM(:,:,:)
C=======================================================================
      ALLOCATABLE OVRLAP(:,:)
      ALLOCATABLE WARAUX(:,:)
      ALLOCATABLE TARIGH(:,:,:)
      ALLOCATABLE TALEFT(:,:,:)
C=======================================================================
      DIMENSION
     *          AUXDIA(1:4*NDSTAT),IAUXDI(1:4*NDSTAT)
      DIMENSION
     *          DETWRK(2)
C
      COMMON /KNOTS/
     *          XA_PNT(1:NDAKNO),XA_WGT(1:NDAKNO),
     *          XB_PNT(1:NDBKNO),XB_WGT(1:NDBKNO),
     *          XAT_PN(1:NDATKN),XAT_WG(1:NDATKN),
     *          XBT_PN(1:NDBTKN),XBT_WG(1:NDBTKN)
      COMMON /GKNOTS/
     *          XG_PNT(1:NDGAUG),XG_WGT(1:NDGAUG),
     *                           XP_WGT(1:     2)
      COMMON /TKNOTS/
     *          XT_PNT(1:NDGAUG),XT_WGT(1:NDGAUG)
      DIMENSION
     *          ISALGA(1:NDAKNO,1:NDAKNO),
     *          IS_ISO(1:NDATKN,1:NDBTKN),
     *          IS_PRO(1:NDAKNO,1:NDAKNO),
     *          ISAALL(1:NDAKNO,1:NDBKNO,1:NDAKNO,1:NDBTKN),
     *          ISPOIN(1:NDAKNO,1:NDBKNO,1:NDAKNO,
     *                 1:NDATKN,1:NDBTKN,1:NDATKN)
      DIMENSION
     *          HAFLIN(2)
      DIMENSION
     *          KPAHFB(0:NDISOS)
C=======================================================================
C --> PFAFFIAN/ONISHI
      DIMENSION
     *          IDSIZN(1:NDBLOC),
     *          IDSIZP(1:NDBLOC),
     *          LDBLOR(0:NDISOS)
      DIMENSION
     *          IDSIQN(1:NDBLOC),
     *          IDSIQP(1:NDBLOC)
      DIMENSION
     *          IBLQPL(0:1,1:NDBLOC),IBLQPR(0:1,1:NDBLOC)
      DIMENSION
     *          PREPFA(2),PFAWRK(2),TREPFA(2,0:NDISOS)
      DIMENSION
     *          PREONI(2),ONIWRK(2),TREONI(2,0:NDISOS)
      ALLOCATABLE
     *          BTAPLF(:,:),BTAPRG(:,:),TBTALF(:,:,:),TBTARG(:,:,:)
      ALLOCATABLE
     *          WARITP(:,:,:)
C=======================================================================
C --> OVERLAP, SKYRME, AND KINETIC ENRGY KERNELS:
      ALLOCATABLE QPKERN(:,:,:,:)
      ALLOCATABLE ATKERN(:,:,:,:,:)
      ALLOCATABLE WTKERN(:,:,:,:,:)
      ALLOCATABLE SPKERN(:,:,:,:)
C
      ALLOCATABLE TMUL_P(:,:)
      ALLOCATABLE TMAG_T(:,:,:)
      ALLOCATABLE TASM_T(:,:,:)
      ALLOCATABLE TSIF_P(:,:)
C
C TER ALLOCATABLE TEKERN(:,:,:,:,:,:,:)
      ALLOCATABLE OVKERN(:,:,:,:,:,:)
      ALLOCATABLE SKKERN(:,:,:,:,:,:)
      ALLOCATABLE EKKERN(:,:,:,:,:,:)
C
      ALLOCATABLE EPKERN(:,:,:,:,:,:)
C
      ALLOCATABLE CDKERN(:,:,:,:,:,:)
      ALLOCATABLE CDKE10(:,:,:,:,:,:)
      ALLOCATABLE CDKE1P(:,:,:,:,:,:)
      ALLOCATABLE CDKE1M(:,:,:,:,:,:)
      ALLOCATABLE CDKE20(:,:,:,:,:,:)
      ALLOCATABLE CDK21P(:,:,:,:,:,:)
      ALLOCATABLE CDK21M(:,:,:,:,:,:)
      ALLOCATABLE CDK22P(:,:,:,:,:,:)
      ALLOCATABLE CDK22M(:,:,:,:,:,:)
      ALLOCATABLE CXKERN(:,:,:,:,:,:)
      ALLOCATABLE CXKE10(:,:,:,:,:,:)
      ALLOCATABLE CXKE1P(:,:,:,:,:,:)
      ALLOCATABLE CXKE1M(:,:,:,:,:,:)
      ALLOCATABLE CXKE20(:,:,:,:,:,:)
      ALLOCATABLE CXK21P(:,:,:,:,:,:)
      ALLOCATABLE CXK21M(:,:,:,:,:,:)
      ALLOCATABLE CXK22P(:,:,:,:,:,:)
      ALLOCATABLE CXK22M(:,:,:,:,:,:)
      ALLOCATABLE PNKE00(:,:,:,:,:,:)
      ALLOCATABLE PNKE10(:,:,:,:,:,:)
      ALLOCATABLE PNKE1P(:,:,:,:,:,:)
      ALLOCATABLE PNKE1M(:,:,:,:,:,:)
      ALLOCATABLE TZKERN(:,:,:,:,:,:)
      ALLOCATABLE T2KERN(:,:,:,:,:,:)
      ALLOCATABLE BZKERN(:,:,:,:,:,:)
      ALLOCATABLE B2KERN(:,:,:,:,:,:)
C=======================================================================
C TER ALLOCATABLE TETERN(:,:,:,:,:)
      ALLOCATABLE OVTERN(:,:,:,:)
      ALLOCATABLE SKTERN(:,:,:,:)
      ALLOCATABLE EKTERN(:,:,:,:)
C
      ALLOCATABLE EPTERN(:,:,:,:)
C
      ALLOCATABLE CDTERN(:,:,:,:)
      ALLOCATABLE CDTE10(:,:,:,:)
      ALLOCATABLE CDTE1P(:,:,:,:)
      ALLOCATABLE CDTE1M(:,:,:,:)
      ALLOCATABLE CDTE20(:,:,:,:)
      ALLOCATABLE CDT21P(:,:,:,:)
      ALLOCATABLE CDT21M(:,:,:,:)
      ALLOCATABLE CDT22P(:,:,:,:)
      ALLOCATABLE CDT22M(:,:,:,:)
      ALLOCATABLE CXTERN(:,:,:,:)
      ALLOCATABLE CXTE10(:,:,:,:)
      ALLOCATABLE CXTE1P(:,:,:,:)
      ALLOCATABLE CXTE1M(:,:,:,:)
      ALLOCATABLE CXTE20(:,:,:,:)
      ALLOCATABLE CXT21P(:,:,:,:)
      ALLOCATABLE CXT21M(:,:,:,:)
      ALLOCATABLE CXT22P(:,:,:,:)
      ALLOCATABLE CXT22M(:,:,:,:)
      ALLOCATABLE PNTE00(:,:,:,:)
      ALLOCATABLE PNTE10(:,:,:,:)
      ALLOCATABLE PNTE1P(:,:,:,:)
      ALLOCATABLE PNTE1M(:,:,:,:)
      ALLOCATABLE TZTERN(:,:,:,:)
      ALLOCATABLE T2TERN(:,:,:,:)
      ALLOCATABLE BZTERN(:,:,:,:)
      ALLOCATABLE B2TERN(:,:,:,:)
C=======================================================================
C TER ALLOCATABLE CTER_T(:,:,:,:)
      ALLOCATABLE CKER_T(:,:,:)
      ALLOCATABLE CSKY_T(:,:,:)
      ALLOCATABLE CKIN_N(:,:,:)
      ALLOCATABLE CKIN_P(:,:,:)
C
      ALLOCATABLE CPAI_N(:,:,:)
      ALLOCATABLE CPAI_P(:,:,:)
C
      ALLOCATABLE CCOU_D(:,:,:)
      ALLOCATABLE CC10_D(:,:,:)
      ALLOCATABLE CC1P_D(:,:,:)
      ALLOCATABLE CC1M_D(:,:,:)
      ALLOCATABLE CC20_D(:,:,:)
      ALLOCATABLE CC21PD(:,:,:)
      ALLOCATABLE CC21MD(:,:,:)
      ALLOCATABLE CC22PD(:,:,:)
      ALLOCATABLE CC22MD(:,:,:)
      ALLOCATABLE CCOU_X(:,:,:)
      ALLOCATABLE CC10_X(:,:,:)
      ALLOCATABLE CC1P_X(:,:,:)
      ALLOCATABLE CC1M_X(:,:,:)
      ALLOCATABLE CC20_X(:,:,:)
      ALLOCATABLE CC21PX(:,:,:)
      ALLOCATABLE CC21MX(:,:,:)
      ALLOCATABLE CC22PX(:,:,:)
      ALLOCATABLE CC22MX(:,:,:)
      ALLOCATABLE CPNU00(:,:,:)
      ALLOCATABLE CPNU10(:,:,:)
      ALLOCATABLE CPNU1P(:,:,:)
      ALLOCATABLE CPNU1M(:,:,:)
      ALLOCATABLE CTZISO(:,:,:)
      ALLOCATABLE CT2ISO(:,:,:)
      ALLOCATABLE CBZROT(:,:,:)
      ALLOCATABLE CB2ROT(:,:,:)
      ALLOCATABLE ZMUL_P(:,:,:)
      ALLOCATABLE ZMAG_T(:,:,:,:)
      ALLOCATABLE ZASM_T(:,:,:,:)
      ALLOCATABLE ZSIF_P(:,:,:)
      ALLOCATABLE CMUL_P(:,:,:)
      ALLOCATABLE CMAG_T(:,:,:,:)
      ALLOCATABLE CASM_T(:,:,:,:)
      ALLOCATABLE CSIF_P(:,:,:)
C
C=======================================================================
C
      DIMENSION
     *          RMUL_P(0:NDMULR,-NDMULR:NDMULR),
     *          RMAG_T(0:NDMULR,-NDMULR:NDMULR),
     *          RASM_T(0:NDMULR,-NDMULR:NDMULR),
     *          RSIF_P(0:NDMULR,-NDMULR:NDMULR)
      DIMENSION
     *          QDUM_P(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          ADUM_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *          ADUM_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      DIMENSION
     *          SDUM_P(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
C TER*          UTER_T(1:NDATKN,-NDPROT:NDPROT,2*NDCOUT),
     *          UKER_T(1:NDATKN,-NDPROT:NDPROT),
     *          USKY_T(1:NDATKN,-NDPROT:NDPROT),
     *          UKIN_N(1:NDATKN,-NDPROT:NDPROT),
     *          UKIN_P(1:NDATKN,-NDPROT:NDPROT),
C
     *          UPAI_N(1:NDATKN,-NDPROT:NDPROT),
     *          UPAI_P(1:NDATKN,-NDPROT:NDPROT),
C
     *          UCOU_D(1:NDATKN,-NDPROT:NDPROT),
     *          UC10_D(1:NDATKN,-NDPROT:NDPROT),
     *          UC1P_D(1:NDATKN,-NDPROT:NDPROT),
     *          UC1M_D(1:NDATKN,-NDPROT:NDPROT),
     *          UC20_D(1:NDATKN,-NDPROT:NDPROT),
     *          UC21PD(1:NDATKN,-NDPROT:NDPROT),
     *          UC21MD(1:NDATKN,-NDPROT:NDPROT),
     *          UC22PD(1:NDATKN,-NDPROT:NDPROT),
     *          UC22MD(1:NDATKN,-NDPROT:NDPROT),
     *          UCOU_X(1:NDATKN,-NDPROT:NDPROT),
     *          UC10_X(1:NDATKN,-NDPROT:NDPROT),
     *          UC1P_X(1:NDATKN,-NDPROT:NDPROT),
     *          UC1M_X(1:NDATKN,-NDPROT:NDPROT),
     *          UC20_X(1:NDATKN,-NDPROT:NDPROT),
     *          UC21PX(1:NDATKN,-NDPROT:NDPROT),
     *          UC21MX(1:NDATKN,-NDPROT:NDPROT),
     *          UC22PX(1:NDATKN,-NDPROT:NDPROT),
     *          UC22MX(1:NDATKN,-NDPROT:NDPROT),
     *          UPNU00(1:NDATKN,-NDPROT:NDPROT),
     *          UPNU10(1:NDATKN,-NDPROT:NDPROT),
     *          UPNU1P(1:NDATKN,-NDPROT:NDPROT),
     *          UPNU1M(1:NDATKN,-NDPROT:NDPROT),
     *          UTZISO(1:NDATKN,-NDPROT:NDPROT),
     *          UT2ISO(1:NDATKN,-NDPROT:NDPROT),
     *          UBZROT(1:NDATKN,-NDPROT:NDPROT),
     *          UB2ROT(1:NDATKN,-NDPROT:NDPROT)
      DIMENSION
C TER*          WTER_T(-NDPROT:NDPROT,-NDPROT:NDPROT,2*NDCOUT),
     *          WKER_T(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WSKY_T(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WKIN_N(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WKIN_P(-NDPROT:NDPROT,-NDPROT:NDPROT),
C
     *          WPAI_N(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WPAI_P(-NDPROT:NDPROT,-NDPROT:NDPROT),
C
     *          WCOU_D(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC10_D(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC1P_D(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC1M_D(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC20_D(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC21PD(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC21MD(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC22PD(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC22MD(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WCOU_X(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC10_X(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC1P_X(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC1M_X(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC20_X(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC21PX(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC21MX(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC22PX(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WC22MX(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WPNU00(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WPNU10(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WPNU1P(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WPNU1M(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WTZISO(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WT2ISO(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WBZROT(-NDPROT:NDPROT,-NDPROT:NDPROT),
     *          WB2ROT(-NDPROT:NDPROT,-NDPROT:NDPROT)
      COMMON
     *       /ALLENE/ EKIN_N,EKIN_P,EKIN_T,
     *                EPOT_N,EPOT_P,EPOT_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *                EREA_N,EREA_P,EREA_T,
     *                ELIP_N,ELIP_P,ELIP_T,
     *
     *                ECOULD,ECOULE,ECOULT,
     *                       ECOULS,ECOULV,
     *
     *                EMULCO,EMUSLO,EMUREA,
     *                ESIFCO,ESISLO,ESIREA,
     *                ESPICO,ESPSLO,ESPREA,
     *
     *                ENREAR,ECORCM,ECOR_R,
     *
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
C TER COMMON
C TER*       /ECCPNM/ ECC_NP(NDCOUT)
C TER COMMON
C TER*       /ECCSKY/ ECCALL(NDCOUT)
      COMMON
     *       /C_SOUR/ SOURCE(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /QMUTTI/ QMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /AMUTTI/ AMUT_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUT_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUT_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /AMULTI/ AMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /WMUTTI/ WMUT_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUT_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUT_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /WMULTI/ WMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /SMUTTI/ SMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /A2BCTI/ A2BCIN(-1:+1),A2BCSA(-1:+1)
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /SIFUNI/ SUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /ASMUNI/ BUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /RANGLE/ ALPROT,BETROT,GAMROT
      COMMON
     *       /RANISO/ ALPISO,BETISO,GAMISO
      COMMON
     *       /GANGLE/ PHIGAU
      COMMON
     *       /GTZANG/ PHI_TZ
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /APROJE/ EPROJE(NDPROM,NDISOM),OPROJE(NDPROM,NDISOM)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /CHARGE/ ECHAR2
      COMMON
     *       /EXCHAN/ COULEX
      COMMON
     *       /LDUNKI/ ECH2_O,COEX_O
      COMMON
     *       /PROIND/ IROMAT(NDPROM),LROMAT(NDPROM),KROMAT(NDPROM)
      COMMON
     *       /PREIND/ IREMAT(NDPROM),LREMAT(NDPROM),KREMAT(NDPROM)
      COMMON
     *       /ISOIND/ ISOMAT(NDISOM),LSOMAT(NDISOM),KSOMAT(NDISOM)
      COMMON
     *       /IMKIND/ INDIMK(0:NDPROI,-NDPROI:NDPROI,-NDPROI:NDPROI)
      COMMON
     *       /IMKRED/ IREIMK(0:NDPROI,-NDPROI:NDPROI,-NDPROI:NDPROI)
      COMMON
     *       /TMKIND/ INDTMK(0:NDPROT,-NDPROT:NDPROT,-NDPROT:NDPROT)
      COMMON
     *       /ISOTOK/ TKEISO(0:NDKART),TKEIS2(0:NDKART)
      COMMON
     *       /ISOTOT/ TOTISO(0:NDKART),TOTIS2(0:NDKART)
      COMMON
     *       /IKETRA/ IKEINV,IKEKAR
      COMMON
     *       /NEWIGN/ NEWWIG
      COMMON
     *       /ROTMOM/ DROTSN(0:NDKART),DROTSP(0:NDKART),DROTST(0:NDKART)
     *               ,EROTSN(0:NDKART),EROTSP(0:NDKART),EROTST(0:NDKART)
     *               ,TROTSN(0:NDKART),TROTSP(0:NDKART),TROTST(0:NDKART)
     *               ,AROTLN(0:NDKART),AROTLP(0:NDKART),AROTLT(0:NDKART)
      COMMON
     *       /KOTMOM/ DKOTSN(0:NDKART),DKOTSP(0:NDKART),DKOTST(0:NDKART)
     *               ,EKOTSN(0:NDKART),EKOTSP(0:NDKART),EKOTST(0:NDKART)
     *               ,TKOTSN(0:NDKART),TKOTSP(0:NDKART),TKOTST(0:NDKART)
     *               ,AKOTLN(0:NDKART),AKOTLP(0:NDKART),AKOTLT(0:NDKART)
      COMMON
     *       /ROTPAI/ PROTSN(0:NDKART),PROTSP(0:NDKART),PROTST(0:NDKART)
     *               ,PROTLN(0:NDKART),PROTLP(0:NDKART),PROTLT(0:NDKART)
     *               ,PROTKN(0:NDKART),PROTKP(0:NDKART),PROTKT(0:NDKART)
      COMMON
     *       /KOTPAI/ PKOTSN(0:NDKART),PKOTSP(0:NDKART),PKOTST(0:NDKART)
     *               ,PKOTLN(0:NDKART),PKOTLP(0:NDKART),PKOTLT(0:NDKART)
     *               ,PKOTKN(0:NDKART),PKOTKP(0:NDKART),PKOTKT(0:NDKART)
      COMMON
     *       /JPA2HF/ DEL2HF(0:NDISOS),IPA2HF(0:NDISOS)
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /FERMIL/ F_KT_L(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_L,IDIM_L,IIFERL,ITFERL,ISFERL
      COMMON
     *       /FERMIR/ F_KT_R(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_R,IDIM_R,IIFERR,ITFERR,ISFERR
      COMMON
     *       /KONFIG/ OCNMIX(NDCONF,NDCONF),HCNMIX(NDCONF,NDCONF),
     *                OVEMIX(NDKERN,NDKERN,NDRZUT,NDRZUT,NDPROT)
      COMMON
     *       /COUFIG/ CODMIX(NDCONF,NDCONF),COXMIX(NDCONF,NDCONF)
      COMMON
     *       /ENEMIX/ ESKMIX(NDKERN,NDKERN,NDRZUT,NDRZUT,NDPROT)
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENTOU/ DENSIU(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /IDENTU/ IDENSU,JDENSU
      COMMON
     *       /IPRIAM/ ILIMAM,IALLAM
      COMMON
     *       /KERNAM/ FILLEF(NDCONF),FILRIG(NDCONF),NUCONF,NAMKER
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /ALLPRO/ NUMPRO(0:NDPROI,0:NDISOM)
      COMMON
     *       /ALLLEF/ NUMLEF(0:NDPROI,0:NDISOM)
      COMMON
     *       /COLMIX/ MIXCOL(0:NDPROI,0:NDISOM,NDCONF)
      COMMON
     *       /GYROSC/ GYRORP,GYRSPN,GYRSPP,IGYROS
      COMMON
     *       /GEF2BC/ GIN2BC,GSA2BC,IGY2BC
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C=======================================================================
      DATA
     *       NAMMUL /'MULTIPOLE MOMENTS [UNITS:  (10 FERMI)^LAMBDA]'/,
     *       NAMSUR /'SURFACE MOMENTS, UNITS: (10 FERMI)^(LAMBDA+2)'/,
     *       NAMSCH /'SCHIFF MOMENTS,  UNITS: (10 FERMI)^(LAMBDA+2)'/,
     *       NAMMAG /'P+N MAGNETIC MOMENTS [MGNTN*FERMI^(LAMBDA-1)]'/,
     *       NAMMAR /'P+N MAGNETIC MOMENTS [MTN*FERMI^(N+LAMBDA-1)]'/,
     *       NAMASM /'P+N SPIN-ASM MOMENTS [MGNTN*FERMI^(LAMBDA+1)]'/,
     *       NAMASR /'P+N SPIN-ASM MOMENTS [MTN*FERMI^(N+LAMBDA+1)]'/
      DATA
     *      IVERKE/13/,IVERK2/12/
C
      KPRSTA(IPRDUM)=IAXIAL*KPROJE-(1-IAXIAL)*IPRDUM
      KPRSTO(IPRDUM)=IAXIAL*KPROJE+(1-IAXIAL)*IPRDUM
C
      LPRSTA(IPRDUM)=IAXIAL*KPLEFT-(1-IAXIAL)*IPRDUM
      LPRSTO(IPRDUM)=IAXIAL*KPLEFT+(1-IAXIAL)*IPRDUM
C
      KSOSTA(IPRDUM)=IAXIAT*ISOSTZ-(1-IAXIAT)*IPRDUM
      KSOSTO(IPRDUM)=IAXIAT*ISOSTZ+(1-IAXIAT)*IPRDUM
C
      IND_LM(LAMDUM,MIUDUM)=LAMDUM**2+LAMDUM+MIUDUM+1
      IND_IK(IPRDUM,KPRDUM)=(IPRDUM**2-IHALF_)/4+(IPRDUM+KPRDUM)/2+1
C
      CALL CPUTIM('PROANG',1)
C
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(WARIGH)) THEN
          ALLOCATE (WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WARIGH','PROANG')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(WALEFT)) THEN
          ALLOCATE (WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WALEFT','PROANG')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(REDQ_P)) THEN
          ALLOCATE (REDQ_P(0:NDREDU),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REDQ_P','PROANG')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(REDM_P)) THEN
          ALLOCATE (REDM_P(0:NDREDU,0:NMAORD),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REDM_P','PROANG')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(REDA_T).AND.NASORD.GE.0) THEN
          ALLOCATE (REDA_T(0:NDREDU,0:NASORD),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REDA_T','PROANG')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(REDS_P)) THEN
          ALLOCATE (REDS_P(0:NDREDU),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REDS_P','PROANG')
      END IF
C=======================================================================
      IF (ICOUMD.GE.1.AND..NOT.ALLOCATED(COUD_P)) THEN
          ALLOCATE (COUD_P(0:NDREDU),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('COUD_P','PROANG')
      END IF
C=======================================================================
      IF (ICOUMX.GE.1.AND..NOT.ALLOCATED(COUX_P)) THEN
          ALLOCATE (COUX_P(0:NDREDU),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('COUX_P','PROANG')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(INDRED)) THEN
          ALLOCATE (INDRED(NDPROK,0:NDMULR,NDPROK),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('INDRED','PROANG')
      END IF
C=======================================================================
      ALLOCATE (OVRLAP(1:4*NDSTAT,1:4*NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('OVRLAP','PROANG')
C=======================================================================
      ALLOCATE (WARAUX(1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WARAUX','PROANG')
C=======================================================================
C WHEN PAIRIING IS ON, THE DIMENSION SHOULD BE DOUBLED
      IF(IPAHFB.EQ.0)THEN
         ALLOCATE (TARIGH(1:2*NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
         IF (IALLOC.NE.0) CALL NOALLO('TARIGH','PROANG')
C=======================================================================
         ALLOCATE (TALEFT(1:2*NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
         IF (IALLOC.NE.0) CALL NOALLO('TALEFT','PROANG')
C=======================================================================
      ELSE
         ALLOCATE (TARIGH(1:2*NDBASE,1:8*NDSTAT,0:NDSPIN),STAT=IALLOC)
         IF (IALLOC.NE.0) CALL NOALLO('TARIGH','PROANG')
C=======================================================================
         ALLOCATE (TALEFT(1:2*NDBASE,1:8*NDSTAT,0:NDSPIN),STAT=IALLOC)
         IF (IALLOC.NE.0) CALL NOALLO('TALEFT','PROANG')
C=======================================================================
         ALLOCATE (WARITP(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
         IF (IALLOC.NE.0) CALL NOALLO('WARITP','PROANG')
      END IF
C=======================================================================
      ALLOCATE (BNN_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('BNN_PP','PROANG')
      ALLOCATE (BNP_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('BNP_PP','PROANG')
      ALLOCATE (BPP_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('BPP_PP','PROANG')
      ALLOCATE (BPN_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('BPN_PP','PROANG')
C=======================================================================
      IF (ISIMPY.NE.1) THEN
          ALLOCATE (BNN_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BNN_PM','PROANG')
          ALLOCATE (BNP_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BNP_PM','PROANG')
          ALLOCATE (BPP_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BPP_PM','PROANG')
          ALLOCATE (BPN_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BPN_PM','PROANG')
      END IF
C=======================================================================
      ALLOCATE (ZMUL_P(1:NDAKNO,-NDPROI:NDPROI,NDMULM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ZMUL_P','PROANG')
      ALLOCATE (ZMAG_T(1:NDAKNO,-NDPROI:NDPROI,NDMULM,0:NMAORD),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ZMAG_T','PROANG')
      ALLOCATE (ZSIF_P(1:NDAKNO,-NDPROI:NDPROI,NDMULM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ZSIF_P','PROANG')
      IF (NASORD.GE.0)
     *ALLOCATE (ZASM_T(1:NDAKNO,-NDPROI:NDPROI,NDMULM,0:NASORD),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ZASM_T','PROANG')
C=======================================================================
      ALLOCATE (CMUL_P(-NDPROI:NDPROI,-NDPROI:NDPROI,NDMULM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMUL_P','PROANG')
      ALLOCATE (CMAG_T(-NDPROI:NDPROI,-NDPROI:NDPROI,NDMULM,0:NMAORD),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMAG_T','PROANG')
      ALLOCATE (CSIF_P(-NDPROI:NDPROI,-NDPROI:NDPROI,NDMULM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CSIF_P','PROANG')
      IF (NASORD.GE.0)
     *ALLOCATE (CASM_T(-NDPROI:NDPROI,-NDPROI:NDPROI,NDMULM,0:NASORD),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CASM_T','PROANG')
C=======================================================================
C
      IF(MREVER.EQ.0) STOP
     *   'MREVER=0 NOT ALLOWED IN PROANG (SEE DENSHF)'
C
C=======================================================================
C        THE SUBROUTINE CALCULATES THE OVERLAPS AND KERNELS OF OPERATORS
C        FOR STATES PROJECTED ON THE ANGULAR  MOMENTUM  AND/OR  ISOSPIN.
C
C        IT CAN BE CALLED IN THREE BASIC VARIANTS: (COMMENTS UNFINISHED)
C
C=======================================================================
C     ATTENTION!  STARTING FROM VERSION 2.79G, THE CODE  CALCULATES  THE
C                 TOTAL (PROTON+NEUTRON) MAGNETIC MOMENTS. CONSEQUENTLY,
C                 THE TOTAL MAGNETIC MOMENTS ARE STORED  ON  THE  KERNEL
C                 FILES. THEREFORE, BY READING THE OLD KERNEL FILES WITH
C                 IVERKE<10 OR IVERK2<3, ONE WILL HAVE  PROTON  MAGNETIC
C                 MOMENTS CALCULATED AND PRINTED INSTEAD  OF  THE  TOTAL
C                 ONES.
C                 THIS MODIFICATION WAS IMPLEMENTED ON 14/04/2017.
C=======================================================================
C     ATTENTION!  STARTING FROM VERSION 2.89L, THE CODE STORES ON THE
C                 KERNEL FILES ALL THE CALCULATED KERNELS. UP TO THAT
C                 VERSION, FOR NBTKNO=1 ONLY SOME KERNELS WERE STORED
C                 REGARDLESS OF THE FACT THAT THOSE NOT  STORED  WERE
C                 LATER USED. THIS WAS  CAUSING  ERRACTIC  PRINTOUNTS
C                 AND DIFFERENCES BETWEEN RESULTS  OBTAINED  IN  RUNS
C                 WHERE  KERNELS  WERE  CALCULATED  AND  THOSE  WHERE
C                 KERNELS WERE READ.
C                 THIS MODIFICATION WAS IMPLEMENTED ON 24/03/2019.
C=======================================================================
C     ATTENTION!  CALCULATION  OF  THE  PAIRING  KERNELS,  WHICH  WAS
C                 IMPLEMENTED IN VERSION 2.65F, WAS  NOT  ACCOMPANIED
C                 BY STORING  THEM  ON  THE  KERNEL  FILE.  THIS  WAS
C                 CAUSING ERRACTIC PRINTOUNTS AND DIFFERENCES BETWEEN
C                 RESULTS  OBTAINED  IN  RUNS  WHERE   KERNELS   WERE
C                 CALCULATED  AND  THOSE  WHERE  KERNELS  WERE  READ.
C                 THIS BUG WAS NOT CORRECTED ON 24/03/2019 ABOVE, BUT
C                 IT WAS CORRECTED ON 21/05/2019 IN VERSION 2.90J.
C=======================================================================
C
C          VERIFY COULOMB CALCULATION VARIANT
C
C=======================================================================
C
                                       ICOUVE=0
      IF (ICOUDI.EQ.0.AND.ICOUEX.EQ.0) ICOUVE=1
      IF (ICOUDI.EQ.1.AND.ICOUEX.EQ.1) ICOUVE=1
      IF (ICOUDI.EQ.2.AND.ICOUEX.EQ.2) ICOUVE=1
      IF (ICOUVE.EQ.0) THEN
      WRITE (*,467) ICOUDI, ICOUEX
 467  FORMAT (2X,'COULOMB VERSION ICOUDI=',I2,' ICOUEX=',I2,
     *             ' IS NOT SUPPORTED IN PROANG')
      STOP
      END IF
C
CWS      ECHAR2=1.43986
      ECHAR2 = ECH2_O
      COULEX = COEX_O
C
      PI=4.0D0*ATAN(1.0D0)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      NAMEPN='DUMMY   '
      PRINIT=.FALSE.
C
      I_YUKA=0
      ISGOGA=0
      ISREGA=0
      ISSEPA=0
C
      IF (NBTKNO.GT.1.AND.LDPNMX.NE.3)
     *    STOP ' NBTKNO.GT.1 REQUIRES LDPNMX=3 IN PROANG'
C
      JMULMO=MAX(NMUCOU,NMURED)
      JSIFMO=NSIRED
C
C=======================================================================
C     ATTENTION!  STARTING FROM VERSION 2.49T, THE CODE  CAN  CALCULATE
C                 THE TRANSITION MATRIX ELEMENTS OF THE SURFACE MOMENTS
C                 FOR LAMBDA=0. THIS MEANS THAT NSIRED=0 DOES  NOT  ANY
C                 MORE SWITCHES THE CALCULATION OF THE SURFACE  MOMENTS
C                 OFF. TO SWITCH THEM OFF, ONE MUST SET NSIRED=-1.  FOR
C                 COMPATIBILITY  REASONS,  THE  SURFACE   MOMENTS   ARE
C                 CALCULATED STARTING FROM LAMBDA=NSIMIN, WHERE  NSIMIN
C                 IS SET TO 1 IF THE OLD (FOR IVERKE<8) KERNEL FILE  IS
C                 READ.
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.49T) AND  (3.12A),  CALCULATION
C                    OF THE TRANSITION MATRIX ELEMENTS  OF  THE  SURFACE
C                    MOMENTS FOR LAMBDA=0 WAS  IMPLEMENTED  INCORRECTLY,
C                    BECAUSE SUBROUTINE MOMSIF WAS NOT SET TO  CALCULATE
C                    THEM. THIS  BUG  WAS  CORRECTED IN VERSION  (3.12D)
C                    ON 24/04/2022.
C=======================================================================
C
      NSIMIN=0
C
C=======================================================================
C        HERE WE SET THE SWITCH THAT INDICATES WHETHER SPIN AND  ISOSPIN
C        ARE INTEGER OR HALF-INTEGER. IN THE CASE WHERE THERE IS NEITHER
C        SPIN NOR ISOSPIN PROJECTION, WE ARBITRARILY SET THIS SWITCH  AS
C        DICTATED BY THE SPIN PROJECTION PARAMETER "IPROMA".
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.65B) AND (2.75G), THE  LOGIC
C                       BELOW WAS INCORRECT AND THUS IN THE CASE  OF  NO
C                       SPIN  AND  ISOSPIN  PROJECTION,  THE  CODE   WAS
C                       STOPPED FOR NO REASON. THIS  BUG  WAS  CORRECTED
C                       IN VERSION (2.75H) ON 13/12/2015.
C=======================================================================
C
      IHALFI=MOD(IPROMA,2)
      IHALFT=MOD(ISOSMA,2)
      IHALF_=-1
C
      IF (NUBKNO.GT.1.AND.NBTKNO.GT.1) THEN
C
          IF (IHALFI.NE.IHALFT)
     *        STOP 'INCOMPATIBLE IHALFI AND IHALFT IN PROANG'
C
          IHALF_=IHALFI
C
      ELSE
C
          IF (NUBKNO.GT.1.AND.NBTKNO.EQ.1) IHALF_=IHALFI
          IF (NUBKNO.EQ.1.AND.NBTKNO.GT.1) IHALF_=IHALFT
          IF (NUBKNO.EQ.1.AND.NBTKNO.EQ.1) IHALF_=IHALFI
C
      END IF
C
      IF (IHALF_.EQ.-1) STOP 'IHALF_ NOT SET IN PROANG'
C
                       CHALF_='  '
      IF (IHALF_.EQ.1) CHALF_='/2'
C
      IEVEN_=2/(IHALF_+1)
C
      IF (ICOMIX.EQ.0) WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
C=======================================================================
C        HERE WE SET SWITCHES THAT HAVE THE FOLLOWING MEANING:
C        LPROJJ=1(0) MEANS THAT THERE IS (IS NOT) PROJECTION ON SPIN
C        LPROJT=1(0) MEANS THAT THERE IS (IS NOT) PROJECTION ON ISOSPIN
C=======================================================================
C                   VERIFY PROJECTION VARIANT
C=======================================================================
C
      LPROJT=1
      LPROJJ=1
      IF (NUAKNO*NUBKNO.EQ.1.AND.NBTKNO.GT.1) LPROJJ=0
      IF (                       NBTKNO.EQ.1) LPROJT=0
C
      IF (N_CALL.EQ.1.AND.ICOMIX.EQ.0) THEN
C
          IF (NBTKNO.GT.1.AND.NATKNO.EQ.1)
     *        WRITE (*,'(1H*,20X,''AXIAL ISOSPIN '',
     *                           ''PROJECTION IS PERFORMED'', 20X,1H*)')
          IF (NBTKNO.GT.1.AND.NATKNO.GT.1)
     *        WRITE (*,'(1H*,23X,''3D ISOSPIN '',
     *                           ''PROJECTION IS PERFORMED'', 20X,1H*)')
          IF (NUBKNO.GT.1.AND.NUAKNO.EQ.1)
     *        WRITE (*,'(1H*,11X,''AXIAL ANGULAR-MOMENTUM '',
     *                           ''PROJECTION IS PERFORMED'', 20X,1H*)')
          IF (NUBKNO.GT.1.AND.NUAKNO.GT.1)
     *        WRITE (*,'(1H*,14X,''3D ANGULAR-MOMENTUM '',
     *                           ''PROJECTION IS PERFORMED'', 20X,1H*)')
          IF (NPNKNO.GT.1)
     *        WRITE (*,'(1H*,12X,''TOTAL PARTICLE-NUMBER '',
     *                           ''PROJECTION IS PERFORMED'',1X,
     *                           ''ON A ='',I3,               10X,1H*)')
     *        IN_FIX+IZ_FIX
C
          IF (NTZKNO.GT.1)
     *        WRITE (*,'(1H*,12X,''TOTAL ISOVECTR-NUMBER '',
     *                           ''PROJECTION IS PERFORMED'',1X,
     *                           ''ON 2*TZ='',I3,              8X,1H*)')
     *        IN_FIX-IZ_FIX
C
          IF (NPAKNO.GT.1) THEN
              IF (IPAPRO.EQ.+1)
     *        WRITE (*,'(1H*,27X,''PARITY '',
     *                           ''PROJECTION IS PERFORMED'',1X,
     *                           ''ON PI=+1'',                11X,1H*)')
              IF (IPAPRO.EQ.-1)
     *        WRITE (*,'(1H*,27X,''PARITY '',
     *                           ''PROJECTION IS PERFORMED '',
     *                           ''ON PI=-1'',                11X,1H*)')
          END IF
C
          IF (ICSKIP.NE.0.AND.ICOUDI.NE.0) WRITE (*,69)
 69       FORMAT(1H*,9X,
     *    'TEST RUN WITH THE COULOMB INTERACTION SET TO ZERO IN PROANG',
     *     9X,1H*)
C
          WRITE (*,'(1H*,77X,1H*)')
C
      END IF
C
      JCSKIP=ICSKIP
      IF (ICOUDI.EQ.0.AND.ICOUEX.EQ.0) JCSKIP=1
C
C=======================================================================
C       VERIFY CONSITENCY BETWEEN COULOMB AND PROJECTON VARIANTS
C=======================================================================
C
      IF (LPROJT.EQ.1.AND.ICOUDI.EQ.1.AND.ICOUEX.EQ.1) THEN
      WRITE(*,70)
 70   FORMAT(1H*,77X,1H*,/,
     *       1H*,5X,'ISOSPIN PROJECTION IS NOT SUPPORTED FOR ',
     *              'ICOUDI.EQ.1 AND ICOUEX.EQ.1',5X,1H*,/,
     *       1H*,77X,1H*,/,79(1H*))
      STOP
      ENDIF
C
C=======================================================================
C       VERIFY CONSITENCY WITH C-O-M AND ROTATIONAL CORRECTIONS
C=======================================================================
C
      IF (KETA_R.EQ.1.OR.KETA_R.EQ.2)
     *    WRITE(NFIPRI,'(
     *             1H*,20(1H/),'' WARNING!  WARNING  WARNING '',
     *                      '' WARNING'',       1X,20(1H/),1H*,/,
     *             1H*,20(1H/),'' ROTATIONAL CORRECTION HAS'',
     *                      '' _NOT_ YET'',     1X,20(1H/),1H*,/,
     *             1H*,20(1H/),'' BEEN IMPLEMENTED IN PROANG '',
     *                      ''        '',       1X,20(1H/),1H*,/,
     *                                             1H*,77X,1H*)')
C
      IF (JETACM.EQ.1.OR.JETACM.EQ.2)
     *    WRITE(NFIPRI,'(
     *             1H*,20(1H/),'' WARNING!  WARNING  WARNING '',
     *                      '' WARNING'',       1X,20(1H/),1H*,/,
     *             1H*,20(1H/),'' CEN-O-MASS CORRECTION HAS'',
     *                      '' _NOT_ YET'',     1X,20(1H/),1H*,/,
     *             1H*,20(1H/),'' BEEN IMPLEMENTED IN PROANG '',
     *                      ''        '',       1X,20(1H/),1H*,/,
     *                                             1H*,77X,1H*)')
C
C=======================================================================
C         HERE WE SET LIMITS ON THE GAUSS KNOTS IN CASE OF THE
C         PARALLEL CALCULATION
C=======================================================================
C
      IF (IPAKER.EQ.1) THEN
C
          NUABEG=NUASTA
          NUAEND=NUASTO
          NUGBEG=NUGSTA
          NUGEND=NUGSTO
C
          IF (IPAALL.EQ.1) THEN
C
              NUBBEG=NUBSTA
              NUBEND=NUBSTO
              NBTBEG=NUTSTA
              NBTEND=NUTSTO
C
          ELSE
C
              NUBBEG=1
              NUBEND=NUBKNO
              NBTBEG=1
              NBTEND=NBTKNO
C
          END IF
C
          IF (IPAK3D.EQ.1) THEN
C
              NATBEG=NATSTA
              NATEND=NATSTO
              NGTBEG=NGTSTA
              NGTEND=NGTSTO
C
          ELSE
C
              NATBEG=1
              NATEND=NATKNO
              NGTBEG=1
              NGTEND=NATKNO
C
          END IF
C
      ELSE
C
          NUABEG=1
          NUAEND=NUAKNO
          NUGBEG=1
          NUGEND=NUAKNO
C
          NATBEG=1
          NATEND=NATKNO
          NGTBEG=1
          NGTEND=NATKNO
C
          NUBBEG=1
          NUBEND=NUBKNO
          NBTBEG=1
          NBTEND=NBTKNO
C
      END IF
C
C=======================================================================
C         CALCULATION OF KNOTS AND WEIGHTS  FOR  THE  GAUSS-LEGENDRE
C         QUADRATURE TO BE USED FOR THE INTEGRATION OVER  THE  EULER
C         ANGLE BETA
C
C         THE INTEGRAL OVER BETA WITHIN [0,PI] LIMITS IS REPLACED BY
C                      I = INTEGRAL[-1,1] dx W_n (x)
C         WHERE  x=COS(BETA) AND W_n IS A POLYNOMIAL.
C
C         HENCE, THE GAUSS-LEGENDRE FORMULA TO BE USED IS
C                      I = SUM_J XB_WGT(J)*d^I_MK(XB_PNT(J))
C                        * KERNEL{XA_PNT(I),XB_PNT(J),XA_PNT(K)}
C=======================================================================
C
      IF (NUBKNO.EQ.1) THEN
C
         XB_WGT(1)=1.0D0
         XB_PNT(1)=0.0D0
C
      ELSE
C
          CALL GAULEG(-1.D0,1.D0,XB_PNT,XB_WGT,NUBKNO)
C
          DO I=1,NUBKNO
C
             XB_PNT(I)=ACOS(XB_PNT(I))
C
          END DO
C
      END IF
C
C=======================================================================
C         CALCULATION OF KNOTS AND WEIGHTS  FOR  THE  GAUSS-TCHEBYSCHEV
C         QUADRATURE TO BE USED FOR  THE  INTEGRATION  OVER  THE  EULER
C         ANGLES ALPHA AND GAMMA
C
C         THE GAUSS-TCHEBYSCHEV FORMULA TO BE USED IS
C          I =SUM_I XA_WGT(I) * EXP(-iM*XA_PNT(I))
C                             * KERNEL{XA_PNT(I),XB_PNT(J),XA_PNT(K)}
C
C         FOR NUAKNO=1, THE INTEGRATIONS OVER ALPHA AND GAMMA  ARE  NOT
C         PERFORMED AND THE STATE IS ASSUMED AXIAL WITH THE  PROJECTION
C         ON THE Z AXIS EQUAL KPROJE/2.
C=======================================================================
C
      IF (NUAKNO.EQ.1) THEN
C
          IAXIAL=1
          IF (LPROJJ.EQ.0) IAXIAL=0
C
          XA_WGT(1)=2*PI
          XA_PNT(1)=0.0D0
C
          IF (ABS(KPROJE-2*ANGU_T(3)).GT.0.001.AND.IDIAGO.EQ.1) THEN
C
              WRITE(NFIPRI,'(
     *                 1H*,20(1H/),'' WARNING!  WARNING  WARNING '',
     *                          '' WARNING'',       1X,20(1H/),1H*,/,
     *                 1H*,20(1H/),''                            '',
     *                          ''        '',       1X,20(1H/),1H*,/,
     *                 1H*,20(1H/),'' VALUE OF KPROJE ='',I3,
     *                          '' FOR 1D ANGULAR'',1X,20(1H/),1H*,/,
     *                 1H*,20(1H/),'' MOMENTUM PROJECTION SHOULD BE'',
     *                          '' EQUAL'',         1X,20(1H/),1H*,/,
     *                 1H*,20(1H/),'' TO TWICE PROJECTION ON  THE'',
     *                          '' Z-AXIS,'',       1X,20(1H/),1H*,/,
     *                 1H*,20(1H/),'' WHICH NOW EQUALS'',F9.5,
     *                            '' IN PROANG'',   1X,20(1H/),1H*,/,
     *                                                 1H*,77X,1H*)')
     *         KPROJE,ANGU_T(3)
C
C             STOP ' INCORRECT VALUE OF KPROJE IN PROANG'
C
          END IF
C
      ELSE
C
          IAXIAL=0
C
          DO I=1,NUAKNO
C
             XA_WGT(I)=2*PI/NUAKNO
             XA_PNT(I)=(2*I-1)*PI/NUAKNO
C
          END DO
C
      END IF
C
C=======================================================================
C         CALCULATION OF KNOTS AND WEIGHTS  FOR  THE  GAUSS-LEGENDRE
C         QUADRATURE TO BE USED FOR THE INTEGRATION OVER  THE  EULER
C         ANGLE BETA_T IN CASE OF ISOSPIN PROJECTION
C
C         THE INTEGRAL OVER BETA WITHIN [0,PI] LIMITS IS REPLACED BY
C                      I = INTEGRAL[-1,1] dx W_n (x)
C         WHERE  x=COS(BETA_T) AND W_n IS A POLYNOMIAL.
C
C         HENCE, THE GAUSS-LEGENDRE FORMULA TO BE USED IS
C                      I = SUM_J XBT_WG(J)*d^T_TzTz(XBT_PN(J))
C                        * KERNEL{XBT_PN(J)}
C         IN ANALOGY TO THE AMP
C=======================================================================
C
      IF (NBTKNO.EQ.1) THEN
C
          XBT_WG(1)=1.0D0
          XBT_PN(1)=0.0D0
C
      ELSE
C
          CALL GAULEG(-1.D0,1.D0,XBT_PN,XBT_WG,NBTKNO)
C
          DO I=1,NBTKNO
C
             XBT_PN(I)=ACOS(XBT_PN(I))
C
          END DO
C
      END IF
C
      IF (NATKNO.EQ.1) THEN
C
          IAXIAT=1
CJD ???   IF (LPROJT.EQ.0) IAXIAT=0
C
          XAT_WG(1)=2*PI
          XAT_PN(1)=0.0D0
C
      ELSE
C
          IAXIAT=0
C
          DO I=1,NATKNO
C
             XAT_WG(I)=2*PI/NATKNO
             XAT_PN(I)=(2*I-1)*PI/NATKNO
C
          END DO
C
      END IF
C
C=======================================================================
C         CALCULATION OF KNOTS AND WEIGHTS  FOR  THE  GAUSS-TCHEBYSCHEV
C         QUADRATURE TO BE USED FOR  THE  INTEGRATION  OVER  THE  GAUGE
C         ANGLES PHI
C
C         THE GAUSS-TCHEBYSCHEV FORMULA TO BE USED IS
C          I =SUM_I XG_WGT(I) * EXP(-iA*XG_PNT(I))
C                             * KERNEL{XG_PNT(I)}
C
C         FOR NPNKNO=1, THE INTEGRATION OVER  THE  GAUGE  ANGLE  IS  NOT
C         PERFORMED.
C=======================================================================
C
      IF (NPNKNO.GT.NDGAUG) STOP 'INCREASE NDGAUG FOR NPNKNO IN PROANG'
      IF (NTZKNO.GT.NDGAUG) STOP 'INCREASE NDGAUG FOR NTZKNO IN PROANG'
C
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.994) AND  (3.01D),  VARIABLE
C            "NPNPAR" BELOW WAS SET WHEN READING KERNELS FROM THE KERNEL
C            FILE ONLY. AS A RESULT, THE PARTICLE-NUMBER PROJECTION  WAS
C            INCORRECT WHEN PERFORMED WITHOUT READING THE  KERNEL  FILE.
C            THIS BUG WAS CORRECTED IN VERSION (3.02E) ON 30/11/2020.
C=======================================================================
C
      NPNPAR=IN_FIX+IZ_FIX
C
      IF (NPNKNO.EQ.1) THEN
C
          XG_WGT(1)=1.0D0
          XG_PNT(1)=0.0D0
C
      ELSE
C
          DO I=1,NPNKNO
C
             XG_WGT(I)=   1.0D0/NPNKNO
             XG_PNT(I)=(I-1)*PI/NPNKNO
C
          END DO
C
      END IF
C
C=======================================================================
C         CALCULATION OF KNOTS AND WEIGHTS  FOR  THE  GAUSS-TCHEBYSCHEV
C         QUADRATURE TO BE USED FOR  THE  INTEGRATION  OVER  THE  GAUGE
C         ANGLE PHIT CORRESPONDING TO THE TZ-PARTICLE-NUMBER PROJECTION
C=======================================================================
C
      NTZPAR=IN_FIX-IZ_FIX
C
      IF (NTZKNO.EQ.1) THEN
C
          XT_WGT(1)=1.0D0
          XT_PNT(1)=0.0D0
C
      ELSE
C
          DO I=1,NTZKNO
C
             XT_WGT(I)=   1.0D0/NTZKNO
             XT_PNT(I)=(I-1)*PI/NTZKNO
C
          END DO
C
      END IF
C
C=======================================================================
C         FOR CONSISTENCY, HERE WE DEFINE THE WEIGHT FACTORS
C         CORRESPONDING TO THE PARITY PROJECTION
C=======================================================================
C
      IF (NPAKNO.EQ.1) THEN
C
          XP_WGT(1)=1.00D0
C
      ELSE
C
          XP_WGT(1)=1.00D0/2.0D0
          XP_WGT(2)=IPAPRO/2.0D0
C
      END IF
C
C=======================================================================
C         HERE WE SET THE LIMITS OF ANGULAR MOMENTA  FOR  WHICH  THE
C         PROJECTION IS PERFORMED. FOR AXIAL INTEGRATION, THE  LOWER
C         LIMIT CANNOT BE LOWER THAN THE PROJECTION ON THE INTRINSIC
C         AXIS "KPROJE".
C
C         FOR ISOSPIN PROJECTION ALL IS DONE IN THE SAME WAY
C=======================================================================
C
      IF (IAXIAL.EQ.1) THEN
C
          JPROMI=MAX(ABS(KPROJE),IPROMI)
          JPROMA=IPROMA
      ELSE
          JPROMI=IPROMI
          JPROMA=IPROMA
C
      END IF
C
      IF (IAXIAT.EQ.1) THEN
C
          JSOSMI=MAX(ABS(ISOSTZ),ISOSMI)
          JSOSMA=ISOSMA
      ELSE
          JSOSMI=ISOSMI
          JSOSMA=ISOSMA
C
      END IF
C
CJD CZY TO PONIZEJ BEDZIE DOBRZE DLA MOMENTU PEDU?
C
      IF (LPROJJ.EQ.0) THEN
C
          JPROMI=ABS(KPROJE)
          JPROMA=ABS(KPROJE)
C
      END IF
C
      IF (LPROJT.EQ.0) THEN
C
          JSOSMI=ABS(ISOSTZ)
          JSOSMA=ABS(ISOSTZ)
C
      END IF
C
      IERROR=0
C
      IF (JPROMA.GT.NDPROI) THEN
C
          WRITE(NFIPRI,'(
     *          1H*,20(1H/),2X,''TOO SMALL VALUE OF NDPROI ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''SHOULD BE EQUAL  AT LEAST ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''IN PROANG                  '',6X,
     *                                        2X,20(1H/),1H*,/,
     *                                           1H*,77X,1H*)')
     *          NDPROI,JPROMA
C
          IERROR=1
C
      END IF
C
      IF (JSOSMA.GT.NDPROT) THEN
C
          WRITE(NFIPRI,'(
     *          1H*,20(1H/),2X,''TOO SMALL VALUE OF NDPROT ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''SHOULD BE EQUAL  AT LEAST ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''IN PROANG                  '',6X,
     *                                        2X,20(1H/),1H*,/,
     *                                           1H*,77X,1H*)')
     *          NDPROT,JSOSMA
C
          IERROR=1
C
      END IF
C
      IF ((JPROMA+1)*(JSOSMA+1).GT.NDPROD) THEN
C
          WRITE(NFIPRI,'(
     *          1H*,20(1H/),2X,''TOO SMALL VALUE OF NDPROD ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''SHOULD BE EQUAL  AT LEAST ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''IN PROANG                  '',6X,
     *                                        2X,20(1H/),1H*,/,
     *                                           1H*,77X,1H*)')
     *          NDPROD,(JPROMA+1)*(JSOSMA+1)
C
          IERROR=1
      END IF
C
C
      IF (IERROR.EQ.1)
     *    STOP ' INCORRECT NDPROI, NDPROT, OR NDPROD IN PROANG'
C
C=======================================================================
C         HERE WE DEFINE COLLECTIVE INDICES IMK FOR THE ANGULAR-MOMENTUM
C         PROJECTION.
C         ARRAYS INDIMK,IROMAT,LROMAT, AND KROMAT  ARE  USED FOR  SCALAR
C         OPERATORS, AND THUS FOR AXIAL PROJECTION THEY CAN  BE  REDUCED
C         TO CONTAIN ONLY MATRIX ELEMENTS WITH FIXED K-PROJECTIONS.
C         ARRAYS IREIMK,IREMAT,LREMAT, AND KREMAT ARE USED FOR NONSCALAR
C         OPERATORS, AND THUS, EVEN FOR AXIAL PROJECTION,  THEY  CONTAIN
C         MATRIX ELEMENTS FOR ALL POSSIBLE K-PROJECTIONS.
C=======================================================================
C
      INDIMK=0
      INDPRO=0
C
      DO IPROAC=JPROMI,JPROMA,2
         DO LPROAC=LPRSTA(IPROAC),LPRSTO(IPROAC),2
            DO KPROAC=KPRSTA(IPROAC),KPRSTO(IPROAC),2
C
               IF (IABS(LPROAC).LE.IPROAC.AND.
     *             IABS(KPROAC).LE.IPROAC) THEN
C
                   INDPRO=INDPRO+1
C
                   IROMAT(INDPRO)=IPROAC
                   LROMAT(INDPRO)=LPROAC
                   KROMAT(INDPRO)=KPROAC
C
                   INDIMK(IPROAC,LPROAC,KPROAC)=INDPRO
C
               END IF
C
            END DO
         END DO
      END DO
C
      IREIMK=0
      IREPRO=0
C
      IF (IKEPRI.EQ.1.OR.IRMPRI.EQ.1) THEN
C
          DO IPROAC=JPROMI,JPROMA,2
             DO LPROAC=-IPROAC,IPROAC,2
                DO KPROAC=KPRSTA(IPROAC),KPRSTO(IPROAC),2
C
                   IREPRO=IREPRO+1
C
                   IREMAT(IREPRO)=IPROAC
                   LREMAT(IREPRO)=LPROAC
                   KREMAT(IREPRO)=KPROAC
C
                   IREIMK(IPROAC,LPROAC,KPROAC)=IREPRO
C
                END DO
             END DO
          END DO
C
      END IF
C
      IF (INDPRO.GT.NDPROM.OR.IREPRO.GT.NDPROM) THEN
C
          WRITE(NFIPRI,'(
     *          1H*,20(1H/),2X,''TOO SMALL VALUE OF NDPROM ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''SHOULD BE EQUAL  AT LEAST ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''IN PROANG                  '',6X,
     *                                        2X,20(1H/),1H*,/,
     *                                           1H*,77X,1H*)')
     *          NDPROM,MAX(INDPRO,IREPRO)
C
          STOP ' TOO SMALL VALUE OF NDPROM IN PROANG'
C
      END IF
C
      IF (LPROJJ.EQ.0) THEN
C
          NUPROM=1
          NUPREM=1
      ELSE
          NUPROM=INDPRO
          NUPREM=IREPRO
C
      END IF
C
C=======================================================================
C         HERE WE DEFINE COLLECTIVE INDICES IMK FOR THE ISOSPIN
C         PROCECTION
C=======================================================================
C
      INDTMK=0
      INDISO=0
C
      DO ISOSAC=JSOSMI,JSOSMA,2
         DO LSOSAC=KSOSTA(ISOSAC),KSOSTO(ISOSAC),2
            DO KSOSAC=KSOSTA(ISOSAC),KSOSTO(ISOSAC),2
C
               INDISO=INDISO+1
C
               ISOMAT(INDISO)=ISOSAC
               LSOMAT(INDISO)=LSOSAC
               KSOMAT(INDISO)=KSOSAC
C
               INDTMK(ISOSAC,LSOSAC,KSOSAC)=INDISO
C
            END DO
         END DO
      END DO
C
      IF (INDISO.GT.NDISOM) THEN
C
          WRITE(NFIPRI,'(
     *          1H*,20(1H/),2X,''TOO SMALL VALUE OF NDISOM ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''SHOULD BE EQUAL  AT LEAST ='',I6,
     *                                        2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''IN PROANG                  '',6X,
     *                                        2X,20(1H/),1H*,/,
     *                                           1H*,77X,1H*)')
     *           NDISOM,INDISO
C
          STOP ' TOO SMALL VALUE OF NDISOM IN PROANG'
C
      END IF
C
      IF (LPROJT.EQ.0) THEN
C
          NUISOM=1
      ELSE
          NUISOM=INDISO
C
      END IF
C
C=======================================================================
C         SETTING SWITCHES "KPAHFB", WHICH INDICATE IF THE HFB OR HF
C         CALCULATIONS WILL BE PERFORMED FOR THE GIVEN ISOSPIN.
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (ICHARG.EQ.0) DELTAX=DELTAN
         IF (ICHARG.EQ.1) DELTAX=DELTAP
C
         IF (IPA2HF(ICHARG).EQ.1.OR.
     *       IPA2HF(ICHARG).EQ.2.AND.
     *       ABS(DELTAX).LT.DEL2HF(ICHARG)) THEN
C
             KPAHFB(ICHARG)=0
         ELSE
             KPAHFB(ICHARG)=IPAHFB
C
         END IF
C
      END DO
C
C=======================================================================
C         ZEROING THE ARRAY  "ISALGA" WHICH CONTAINS FLAGS 0(1) DENOTING
C         THE KNOTS IN ALPHA AND GAMMA THAT HAVE NOT YET BEEN CALCULATED
C         (HAVE ALREADY BEEN CALCULATED)
C=======================================================================
C
      DO I=1,NUAKNO
         DO K=1,NUAKNO
C
            ISALGA(I,K)=0
C
         END DO
      END DO
C
C=======================================================================
C         ZEROING THE ARRAY  "ISAALL" WHICH CONTAINS FLAGS 0(1) DENOTING
C         ALL KNOTS IN ALPHA, GAMMA, BETA, BETA_T THAT HAVE NOT YET BEEN
C         CALCULATED (HAVE ALREADY BEEN CALCULATED)
C=======================================================================
C
      ISAALL=0
C
C=======================================================================
C         ZEROING THE ARRAY  "ISPOIN" WHICH CONTAINS FLAGS 0(1) DENOTING
C         ALL KNOTS THAT HAVE NOT YET BEEN CALCULATED
C         (HAVE ALREADY BEEN CALCULATED)
C=======================================================================
C
      ISPOIN=0
C
C=======================================================================
C         ALLOCATING ARRAYS WITH KERNELS
C=======================================================================
      ALLOCATE (QPKERN(1:NDASAV,1:NDBKNO,1:NDASAV,NDMULM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('QPKERN','PROANG')
      ALLOCATE (ATKERN(1:NDASAV,1:NDBKNO,1:NDASAV,NDMULM,0:NMAORD),
     *                                                    STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ATKERN','PROANG')
      ALLOCATE (SPKERN(1:NDASAV,1:NDBKNO,1:NDASAV,NDMULM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('SPKERN','PROANG')
      IF (NASORD.GE.0)
     *ALLOCATE (WTKERN(1:NDASAV,1:NDBKNO,1:NDASAV,NDMULM,0:NASORD),
     *                                                    STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('WTKERN','PROANG')
C=======================================================================
C TER ALLOCATE (TEKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
C TER*                 1:NDASAT,1:NDBTKN,1:NDASAT,
C TER*                 2*NDCOUT),STAT=IALLOC)
C TER IF (IALLOC.NE.0) CALL NOALLO('TEKERN','PROANG')
C=======================================================================
      ALLOCATE (OVKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,0:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('OVKERN','PROANG')
      ALLOCATE (SKKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('SKKERN','PROANG')
      ALLOCATE (EKKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,0:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('EKKERN','PROANG')
      ALLOCATE (EPKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,0:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('EPKERN','PROANG')
      ALLOCATE (CDKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDKERN','PROANG')
      ALLOCATE (CDKE10(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDKE10','PROANG')
      ALLOCATE (CDKE1P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDKE1P','PROANG')
      ALLOCATE (CDKE1M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDKE1M','PROANG')
      ALLOCATE (CDKE20(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDKE20','PROANG')
      ALLOCATE (CDK21P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDK21P','PROANG')
      ALLOCATE (CDK21M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDK21M','PROANG')
      ALLOCATE (CDK22P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDK22P','PROANG')
      ALLOCATE (CDK22M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDK22M','PROANG')
      ALLOCATE (CXKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXKERN','PROANG')
      ALLOCATE (CXKE10(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXKE10','PROANG')
      ALLOCATE (CXKE1P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXKE1P','PROANG')
      ALLOCATE (CXKE1M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXKE1M','PROANG')
      ALLOCATE (CXKE20(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXKE20','PROANG')
      ALLOCATE (CXK21P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXK21P','PROANG')
      ALLOCATE (CXK21M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXK21M','PROANG')
      ALLOCATE (CXK22P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXK22P','PROANG')
      ALLOCATE (CXK22M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXK22M','PROANG')
      ALLOCATE (PNKE00(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('PNKE00','PROANG')
      ALLOCATE (PNKE10(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('PNKE10','PROANG')
      ALLOCATE (PNKE1P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('PNKE1P','PROANG')
      ALLOCATE (PNKE1M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('PNKE1M','PROANG')
      ALLOCATE (TZKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TZKERN','PROANG')
      ALLOCATE (T2KERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('T2KERN','PROANG')
      ALLOCATE (BZKERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('BZKERN','PROANG')
      ALLOCATE (B2KERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NDASAT,1:NDBTKN,1:NDASAT),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('B2KERN','PROANG')
C=======================================================================
C TER ALLOCATE (TETERN(1:NDASAV,1:NDBKNO,1:NDASAV,
C TER*                 1:NUISOM,2*NDCOUT),STAT=IALLOC)
C TER       IF (IALLOC.NE.0) CALL NOALLO('TETERN','PROANG')
C=======================================================================
      ALLOCATE (OVTERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('OVTERN','PROANG')
      ALLOCATE (SKTERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('SKTERN','PROANG')
      ALLOCATE (EKTERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('EKTERN','PROANG')
      ALLOCATE (EPTERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('EPTERN','PROANG')
      ALLOCATE (CDTERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDTERN','PROANG')
      ALLOCATE (CDTE10(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDTE10','PROANG')
      ALLOCATE (CDTE1P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDTE1P','PROANG')
      ALLOCATE (CDTE1M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDTE1M','PROANG')
      ALLOCATE (CDTE20(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDTE20','PROANG')
      ALLOCATE (CDT21P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDT21P','PROANG')
      ALLOCATE (CDT21M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDT21M','PROANG')
      ALLOCATE (CDT22P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDT22P','PROANG')
      ALLOCATE (CDT22M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CDT22M','PROANG')
      ALLOCATE (CXTERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXTERN','PROANG')
      ALLOCATE (CXTE10(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXTE10','PROANG')
      ALLOCATE (CXTE1P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXTE1P','PROANG')
      ALLOCATE (CXTE1M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXTE1M','PROANG')
      ALLOCATE (CXTE20(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXTE20','PROANG')
      ALLOCATE (CXT21P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXT21P','PROANG')
      ALLOCATE (CXT21M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXT21M','PROANG')
      ALLOCATE (CXT22P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXT22P','PROANG')
      ALLOCATE (CXT22M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CXT22M','PROANG')
      ALLOCATE (PNTE00(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('PNTE00','PROANG')
      ALLOCATE (PNTE10(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('PNTE10','PROANG')
      ALLOCATE (PNTE1P(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('PNTE1P','PROANG')
      ALLOCATE (PNTE1M(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('PNTE1M','PROANG')
      ALLOCATE (TZTERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TZTERN','PROANG')
      ALLOCATE (T2TERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('T2TERN','PROANG')
      ALLOCATE (BZTERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('BZTERN','PROANG')
      ALLOCATE (B2TERN(1:NDASAV,1:NDBKNO,1:NDASAV,
     *                 1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('B2TERN','PROANG')
C=======================================================================
C         ZEROING ARRAYS WITH KERNELS
C=======================================================================
C
      QPKERN(:,:,:,:)  =C_ZERO
      ATKERN(:,:,:,:,:)=C_ZERO
      SPKERN(:,:,:,:)  =C_ZERO
      IF (NASORD.GE.0)
     *WTKERN(:,:,:,:,:)=C_ZERO
C
C TER TEKERN=C_ZERO
      OVKERN=C_ZERO
      SKKERN=C_ZERO
      EKKERN=C_ZERO
C
      EPKERN=C_ZERO
C
      CDKERN=C_ZERO
      CDKE10=C_ZERO
      CDKE1P=C_ZERO
      CDKE1M=C_ZERO
      CDKE20=C_ZERO
      CDK21P=C_ZERO
      CDK21M=C_ZERO
      CDK22P=C_ZERO
      CDK22M=C_ZERO
      CXKERN=C_ZERO
      CXKE10=C_ZERO
      CXKE1P=C_ZERO
      CXKE1M=C_ZERO
      CXKE20=C_ZERO
      CXK21P=C_ZERO
      CXK21M=C_ZERO
      CXK22P=C_ZERO
      CXK22M=C_ZERO
      PNKE00=C_ZERO
      PNKE10=C_ZERO
      PNKE1P=C_ZERO
      PNKE1M=C_ZERO
      TZKERN=C_ZERO
      T2KERN=C_ZERO
      BZKERN=C_ZERO
      B2KERN=C_ZERO
C===========================================================
C TER TETERN(:,:,:,:,:)=C_ZERO
      OVTERN(:,:,:,:)=C_ZERO
      SKTERN(:,:,:,:)=C_ZERO
      EKTERN(:,:,:,:)=C_ZERO
      EPTERN(:,:,:,:)=C_ZERO
      CDTERN(:,:,:,:)=C_ZERO
      CDTE10(:,:,:,:)=C_ZERO
      CDTE1P(:,:,:,:)=C_ZERO
      CDTE1M(:,:,:,:)=C_ZERO
      CDTE20(:,:,:,:)=C_ZERO
      CDT21P(:,:,:,:)=C_ZERO
      CDT21M(:,:,:,:)=C_ZERO
      CDT22P(:,:,:,:)=C_ZERO
      CDT22M(:,:,:,:)=C_ZERO
      CXTERN(:,:,:,:)=C_ZERO
      CXTE10(:,:,:,:)=C_ZERO
      CXTE1P(:,:,:,:)=C_ZERO
      CXTE1M(:,:,:,:)=C_ZERO
      CXTE20(:,:,:,:)=C_ZERO
      CXT21P(:,:,:,:)=C_ZERO
      CXT21M(:,:,:,:)=C_ZERO
      CXT22P(:,:,:,:)=C_ZERO
      CXT22M(:,:,:,:)=C_ZERO
      PNTE00(:,:,:,:)=C_ZERO
      PNTE10(:,:,:,:)=C_ZERO
      PNTE1P(:,:,:,:)=C_ZERO
      PNTE1M(:,:,:,:)=C_ZERO
      TZTERN(:,:,:,:)=C_ZERO
      T2TERN(:,:,:,:)=C_ZERO
      BZTERN(:,:,:,:)=C_ZERO
      B2TERN(:,:,:,:)=C_ZERO
C
C=======================================================================
C         READING THE OLD FILES WITH KERNELS
C=======================================================================
C         COMPILE WITH IWRKER=1 TO PRINT THE KERNELS READ FROM FILE(S)
C=======================================================================
C
      IWRKER=0
C
C=======================================================================
C
      IF (ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(
     *          1H*,20(1H/),2X,''ATTENTION: OLD VERSIONS OF KERNEL'',
     *                                              2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''FILES WILL BE WRITTEN/READ. USAGE'',
     *                                              2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''OF  NEW  VERSIONS  IS  RECOMENDED'',
     *                                              2X,20(1H/),1H*,/,
     *          1H*,20(1H/),2X,''BY RERUNNING CODE WITH ISAKER = 2'',
     *                                              2X,20(1H/),1H*,/,
     *                                                 1H*,77X,1H*)')
C
          IFIKER=0
          JFIKER=0
          MVERKE=0
C
    8     IFIKER=IFIKER+1
C
C=======================================================================
C         OPENING THE FILE
C=======================================================================
C
          IF (IPROAN.EQ.1.OR.IPROAN.EQ.2) THEN
C
              WRITE(FILACT(01:05),'(''N'',I3,''-'')') IFIKER
              WRITE(FILACT(06:10),'(''L'',I3,''-'')') ILFWAV
              WRITE(FILACT(11:15),'(''R'',I3,''-'')') IRGWAV
C
          ELSE IF (IPROAN.EQ.3) THEN
C
              WRITE(FILACT(01:05),'(''N'',I3,''-'')') IFIKER
              WRITE(FILACT(06:10),'(''L'',I3,''-'')') INLWAV
              WRITE(FILACT(11:15),'(''R'',I3,''-'')') INRWAV
C
          ELSE
c
              STOP ' WRONG IPROAN USED FOR ISAKER=1 IN PROANG'
C
          END IF
C
          DO NUCHAR=1,15
C
             IF (FILACT(NUCHAR:NUCHAR).EQ.' ') FILACT(NUCHAR:NUCHAR)='0'
C
          END DO
C
          FILACT(16:83)=FILKER
C
          OPEN(NFIKER,FILE=FILACT,STATUS='OLD',ERR=7,FORM='UNFORMATTED')
C
          NUALGA=0
          NUAALL=0
C
          I_MINI=NUAKNO
          I_MAXI=1
          K_MINI=NUAKNO
          K_MAXI=1
C
C=======================================================================
C         READING THE FILE
C=======================================================================
C
   6      READ (NFIKER,END=5,ERR=15) I,K,LVERKE
C
          INEWFI=1
C
          JFIKER=JFIKER+1
C
          IF (JFIKER.GT.1.AND.LVERKE.NE.MVERKE) THEN
C
              WRITE(NFIPRI,'(/,1X,10(1H/),
     *                  ''  CANNOT READ MIXED-VERSION KERNEL FILES'',
     *                  3X,10(1H/),/)')
C
              STOP '  WRONG MIXED-VERSION KERNEL FILES IN PROANG'
          ELSE
              MVERKE=LVERKE
          END IF
C
          GO TO 16
C
  15      INEWFI=0
C
          MVERKE=1
C
  16      CONTINUE
C
          IF (JFIKER.EQ.1.AND.ICOMIX.EQ.0)
     *        WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE GCM KERNELS IN FUNCTION OF THE EULER'',
     *               '' ANGLES READ FROM OLD FILES FILKER'',  1X,1H*,/,
     *        1H*,2X,A68,''VER='',I2,                         1X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                                         79(1H*),/,1H*,77X,1H*)')
     *
     *        FILKER,MVERKE
C
          IF (MVERKE.GT.IVERKE) THEN
C
              WRITE(NFIPRI,'(/,1X,10(1H/),
     *                  ''  CANNOT READ THE KERNEL FILE VERSION:'',
     *                  I3,2X,10(1H/),/)') MVERKE
C
              STOP '  WRONG MVERKE IN PROANG'
C
          END IF
C
          IF (I.LT.1.OR.I.GT.NUAKNO) STOP ' WRONG I READ IN PROANG'
          IF (K.LT.1.OR.K.GT.NUAKNO) STOP ' WRONG K READ IN PROANG'
C
          IF (MVERKE.LE.7) NSIMIN=1
C
          IF (MVERKE.GE.3) THEN
C
              IF (MVERKE.GE.7) THEN
C
                  READ (NFIKER,END=5,ERR=8915) MPAALL,J,L
C
                  IF (MPAALL.NE.IPAALL)
     *                               STOP ' WRONG IPAALL READ IN PROANG'
                  IF ((J.LT.1.OR.J.GT.NUBKNO).AND.IPAALL.EQ.1)
     *                               STOP ' WRONG J READ IN PROANG'
                  IF ((L.LT.1.OR.L.GT.NBTKNO).AND.IPAALL.EQ.1)
     *                               STOP ' WRONG L READ IN PROANG'
C
                  GO TO 8916
C
 8915             STOP ' ERROR READING IVERKE.GE.7 FILE IN PROANG'
C
 8916             CONTINUE
C
              END IF
C
              READ (NFIKER,END=5,ERR=5) FILINP
C
              IF (FILINP.NE.FILACT.AND.ICHKER.EQ.1) THEN
C
                  WRITE(NFIPRI,'(//,87(1H/),/,1H/,85X,1H/,/,
     *
     *                1H/,'' THE NAME OF THE KERNEL FILE: '',55X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                1H/,1X,A83,                             1X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                1H/,'' IS DIFFERENT THAN THE NAME RECORDED'',
     *                    '' IN THE KERNEL FILE:    '',      25X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                1H/,1X,A83,                             1X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                1H/,'' CORRECT THE DATABASE OF YOUR KERNEL'',
     *                    '' FILES AND START AGAIN'',
     *                    '' OR OTHERWISE SET ICHKER=0'',     1X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                                                        87(1H/))')
     *
     *            FILACT,FILINP
C
              STOP ' NAME OF THE KERNEL FILE IS DIFFERENT THAN RECORDED'
C
              END IF
C
          END IF
C
          I_MINI=MIN(I_MINI,I)
          I_MAXI=MAX(I_MAXI,I)
          K_MINI=MIN(K_MINI,K)
          K_MAXI=MAX(K_MAXI,K)
C
C=======================================================================
C         THE TRICK BELOW IS INTRODUCED IN ORDER TO SAVE MEMORY WHEN
C         A PARALLEL CALCULATION IS  PERFORMED  (IPAKER=1)  AND  THE
C         CALCULATED KERNELS WILL NOT BE INTEGRATED. IN SUCH A  CASE
C         WE DO NOT HAVE TO KEEP THEM IN MEMORY, AND ALL ARE  STORED
C         IN THE LOCATION NORMALLY USED FOR THE FIRST KNOT IN  ALPHA
C         AND GAMMA, AND THE CODE CAN BE COMPILED WITH IPARAL=1.
C         THE SAME RULES CONCERN THE ISOSPIN AND IPARAT=1.
C=======================================================================
C
                           M=I
          IF (IPAKER.EQ.1) M=1
                           N=K
          IF (IPAKER.EQ.1) N=1
C
C=======================================================================
C
          IF (INEWFI.EQ.1) THEN
C
              IF (MVERKE.LE.3) THEN
C
                  READ (NFIKER,END=5,ERR=5) MUBKNO,MMURED,MMARED
                  MSIRED=0
C
              ELSE
C
                  IF (MVERKE.LE.5) THEN
C
                      READ (NFIKER,END=5,ERR=5) MUBKNO,MMURED,MMARED,
     *                                                        MSIRED
                      MBTKNO=1
C
                  ELSE
C
                      READ (NFIKER,END=5,ERR=5) MUBKNO,MBTKNO,
     *                                          MMURED,MMARED,MSIRED
C
                  END IF
C
              END IF
C
              IF (MUBKNO.NE.NUBKNO) STOP ' WRONG NUBKNO READ IN PROANG'
              IF (MBTKNO.NE.NBTKNO) STOP ' WRONG NBTKNO READ IN PROANG'
              IF (MMURED.NE.NMURED) STOP ' WRONG NMURED READ IN PROANG'
              IF (MMARED.NE.NMARED) STOP ' WRONG NMARED READ IN PROANG'
              IF (MSIRED.NE.NSIRED) STOP ' WRONG NSIRED READ IN PROANG'
C
              IF (IPAALL.EQ.1) THEN
C
                     READ (NFIKER,END=5,ERR=5) JJ,
     *                OVKERN(M,J,N,1,0,1),OVKERN(M,J,N,1,L,1),
     *                EKKERN(M,J,N,1,0,1),EKKERN(M,J,N,1,L,1),
     *                CDKERN(M,J,N,1,L,1),
     *                CXKERN(M,J,N,1,L,1),
     *                SKKERN(M,J,N,1,L,1),
     *               ((QPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                             MIU=-LAMBDA,LAMBDA),LAMBDA=0,NMURED),
     *               ((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0),
     *                             MIU=-LAMBDA,LAMBDA),LAMBDA=1,NMARED),
     *               ((SPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                             MIU=-LAMBDA,LAMBDA),
     *                                            LAMBDA=NSIMIN,NSIRED)
C
                     IF (J.NE.JJ)
     *                         STOP ' WRONG J READ IN PROANG (IPAALL=1)'
C
                     IF (IWRKER.EQ.1) WRITE(*,7878) M,J,N,1,L,1,
     *                                       OVKERN(M,J,N,1,L,1),
     *                                   ABS(OVKERN(M,J,N,1,L,1)),
     *                                       SKKERN(M,J,N,1,L,1),
     *                                   ABS(SKKERN(M,J,N,1,L,1)),
     *                                       CDKERN(M,J,N,1,L,1),
     *                                   ABS(CDKERN(M,J,N,1,L,1)),
     *                                       CXKERN(M,J,N,1,L,1),
     *                                   ABS(CXKERN(M,J,N,1,L,1)),
     *                                       SKKERN(M,J,N,1,L,1)*
     *                                       OVKERN(M,J,N,1,L,1),
     *                                   ABS(SKKERN(M,J,N,1,L,1)*
     *                                       OVKERN(M,J,N,1,L,1))
C
                     IF (NBTKNO.GT.1.OR.MVERKE.GE.11)
     *
     *                   READ (NFIKER,END=5,ERR=5)
     *                      CDKE10(M,J,N,1,L,1),
     *                      CDKE1P(M,J,N,1,L,1),
     *                      CXKE10(M,J,N,1,L,1),
     *                      CXKE1P(M,J,N,1,L,1),
     *                      CDKE1M(M,J,N,1,L,1),
     *                      CDKE20(M,J,N,1,L,1),
     *                      CDK21P(M,J,N,1,L,1),
     *                      CDK21M(M,J,N,1,L,1),
     *                      CDK22P(M,J,N,1,L,1),
     *                      CDK22M(M,J,N,1,L,1),
     *                      CXKE1M(M,J,N,1,L,1),
     *                      CXKE20(M,J,N,1,L,1),
     *                      CXK21P(M,J,N,1,L,1),
     *                      CXK21M(M,J,N,1,L,1),
     *                      CXK22P(M,J,N,1,L,1),
     *                      CXK22M(M,J,N,1,L,1),
     *                      PNKE00(M,J,N,1,L,1),
     *                      PNKE10(M,J,N,1,L,1),
     *                      PNKE1P(M,J,N,1,L,1),
     *                      PNKE1M(M,J,N,1,L,1)
C
                         IF (MVERKE.GE.9) THEN
C
                             READ (NFIKER,END=5,ERR=5)
     *                         (TZKERN(M,J,N,1,L1,1),L1=1,NBTKNO),
     *                         (T2KERN(M,J,N,1,L1,1),L1=1,NBTKNO)
C
                         ELSE
C
                             DO L1=1,NBTKNO
C
                                TZKERN(M,J,N,1,L1,1)=C_ZERO
                                T2KERN(M,J,N,1,L1,1)=C_ZERO
C
                             END DO
C
                         END IF
C
                         IF (MVERKE.GE.12) THEN
C
                             READ (NFIKER,END=5,ERR=5)
     *                         (EPKERN(M,J,N,1,L1,1),L1=0,NBTKNO)
C
                         ELSE
C
                             DO L1=0,NBTKNO
C
                                EPKERN(M,J,N,1,L1,1)=C_ZERO
C
                             END DO
C
                         END IF
C
                         IF (MVERKE.GE.13) THEN
C
                             READ (NFIKER,END=5,ERR=5)
     *                         (BZKERN(M,J,N,1,L1,1),L1=1,NBTKNO),
     *                         (B2KERN(M,J,N,1,L1,1),L1=1,NBTKNO)
C
                         ELSE
C
                             DO L1=1,NBTKNO
C
                                BZKERN(M,J,N,1,L1,1)=C_ZERO
                                B2KERN(M,J,N,1,L1,1)=C_ZERO
C
                             END DO
C
                         END IF
C
                  ISAALL(I,J,K,L)=ISAALL(I,J,K,L)+1
                  NUAALL=NUAALL+1
C
              ELSE
C
                  DO J=1,NUBKNO
C
                     READ (NFIKER,END=5,ERR=5) JJ,
     *                (OVKERN(M,J,N,1,L,1),L=0,NBTKNO),
     *                (EKKERN(M,J,N,1,L,1),L=0,NBTKNO),
     *                (CDKERN(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXKERN(M,J,N,1,L,1),L=1,NBTKNO),
     *                (SKKERN(M,J,N,1,L,1),L=1,NBTKNO),
     *               ((QPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                             MIU=-LAMBDA,LAMBDA),LAMBDA=0,NMURED),
     *               ((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0),
     *                             MIU=-LAMBDA,LAMBDA),LAMBDA=1,NMARED),
     *               ((SPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                             MIU=-LAMBDA,LAMBDA),
     *                                            LAMBDA=NSIMIN,NSIRED)
C
                     IF (J.NE.JJ)
     *                         STOP ' WRONG J READ IN PROANG (IPAALL=0)'
C
                     IF (IWRKER.EQ.1) WRITE(*,7878) M,J,N,1,1,1,
     *                                       OVKERN(M,J,N,1,0,1),
     *                                   ABS(OVKERN(M,J,N,1,0,1)),
     *                                       OVKERN(M,J,N,1,1,1),
     *                                   ABS(OVKERN(M,J,N,1,1,1)),
     *                                       OVKERN(M,J,N,1,0,1)*
     *                                       OVKERN(M,J,N,1,1,1),
     *                                   ABS(OVKERN(M,J,N,1,0,1)*
     *                                       OVKERN(M,J,N,1,1,1))
C
                     IF (NBTKNO.GT.1.OR.MVERKE.GE.11) THEN
C
                         READ (NFIKER,END=5,ERR=5)
     *                      (CDKE10(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CDKE1P(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CXKE10(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CXKE1P(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CDKE1M(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CDKE20(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CDK21P(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CDK21M(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CDK22P(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CDK22M(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CXKE1M(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CXKE20(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CXK21P(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CXK21M(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CXK22P(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (CXK22M(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (PNKE00(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (PNKE10(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (PNKE1P(M,J,N,1,L,1),L=1,NBTKNO),
     *                      (PNKE1M(M,J,N,1,L,1),L=1,NBTKNO)
C
                         IF (MVERKE.GE.9) THEN
C
                             READ (NFIKER,END=5,ERR=5)
     *                         (TZKERN(M,J,N,1,L1,1),L1=1,NBTKNO),
     *                         (T2KERN(M,J,N,1,L1,1),L1=1,NBTKNO)
C
                         ELSE
C
                             DO L1=1,NBTKNO
C
                                TZKERN(M,J,N,1,L1,1)=C_ZERO
                                T2KERN(M,J,N,1,L1,1)=C_ZERO
C
                             END DO
C
                         END IF
C
                         IF (MVERKE.GE.12) THEN
C
                             READ (NFIKER,END=5,ERR=5)
     *                         (EPKERN(M,J,N,1,L1,1),L1=0,NBTKNO)
C
                         ELSE
C
                             DO L1=0,NBTKNO
C
                                EPKERN(M,J,N,1,L1,1)=C_ZERO
C
                             END DO
C
                         END IF
C
                         IF (MVERKE.GE.13) THEN
C
                             READ (NFIKER,END=5,ERR=5)
     *                         (BZKERN(M,J,N,1,L1,1),L1=1,NBTKNO),
     *                         (B2KERN(M,J,N,1,L1,1),L1=1,NBTKNO)
C
                         ELSE
C
                             DO L1=1,NBTKNO
C
                                BZKERN(M,J,N,1,L1,1)=C_ZERO
                                B2KERN(M,J,N,1,L1,1)=C_ZERO
C
                             END DO
C
                         END IF
C
                     END IF
C
                  END DO
C
                  ISALGA(I,K)=ISALGA(I,K)+1
                  NUALGA=NUALGA+1
C
              END IF
C
          ELSE
C
C=======================================================================
C         READING OF FILES IN THE OLD FORMAT IS KEPT FOR SOME TIME
C=======================================================================
C
              READ (NFIKER,END=5,ERR=5) MUBKNO,MMURED,MMARED,MDCOUP
C
              IF (MUBKNO.NE.NUBKNO) STOP ' WRONG NUBKNO READ IN PROANG'
              IF (MMURED.NE.NMURED) STOP ' WRONG NMURED READ IN PROANG'
              IF (MMARED.NE.NMARED) STOP ' WRONG NMARED READ IN PROANG'
C             IF (MDCOUP.NE.NDCOUP) STOP ' WRONG NDCOUP READ IN PROANG'
C
              DO J=1,NUBKNO
C
                 READ (NFIKER,END=5,ERR=5) JJ,
     *             OVKERN(M,J,N,1,0,1),OVKERN(M,J,N,1,1,1),
     *             EKKERN(M,J,N,1,0,1),EKKERN(M,J,N,1,1,1),
     *             CDKERN(M,J,N,1,1,1),CXKERN(M,J,N,1,1,1),
     *             SKKERN(M,J,N,1,1,1),
     *           ((QPKERN(M,J,N,IND_LM(LAMBDA,MIU)),MIU=-LAMBDA,LAMBDA),
     *                                                 LAMBDA=0,NMURED),
     *         ((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0),MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=0,NMARED),
     *            (FACINT,NUCOUP=1,MDCOUP)
C
C
                 IF (J.NE.JJ) STOP ' WRONG J READ IN PROANG'
C
                 IF (IWRKER.EQ.1) WRITE(*,7878) M,J,N,1,1,1,
     *                                   OVKERN(M,J,N,0,1,1),
     *                               ABS(OVKERN(M,J,N,0,1,1)),
     *                                   OVKERN(M,J,N,1,1,1),
     *                               ABS(OVKERN(M,J,N,1,1,1)),
     *                                   OVKERN(M,J,N,0,1,1)*
     *                                   OVKERN(M,J,N,1,1,1),
     *                               ABS(OVKERN(M,J,N,0,1,1)*
     *                                   OVKERN(M,J,N,1,1,1)),
     *                                   SKKERN(M,J,N,1,1,1),
     *                               ABS(SKKERN(M,J,N,1,1,1)),
     *                                   CDKERN(M,J,N,1,1,1),
     *                               ABS(CDKERN(M,J,N,1,1,1)),
     *                                   CXKERN(M,J,N,1,1,1),
     *                               ABS(CXKERN(M,J,N,1,1,1)),
     *                                   SKKERN(M,J,N,1,1,1)*
     *                                   OVKERN(M,J,N,1,1,1),
     *                               ABS(SKKERN(M,J,N,1,1,1)*
     *                                   OVKERN(M,J,N,1,1,1))
C
              END DO
C
              ISALGA(I,K)=ISALGA(I,K)+1
              NUALGA=NUALGA+1
C
          END IF
C
          IF (MVERKE.LT.5) THEN
C
              DO J=1,NUBKNO
C
                 DO LAMBDA=0,NMURED
                    DO MIU=-LAMBDA,LAMBDA
C
                       NIU=IABS(MIU)
C
                       QPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *                 QPKERN(M,J,N,IND_LM(LAMBDA,MIU))
     *                             *QUNITS(LAMBDA,NIU)
C
                    END DO
                 END DO
C
                 DO LAMBDA=1,NMARED
                    DO MIU=-LAMBDA,LAMBDA
C
                       NIU=IABS(MIU)
C
                       ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0)=
     *                 ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0)
     *                             *AUNITS(LAMBDA,NIU)
C
                    END DO
                 END DO
C
                 DO LAMBDA=NSIMIN,NSIRED
                    DO MIU=-LAMBDA,LAMBDA
C
                       NIU=IABS(MIU)
C
                       SPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *                 SPKERN(M,J,N,IND_LM(LAMBDA,MIU))
     *                             *SUNITS(LAMBDA,NIU)
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
C=======================================================================
C         HERE JUMP TO READING THE NEXT SET OF BETA KNOTS
C=======================================================================
C
          GO TO 6
C
    5     CLOSE(NFIKER)
C
          MUALGA=(I_MAXI-I_MINI+1)*(K_MAXI-K_MINI+1)
C
          IF (ICOMIX.EQ.0)
     *    WRITE(NFIPRI,'(1H*,2X,A14,     I4,'' <= I <='',I3,
     *                         ''  AND'',I4,'' <= K <='',I3,
     *                         ''; TOT'',I6,'' PNTS OF'',I6,
     *                   1X,1H*)')
     *
     *    FILACT(01:14),I_MINI,I_MAXI,K_MINI,K_MAXI,NUALGA,MUALGA
C
C=======================================================================
C         HERE JUMP TO READING THE NEXT FILE
C=======================================================================
C
          GO TO 8
C
    7     CONTINUE
C
          IF (IFIKER.GT.1.AND.ICOMIX.EQ.0) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
          IF (MVERKE.GT.0.AND.MVERKE.LT.10.AND.MMARED.GE.1)
     *
     *        WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' ATTENTION: PROTON KERNELS OF MAGNETIC MOMENTS'',
     *               '' HAVE BEEN READ FROM DISK   '',  2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
C=======================================================================
C         HERE WE PRINT THE TABLE OF KNOTS THAT HAVE ALREADY BEEN
C         CALCULATED.
C=======================================================================
C
          IF (ICOMIX.NE.0) GO TO 9238
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE MATRIX OF KERNELS THAT HAVE ALREADY'',
     *               '' BEEN CALCULATED IS AS FOLLOWS:   '',  2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          NUABLO=(NUAKNO-MOD(NUAKNO-1,NUMCOL)-1)/NUMCOL+1
C
          IOFSET=0
          ISTART=IOFSET+1
          ISTOPP=NUAKNO
          DO KBLOCK=1,NUABLO
             KOFSET=(KBLOCK-1)*NUMCOL
             KSTART=KOFSET+1
             KSTOPP=MIN(NUAKNO,KOFSET+NUMCOL)
C
             WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
             DO K=KSTART,KSTOPP
C
                KCOLUM=K-KOFSET
C
                      LINE_0(KCOLUM)='-'
                WRITE(LINE_1(KCOLUM),'(I1)')(MOD(K,1000)-MOD(K,100))/100
                WRITE(LINE_2(KCOLUM),'(I1)')(MOD(K,100) -MOD(K,10))/10
                WRITE(LINE_3(KCOLUM),'(I1)') MOD(K,10)
C
             END DO
C
             KCOLUM=KSTOPP+1-KOFSET
C
             LINE_0(KCOLUM)=' '
             LINE_1(KCOLUM)='|'
             LINE_2(KCOLUM)='|'
             LINE_3(KCOLUM)='|'
C
             DO K=KSTOPP+2,KOFSET+NUMCOL+1
C
                KCOLUM=K-KOFSET
C
                LINE_0(KCOLUM)=' '
                LINE_1(KCOLUM)=' '
                LINE_2(KCOLUM)=' '
                LINE_3(KCOLUM)=' '
C
             END DO
C
             WRITE(NFIPRI,'(
     *         1H*,1X,''   '',   1X,''GAMMA'',66X,1X,1H*,/,
     *         1H*,1X,'' A '','' '',         71A1,1X,1H*,/,
     *         1H*,1X,'' L '',''|'',         71A1,1X,1H*,/,
     *         1H*,1X,'' P '',''|'',         71A1,1X,1H*,/,
     *         1H*,1X,'' H '',''|'',         71A1,1X,1H*,/,
     *         1H*,1X,'' A '','' '',         71A1,1X,1H*)')
     *
     *         LINE_0,LINE_1,LINE_2,LINE_3,LINE_0
C
             DO I=ISTART,ISTOPP
C
                DO K=KSTART,KSTOPP
C
                   KCOLUM=K-KOFSET
C
                   WRITE(LINE_1(KCOLUM),'(I1)') ISALGA(I,K)
C
                END DO
C
                KCOLUM=KSTOPP+1-KOFSET
C
                LINE_1(KCOLUM)='|'
C
                DO K=KSTOPP+2,KOFSET+NUMCOL+1
C
                   KCOLUM=K-KOFSET
C
                   LINE_1(KCOLUM)=' '
C
                END DO
C
                WRITE(NFIPRI,'(1H*,1X,I3,''|'',71A1,1X,1H*)') I,LINE_1
C
             END DO
C
             WRITE(NFIPRI,'(1H*,1X,3X, 1X,71A1,1X,1H*)') LINE_0
             WRITE(NFIPRI,'(1H*,77X,1H*)')
C
          END DO
C
 9238     CONTINUE
C
      END IF
C
C=======================================================================
C         READING THE NEW FILES WITH KERNELS
C=======================================================================
C
      IF (ISAKER.EQ.2) THEN
C
          NUPOIN=0
C
          IF (IPAKER.EQ.1) THEN
C
              IFIBEG=KFIKER
              IFIEND=KFIKER
          ELSE
              IFIBEG=1
              IFIEND=KFIKER
C
          END IF
C
          IFIKER=0
          JFIKER=0
          MVERK2=0
C
          DO KFIACT=IFIBEG,IFIEND
C
             IFIACT=-1
C
 3218        IFIACT=IFIACT+1
C
             IF (IFIACT.GT.9)
     *            STOP ' MORE THAN 10 KERNEL FILES NOT ALOWED IN PROANG'
C
C=======================================================================
C         OPENING THE FILE
C=======================================================================
C
             WRITE(FILHE2(01:06),'(''N'',I5      )') KFIACT
             WRITE(FILHE2(07:08),'(      I1,''-'')') IFIACT
C
             IF (NAMKER.EQ.1) THEN
C
                 FILACT=' '
                 IF (IPROAN.EQ.1.OR.IPROAN.EQ.2) THEN
C
                     WRITE(FILHE2(09:11),'(''L'',I2      )') ILFWAV
                     WRITE(FILHE2(12:15),'(''R'',I2,''-'')') IRGWAV
C
                 ELSE IF (IPROAN.EQ.3.OR.IPROAN.EQ.4.OR.IPROAN.EQ.5)THEN
C
                     WRITE(FILHE2(09:11),'(''L'',I2      )') INLWAV
                     WRITE(FILHE2(12:15),'(''R'',I2,''-'')') INRWAV
C
                 ELSE
c
                     STOP' WRONG IPROAN USED FOR ISAKER=2 IN PROANG'
C
                 END IF
C
                 DO NUCHAR=1,15
                    IF (FILHE2(NUCHAR:NUCHAR).EQ.' ')
     *                  FILHE2(NUCHAR:NUCHAR)='0'
                 END DO
C
                 FILACT( 1:15)=FILHE2
                 FILACT(16:83)=FILKER
C
                 OPEN(NFIKER,FILE=FILACT,STATUS='OLD',ERR=3217,
     *                                               FORM='UNFORMATTED')
             ELSE
C
                 FILAC2=' '
                 FILAC2(1: 8)=FILHE2(1: 8)
C
                 DO NUCHAR=1,8
                    IF (FILAC2(NUCHAR:NUCHAR).EQ.' ')
     *                  FILAC2(NUCHAR:NUCHAR)='0'
                 END DO
C
                 FILAC2(9:77)=TRIM(FILLEF(ILFWAV))//'+'
                 LENACT=LEN_TRIM(FILAC2)
C                WRITE (*,*) ILFWAV,LENACT,FILAC2
                 IF (LENACT+68.GT.149) STOP ' TOO LONG FILAC2 1'
                 FILAC2(LENACT+1:LENACT+68)=TRIM(FILLEF(IRGWAV))
                 LENACT=LEN_TRIM(FILAC2)
C                WRITE (*,*) IRGWAV,LENACT,FILAC2
                 IF (LENACT+ 4.GT.149) STOP ' TOO LONG FILAC2 2'
                 FILAC2(LENACT+1:LENACT+4)='.ker'
C                WRITE (*,*) LENACT,FILAC2
C
                 OPEN(NFIKER,FILE=FILAC2,STATUS='OLD',ERR=3217,
     *                                               FORM='UNFORMATTED')
             END IF
C
             IFIKER=IFIKER+1
C
C=======================================================================
C         READING THE FILE
C=======================================================================
C
 3216        READ (NFIKER,END=3219,ERR=3219) I,K,LVERK2
C
             JFIKER=JFIKER+1
C
             IF (JFIKER.EQ.1.AND.ICOMIX.EQ.0) THEN
C
                 IF (NAMKER.EQ.1) THEN
C
                     WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *         1H*,1X,'' THE GCM KERNELS IN FUNCTION OF THE EULER'',
     *                '' ANGLES READ FROM NEW FILES FILKER'',  1X,1H*,/,
     *         1H*,2X,A68,''VER='',I2,                         1X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                          79(1H*),/,1H*,77X,1H*)')
     *
     *               FILKER,LVERK2
C
                 ELSE
C
                     WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *         1H*,1X,'' THE GCM KERNELS IN FUNCTION OF THE EULER'',
     *                '' ANGLES READ FROM NEW FILES FILAC2'',  1X,1H*,/,
     *         1H*,2X,A149,''VER='',I2,                        1X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                          79(1H*),/,1H*,77X,1H*)')
     *
     *               FILAC2,LVERK2
C
                 ENDIF
C
              ENDIF
C
             IF (JFIKER.GT.1.AND.LVERK2.NE.MVERK2) THEN
C
                 WRITE(NFIPRI,'(/,1X,10(1H/),
     *                  ''  CANNOT READ MIXED-VERSION KERNEL FILES'',
     *                  3X,10(1H/),/)')
C
                 STOP '  WRONG MIXED-VERSION KERNEL FILES IN PROANG'
             ELSE
                 MVERK2=LVERK2
             END IF
C
             IF (MVERK2.GT.IVERK2) THEN
C
                 WRITE(NFIPRI,'(/,1X,10(1H/),
     *                     ''  CANNOT READ THE KERNEL FILE VERSION:'',
     *                     I3,2X,10(1H/),/)') MVERK2
C
                 STOP '  WRONG MVERK2 IN PROANG'
C
             END IF
C
             READ (NFIKER,END=3215,ERR=3215) MUAKNO,MUBKNO,MATKNO,MBTKNO
C
             IF (MUAKNO.NE.NUAKNO)STOP' WRONG MUAKNO READ IN PROANG (2)'
             IF (MUBKNO.NE.NUBKNO)STOP' WRONG MUBKNO READ IN PROANG (2)'
             IF (MATKNO.NE.NATKNO)STOP' WRONG MATKNO READ IN PROANG (2)'
             IF (MBTKNO.NE.NBTKNO)STOP' WRONG MBTKNO READ IN PROANG (2)'
C
             IF (I.LT.1.OR.I.GT.NUAKNO)STOP' WRONG I READ IN PROANG (2)'
             IF (K.LT.1.OR.K.GT.NUAKNO)STOP' WRONG K READ IN PROANG (2)'
C
C=======================================================================
C         THE TRICK BELOW IS INTRODUCED IN ORDER TO SAVE MEMORY WHEN
C         A PARALLEL CALCULATION IS  PERFORMED  (IPAKER=1)  AND  THE
C         CALCULATED KERNELS WILL NOT BE INTEGRATED. IN SUCH A  CASE
C         WE DO NOT HAVE TO KEEP THEM IN MEMORY, AND ALL ARE  STORED
C         IN THE LOCATION NORMALLY USED FOR THE FIRST KNOT IN  ALPHA
C         AND GAMMA, AND THE CODE CAN BE COMPILED WITH IPARAL=1.
C         THE SAME RULES CONCERN THE ISOSPIN AND IPARAT=1.
C=======================================================================
C
                              M=I
             IF (IPAKER.EQ.1) M=1
                              N=K
             IF (IPAKER.EQ.1) N=1
C
C=======================================================================
C
             READ (NFIKER,END=3215,ERR=3215) MPAALL,J,L
C
             IF (J.LT.1.OR.J.GT.NUBKNO)STOP' WRONG J READ IN PROANG (2)'
             IF (L.LT.1.OR.L.GT.NBTKNO)STOP' WRONG L READ IN PROANG (2)'
C
             READ (NFIKER,END=3215,ERR=3215) MPAK3D,I_T,K_T
C
             IF (I_T.LT.1.OR.I_T.GT.NATKNO) STOP' WRONG I_T READ PROANG'
             IF (K_T.LT.1.OR.K_T.GT.NATKNO) STOP' WRONG K_T READ PROANG'
C
C=======================================================================
C
                              M_T=I_T
             IF (IPAK3D.EQ.1) M_T=1
                              N_T=K_T
             IF (IPAK3D.EQ.1) N_T=1
C
C=======================================================================
C
             IF (MVERK2.GE.7) THEN
C
                 READ (NFIKER,END=3215,ERR=3215)
     *                 MPNKNO,MPNPAR,MPAKNO,MPAPRO
C
                 NPNPAR=IN_FIX+IZ_FIX
C
                 IF (MPNKNO.NE.NPNKNO.AND.NPNKNO.GT.1)
     *                                     STOP' WRONG MPNKNO IN PROANG'
                 IF (MPNPAR.NE.NPNPAR.AND.NPNKNO.GT.1)
     *                                     STOP' WRONG MPNPAR IN PROANG'
                 IF (MPAKNO.NE.NPAKNO.AND.NPAKNO.GT.1)
     *                                     STOP' WRONG MPAKNO IN PROANG'
                 IF (MPAPRO.NE.IPAPRO.AND.NPAKNO.GT.1)
     *                                     STOP' WRONG MPAPRO IN PROANG'
C
                 READ (NFIKER,END=3215,ERR=3215) MPROJE,MSOSTZ
C
                 IF (MPROJE.NE.KPROJE.AND.NUAKNO.EQ.1.AND.NUBKNO.NE.1)
     *                                     STOP' WRONG MPROJE IN PROANG'
                 IF (MSOSTZ.NE.ISOSTZ.AND.NATKNO.EQ.1.AND.NBTKNO.NE.1)
     *                                     STOP' WRONG MSOSTZ IN PROANG'
             END IF
C
             IF (MVERK2.GE.8) THEN
C
                 READ (NFIKER,END=3215,ERR=3215)
     *                 MTZKNO,MTZPAR
C
                 NTZPAR=IN_FIX-IZ_FIX
C
                 IF (MTZKNO.NE.NTZKNO.AND.NTZKNO.GT.1)
     *                                     STOP' WRONG MTZKNO IN PROANG'
                 IF (MTZPAR.NE.NTZPAR.AND.NTZKNO.GT.1)
     *                                     STOP' WRONG MTZPAR IN PROANG'
C
             END IF
C
             IF (NAMKER.EQ.1) THEN
C
                 READ (NFIKER,END=3215,ERR=3215) FILINP
C
                 IF (FILINP.NE.FILACT.AND.ICHKER.EQ.1) THEN
C
                     WRITE(NFIPRI,'(//,87(1H/),/,1H/,85X,1H/,/,
     *
     *                1H/,'' THE NAME OF THE KERNEL FILE: '',55X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                1H/,1X,A83,                             1X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                1H/,'' IS DIFFERENT THAN THE NAME RECORDED'',
     *                    '' IN THE KERNEL FILE:    '',      25X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                1H/,1X,A83,                             1X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                1H/,'' CORRECT THE DATABASE OF YOUR KERNEL'',
     *                    '' FILES AND START AGAIN'',
     *                    '' OR OTHERWISE SET ICHKER=0'',     1X,1H/,/,
     *                                                   1H/,85X,1H/,/,
     *                                                        87(1H/))')
     *
     *               FILACT,FILINP
C
                     STOP ' NAME OF KERNEL FILE IS DIFFERENT'//
     *                    ' THAN RECORDED 1'
C
                 END IF
C
             ELSE
C
                 READ (NFIKER,END=3215,ERR=3215) FILIN2
C
                 IF (FILIN2.NE.FILAC2.AND.ICHKER.EQ.1) THEN
C
                     WRITE(NFIPRI,'(//,152(1H/),/,1H/,150X,1H/,/,
     *
     *                1H/,'' THE NAME OF THE KERNEL FILE: '',120X,1H/,/,
     *                                                   1H/,150X,1H/,/,
     *                1H/,1X,A149,                             1X,1H/,/,
     *                                                   1H/,150X,1H/,/,
     *                1H/,'' IS DIFFERENT THAN THE NAME RECORDED'',
     *                    '' IN THE KERNEL FILE:    '',       90X,1H/,/,
     *                                                   1H/,150X,1H/,/,
     *                1H/,1X,A149,                             1X,1H/,/,
     *                                                   1H/,150X,1H/,/,
     *                1H/,'' CORRECT THE DATABASE OF YOUR KERNEL'',
     *                    '' FILES AND START AGAIN'',
     *                    '' OR OTHERWISE SET ICHKER=0'',     66X,1H/,/,
     *                                                   1H/,150X,1H/,/,
     *                                                       152(1H/))')
     *
     *               FILAC2,FILIN2
C
                     STOP ' NAME OF KERNEL FILE IS DIFFERENT'//
     *                    ' THAN RECORDED 2'
C
                 END IF
C
             END IF
C
             READ (NFIKER,END=3215,ERR=3215) MMURED,MMARED,MSIRED
C
             IF (MMURED.NE.NMURED)   STOP ' WRONG MMURED READ IN PROANG'
             IF (MMARED.NE.NMARED)   STOP ' WRONG MMARED READ IN PROANG'
             IF (MSIRED.NE.NSIRED)   STOP ' WRONG MSIRED READ IN PROANG'
C
             READ (NFIKER,END=3215,ERR=3215)
     *             OVKERN(M,J,N,M_T,0,N_T),OVKERN(M,J,N,M_T,L,N_T),
     *             EKKERN(M,J,N,M_T,0,N_T),EKKERN(M,J,N,M_T,L,N_T),
     *             CDKERN(M,J,N,M_T,L,N_T),
     *             CXKERN(M,J,N,M_T,L,N_T),
     *             SKKERN(M,J,N,M_T,L,N_T),
C TER*            (TEKERN(M,J,N,M_T,L,N_T,NUCOUT),NUCOUT=1,2*NDCOUT),
     *            ((QPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                                         MIU=-LAMBDA,LAMBDA),
     *                                            LAMBDA=0,NMURED),
     *            ((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0),
     *                                         MIU=-LAMBDA,LAMBDA),
     *                                            LAMBDA=1,NMARED),
     *            ((SPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                                         MIU=-LAMBDA,LAMBDA),
     *                                       LAMBDA=NSIMIN,NSIRED)
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.23F) AND  (3.24O), THE ORDER OF
C                    READING ENTRIES FROM THE KERNEL FILE WAS  CORRUPTED
C                    AND THUS READING OF THE KERNEL FILES  CREATED  WITH
C                    EARLIER VERSIONS BECAME IMPOSSIBLE.  THIS  BUG  WAS
C                    CORRECTED ON 27/04/2022 IN VERSION (3.24P).
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.06A) AND  (3.13N),  INFORMATION
C                    ON THE EFFECTIVE G-FACTORS  ("IGYROS")  USED  IN  A
C                    GIVEN RUN WAS NOT STORED ON THE KERNEL FILE.  AS  A
C                    CONSEQUENCE, THE FOLLOWING RUN THAT WAS READING THE
C                    THE KERNEL FILE AND USING DIFFERENT VALUES  OF  THE
C                    G-FACTORS WAS GIVING THE  PREVIOUS  VALUES  OF  THE
C                    MAGNETIC MOMENTS WITHOUT NOTIFYING  THE  USER. THIS
C                    BUG WAS CORRECTED ON 02/08/2022 IN VERSION (3.13O).
C=======================================================================
C
             IF (MVERK2.GE.10) THEN
C
                 READ (NFIKER,END=3215,ERR=3215)
     *                 RYRORP,RYRSPN,RYRSPP,IRYROS
C
                 IF (IRYROS.NE.IGYROS)STOP' WRONG IGYROS READ IN PROANG'
C
                 IF (IGYROS.EQ.1) THEN
C
                    IF (RYRORP.NE.GYRORP) STOP' WRONG GYRORP IN PROANG'
                    IF (RYRSPN.NE.GYRSPN) STOP' WRONG GYRSPN IN PROANG'
                    IF (RYRSPP.NE.GYRSPP) STOP' WRONG GYRSPP IN PROANG'
C
                 END IF
C
             ELSE
C
             END IF
C
C=======================================================================
C
             IF (MVERK2.GE.12) THEN
C
                 READ (NFIKER,END=3215,ERR=3215)
     *                 RIN2BC,RSA2BC,IRY2BC
C
                 IF (IRY2BC.NE.IGY2BC)STOP' WRONG IGY2BC READ IN PROANG'
C
                 IF (IGY2BC.EQ.1) THEN
C
                    IF (RIN2BC.NE.GIN2BC) STOP' WRONG GIN2BC IN PROANG'
                    IF (RSA2BC.NE.GSA2BC) STOP' WRONG GSA2BC IN PROANG'
C
                 END IF
C
             ELSE
C
                 IF (IGY2BC.EQ.1)STOP' MISSING IGY2BC IN KERNELS/PROANG'
C
             END IF
C
C=======================================================================
C
             IF (MVERK2.GE.9) THEN
C
                 READ (NFIKER,END=3215,ERR=3215) MMAORD
C
                 IF (MMAORD.NE.NMAORD)STOP' WRONG MMAORD READ IN PROANG'
C
                 READ (NFIKER,END=3215,ERR=3215)
     *           (((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),NUMORD),
     *                                         MIU=-LAMBDA,LAMBDA),
     *                                            LAMBDA=1,NMARED),
     *                                            NUMORD=1,MMAORD)
C
             END IF
C
C=======================================================================
C
             IF (MVERK2.GE.11) THEN
C
                 READ (NFIKER,END=3215,ERR=3215) MASRED,MASORD
C
                 IF (MASRED.NE.NASRED) THEN
C
                     WRITE(NFIPRI,'(/,1X,10(1H/),
     *                     '' ERROR READING KERNEL FILE VERSION='',I2,
     *                             21X,10(1H/),/,1X,10(1H/),
     *                     '' WRONG MASRED='',I2,'' READ FROM THE'',
     *                     '' KERNEL FILE FOR NASRED='',I2,
     *                              1X,10(1H/),/)') MVERK2,MASRED,NASRED
C
                     STOP ' WRONG MASRED READ IN PROANG'
C
                 END IF
C
                 IF (MASORD.NE.NASORD) THEN
C
                     WRITE(NFIPRI,'(/,1X,10(1H/),
     *                     '' ERROR READING KERNEL FILE VERSION='',I2,
     *                             21X,10(1H/),/,1X,10(1H/),
     *                     '' WRONG MASORD='',I2,'' READ FROM THE'',
     *                     '' KERNEL FILE FOR NASORD='',I2,
     *                              1X,10(1H/),/)') MVERK2,MASORD,NASORD
C
                     STOP ' WRONG MASORD READ IN PROANG'
C
                 END IF
C
                 IF (NASORD.GE.0) READ (NFIKER,END=3215,ERR=3215)
     *           (((WTKERN(M,J,N,IND_LM(LAMBDA,MIU),NUMORD),
     *                                         MIU=-LAMBDA,LAMBDA),
     *                                            LAMBDA=1,NASRED),
     *                                            NUMORD=0,NASORD)
C
             END IF
C
C=======================================================================
C
             IF (MVERK2.LT.7)
     *           OVKERN(M,J,N,M_T,1,N_T)=
     *           OVKERN(M,J,N,M_T,1,N_T)*OVKERN(M,J,N,M_T,0,N_T)
C
             IF (IWRKER.EQ.1) WRITE(*,7878) M,J,N,M_T,L,N_T,
     *                               OVKERN(M,J,N,M_T,0,N_T),
     *                           ABS(OVKERN(M,J,N,M_T,0,N_T)),
     *                               OVKERN(M,J,N,M_T,L,N_T),
     *                           ABS(OVKERN(M,J,N,M_T,L,N_T)),
     *                               OVKERN(M,J,N,M_T,0,N_T)*
     *                               OVKERN(M,J,N,M_T,L,N_T),
     *                           ABS(OVKERN(M,J,N,M_T,0,N_T)*
     *                               OVKERN(M,J,N,M_T,L,N_T)),
     *                               SKKERN(M,J,N,M_T,L,N_T),
     *                           ABS(SKKERN(M,J,N,M_T,L,N_T)),
     *                               CDKERN(M,J,N,M_T,L,N_T),
     *                           ABS(CDKERN(M,J,N,M_T,L,N_T)),
     *                               CXKERN(M,J,N,M_T,L,N_T),
     *                           ABS(CXKERN(M,J,N,M_T,L,N_T)),
     *                               SKKERN(M,J,N,M_T,L,N_T)*
     *                               OVKERN(M,J,N,M_T,L,N_T),
     *                           ABS(SKKERN(M,J,N,M_T,L,N_T)*
     *                               OVKERN(M,J,N,M_T,L,N_T))
C
 7878        FORMAT(2X,6I3,2X,75D16.8)
C
             IF (NBTKNO.GT.1.OR.MVERK2.GE.4) THEN
C
                 READ (NFIKER,END=3215,ERR=3215)
     *              CDKE10(M,J,N,M_T,L,N_T),
     *              CDKE1P(M,J,N,M_T,L,N_T),
     *              CXKE10(M,J,N,M_T,L,N_T),
     *              CXKE1P(M,J,N,M_T,L,N_T),
     *              CDKE1M(M,J,N,M_T,L,N_T),
     *              CDKE20(M,J,N,M_T,L,N_T),
     *              CDK21P(M,J,N,M_T,L,N_T),
     *              CDK21M(M,J,N,M_T,L,N_T),
     *              CDK22P(M,J,N,M_T,L,N_T),
     *              CDK22M(M,J,N,M_T,L,N_T),
     *              CXKE1M(M,J,N,M_T,L,N_T),
     *              CXKE20(M,J,N,M_T,L,N_T),
     *              CXK21P(M,J,N,M_T,L,N_T),
     *              CXK21M(M,J,N,M_T,L,N_T),
     *              CXK22P(M,J,N,M_T,L,N_T),
     *              CXK22M(M,J,N,M_T,L,N_T),
     *              PNKE00(M,J,N,M_T,L,N_T),
     *              PNKE10(M,J,N,M_T,L,N_T),
     *              PNKE1P(M,J,N,M_T,L,N_T),
     *              PNKE1M(M,J,N,M_T,L,N_T)
C
C=======================================================================
C
                 IF (MVERK2.GE.2) THEN
C
                    READ (NFIKER,END=3215,ERR=3215)
     *              TZKERN(M,J,N,M_T,L,N_T),
     *              T2KERN(M,J,N,M_T,L,N_T)
C
                 ELSE
C
                    TZKERN(M,J,N,M_T,L,N_T)=C_ZERO
                    T2KERN(M,J,N,M_T,L,N_T)=C_ZERO
C
                 END IF
C
C=======================================================================
C
                 IF (MVERK2.GE.5) THEN
C
                    READ (NFIKER,END=3215,ERR=3215)
     *              EPKERN(M,J,N,M_T,0,N_T),EPKERN(M,J,N,M_T,L,N_T)
C
                 ELSE
C
                    EPKERN(M,J,N,M_T,0,N_T)=C_ZERO
                    EPKERN(M,J,N,M_T,L,N_T)=C_ZERO
C
                 END IF
C
C=======================================================================
C
                 IF (MVERK2.GE.6) THEN
C
                    READ (NFIKER,END=3215,ERR=3215)
     *              BZKERN(M,J,N,M_T,L,N_T),
     *              B2KERN(M,J,N,M_T,L,N_T)
C
                 ELSE
C
                    BZKERN(M,J,N,M_T,L,N_T)=C_ZERO
                    B2KERN(M,J,N,M_T,L,N_T)=C_ZERO
C
                 END IF
C
             END IF
C
             ISALGA(I,K)=ISALGA(I,K)+1
C
             ISAALL(I,J,K,L)=ISAALL(I,J,K,L)+1
C
             ISPOIN(I,J,K,I_T,L,K_T)=ISPOIN(I,J,K,I_T,L,K_T)+1
C
             NUPOIN=NUPOIN+1
C
             IPRINT=0
             IF (IPRINT.GT.0)
     *           WRITE(NFIPRI,'(1H*,2X,A14,'' NUPN ='',I7,
     *                            '' I ='',I3,'' J ='',I3,  '' K ='',I3,
     *                          '' I_T ='',I3,'' L ='',I3,'' K_T ='',I3,
     *                          1X,1H*)')
     *
     *           FILACT(01:14),NUPOIN,I,J,K,I_T,L,K_T
C
C=======================================================================
C         HERE JUMP TO READING THE NEXT SET OF GAUSS KNOTS
C=======================================================================
C
             GO TO 3216
C
 3215        IF (NAMKER.EQ.1) THEN
C
                 WRITE (NFIPRI,'('' ERROR READING FILE: '',A)') FILACT
             ELSE
                 WRITE (NFIPRI,'('' ERROR READING FILE: '',A)') FILAC2
C
             END IF
C
 3219        CLOSE(NFIKER)
C
C=======================================================================
C         HERE JUMP TO READING THE NEXT FILE
C=======================================================================
C
             GO TO 3218
C
 3217        CONTINUE
C
          END DO
C
          WRITE(NFIPRI,'(1H*,2X,''NUMBER OF FILES READ ='',I6,'',  '',
     *                         ''NUMBER OF POINTS READ ='',I8,13X,1H*,/,
     *                                    1H*,77X,1H*)')
     *    IFIKER,NUPOIN
C
          IF (MVERK2.GT.0.AND.MVERK2.LT.3.AND.MMARED.GE.1)
     *
     *        WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' ATTENTION: PROTON KERNELS OF MAGNETIC MOMENTS'',
     *               '' HAVE BEEN READ FROM DISK   '',  2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
C=======================================================================
C         HERE WE PRINT THE TABLE OF SPIN KNOTS THAT HAVE ALREADY BEEN
C         CALCULATED.
C=======================================================================
C
          ISDONE=1
C
          IF (LPROJJ.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE MATRIX OF ANGULAR-MOMENTUM KERNELS THAT'',
     *               '' HAVE ALREADY BEEN CALCULATED:'',  2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
              IS_PRO=0
C
              DO I=1,NUAKNO
                 DO K=1,NUAKNO
                    DO J=1,NUBKNO
C
                       NUPOIN=0
C
                       DO I_T=1,NATKNO
                          DO K_T=1,NATKNO
                             DO L=1,NBTKNO
C
                                IF (ISPOIN(I,J,K,I_T,L,K_T).GT.0)
     *                                                   NUPOIN=NUPOIN+1
                             END DO
                          END DO
                       END DO
C
                       IF (NUPOIN.EQ.NATKNO*NATKNO*NBTKNO) THEN
                           IS_PRO(I,K)=IS_PRO(I,K)+1
                       ELSE
                           ISDONE=0
                       END IF
C
                    END DO
                 END DO
              END DO
C
              NUABLO=(NUAKNO-MOD(NUAKNO-1,NUMCOL)-1)/NUMCOL+1
C
              IOFSET=0
              ISTART=IOFSET+1
              ISTOPP=NUAKNO
              DO KBLOCK=1,NUABLO
                 KOFSET=(KBLOCK-1)*NUMCOL
                 KSTART=KOFSET+1
                 KSTOPP=MIN(NUAKNO,KOFSET+NUMCOL)
C
                 WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
                 DO K=KSTART,KSTOPP
                    KCOLUM=K-KOFSET
C
                     LINE_0(KCOLUM)='-'
               WRITE(LINE_1(KCOLUM),'(I1)') (MOD(K,1000)-MOD(K,100))/100
               WRITE(LINE_2(KCOLUM),'(I1)') (MOD(K,100) -MOD(K,10))/10
               WRITE(LINE_3(KCOLUM),'(I1)')  MOD(K,10)
C
                 END DO
C
                 KCOLUM=KSTOPP+1-KOFSET
C
                 LINE_0(KCOLUM)=' '
                 LINE_1(KCOLUM)='|'
                 LINE_2(KCOLUM)='|'
                 LINE_3(KCOLUM)='|'
C
                 DO K=KSTOPP+2,KOFSET+NUMCOL+1
C
                    KCOLUM=K-KOFSET
C
                    LINE_0(KCOLUM)=' '
                    LINE_1(KCOLUM)=' '
                    LINE_2(KCOLUM)=' '
                    LINE_3(KCOLUM)=' '
C
                 END DO
C
                 WRITE(NFIPRI,'(
     *             1H*,1X,''   '',   1X,''GAMMA'',66X,1X,1H*,/,
     *             1H*,1X,'' A '','' '',         71A1,1X,1H*,/,
     *             1H*,1X,'' L '',''|'',         71A1,1X,1H*,/,
     *             1H*,1X,'' P '',''|'',         71A1,1X,1H*,/,
     *             1H*,1X,'' H '',''|'',         71A1,1X,1H*,/,
     *             1H*,1X,'' A '','' '',         71A1,1X,1H*)')
     *
     *             LINE_0,LINE_1,LINE_2,LINE_3,LINE_0
C
                 DO I=ISTART,ISTOPP
C
                    DO K=KSTART,KSTOPP
                       KCOLUM=K-KOFSET
                       IF (IS_PRO(I,K).LE.9) THEN
                           WRITE(LINE_1(KCOLUM),'(A1)')
     *                                              CHAR(IS_PRO(I,K)+48)
                       ELSE
                           WRITE(LINE_1(KCOLUM),'(A1)')
     *                                              CHAR(IS_PRO(I,K)+55)
                       END IF
                    END DO
C
                    KCOLUM=KSTOPP+1-KOFSET
C
                    LINE_1(KCOLUM)='|'
C
                    DO K=KSTOPP+2,KOFSET+NUMCOL+1
                       KCOLUM=K-KOFSET
                       LINE_1(KCOLUM)=' '
                    END DO
C
                    WRITE(NFIPRI,'(1H*,I4,''|'',71A1,1X,1H*)') I,LINE_1
C
                 END DO
C
                 WRITE(NFIPRI,'(1H*,1X,3X, 1X,71A1,1X,1H*)') LINE_0
                 WRITE(NFIPRI,'(1H*,77X,1H*)')
C
              END DO
C
          END IF
C
C=======================================================================
C         HERE WE PRINT THE TABLE OF ISOSPIN KNOTS THAT HAVE ALREADY
C         BEEN CALCULATED.
C=======================================================================
C
          IF (LPROJT.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE MATRIX OF ISOSPIN KERNELS THAT'',
     *               '' HAVE ALREADY BEEN CALCULATED:'',  11X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
              IS_ISO=0
C
              DO I_T=1,NATKNO
                 DO K_T=1,NATKNO
                    DO L=1,NBTKNO
C
                       NUPOIN=0
C
                       DO I=1,NUAKNO
                          DO K=1,NUAKNO
                             DO J=1,NUBKNO
C
                                IF (ISPOIN(I,J,K,I_T,L,K_T).GT.0)
     *                                                   NUPOIN=NUPOIN+1
                             END DO
                          END DO
                       END DO
C
                       IF (NUPOIN.EQ.NUAKNO*NUAKNO*NUBKNO) THEN
                           IS_ISO(I_T,K_T)=IS_ISO(I_T,K_T)+1
                       ELSE
                           ISDONE=0
                       END IF
C
                    END DO
                 END DO
              END DO
C
              NUABLO=(NATKNO-MOD(NATKNO-1,NUMCOL)-1)/NUMCOL+1
C
              IOFSET=0
              ISTART=IOFSET+1
              ISTOPP=NATKNO
              DO KBLOCK=1,NUABLO
                 KOFSET=(KBLOCK-1)*NUMCOL
                 KSTART=KOFSET+1
                 KSTOPP=MIN(NATKNO,KOFSET+NUMCOL)
C
                 WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
                 DO K=KSTART,KSTOPP
                    KCOLUM=K-KOFSET
C
                     LINE_0(KCOLUM)='-'
               WRITE(LINE_1(KCOLUM),'(I1)') (MOD(K,1000)-MOD(K,100))/100
               WRITE(LINE_2(KCOLUM),'(I1)') (MOD(K,100) -MOD(K,10))/10
               WRITE(LINE_3(KCOLUM),'(I1)')  MOD(K,10)
C
                 END DO
C
                 KCOLUM=KSTOPP+1-KOFSET
C
                 LINE_0(KCOLUM)=' '
                 LINE_1(KCOLUM)='|'
                 LINE_2(KCOLUM)='|'
                 LINE_3(KCOLUM)='|'
C
                 DO K=KSTOPP+2,KOFSET+NUMCOL+1
C
                    KCOLUM=K-KOFSET
C
                    LINE_0(KCOLUM)=' '
                    LINE_1(KCOLUM)=' '
                    LINE_2(KCOLUM)=' '
                    LINE_3(KCOLUM)=' '
C
                 END DO
C
                 WRITE(NFIPRI,'(
     *             1H*,1X,''   '',   1X,''GAMMA_T'',64X,1X,1H*,/,
     *             1H*,1X,'' A '','' '',         71A1,1X,1H*,/,
     *             1H*,1X,'' L '',''|'',         71A1,1X,1H*,/,
     *             1H*,1X,'' P '',''|'',         71A1,1X,1H*,/,
     *             1H*,1X,'' H '',''|'',         71A1,1X,1H*,/,
     *             1H*,1X,'' T '','' '',         71A1,1X,1H*)')
     *
     *             LINE_0,LINE_1,LINE_2,LINE_3,LINE_0
C
                 DO I_T=ISTART,ISTOPP
C
                    DO K_T=KSTART,KSTOPP
                       KCOLUM=K_T-KOFSET
                       IF (IS_ISO(I_T,K_T).LE.9) THEN
                           WRITE(LINE_1(KCOLUM),'(A1)')
     *                                          CHAR(IS_ISO(I_T,K_T)+48)
                       ELSE
                           WRITE(LINE_1(KCOLUM),'(A1)')
     *                                          CHAR(IS_ISO(I_T,K_T)+55)
                       END IF
                    END DO
C
                    KCOLUM=KSTOPP+1-KOFSET
C
                    LINE_1(KCOLUM)='|'
C
                    DO K=KSTOPP+2,KOFSET+NUMCOL+1
                       KCOLUM=K-KOFSET
                       LINE_1(KCOLUM)=' '
                    END DO
C
                    WRITE(NFIPRI,'(1H*,I4,''|'',71A1,1X,1H*)')I_T,LINE_1
C
                 END DO
C
                 WRITE(NFIPRI,'(1H*,1X,3X, 1X,71A1,1X,1H*)') LINE_0
                 WRITE(NFIPRI,'(1H*,77X,1H*)')
C
              END DO
C
          END IF
C
          IF (IPAKER.EQ.-1.AND.ISDONE.EQ.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' PARALLEL CALCULATIONS OF KERNELS'',
     *               '' HAVE NOT YET BEEN COMPLETED.'',  14X,1H*,/,
     *        1H*,1X,'' PLEASE COMPLETE THE PARALLEL CALCULATIONS'',
     *               '' OR RERUN THE JOB WITH IPAKER=0'', 3X,1H*,/,
     *                                      1H*,77X,1H*,/,79(1H*),/)')
C
              GO TO 11
C
          END IF
C
      END IF
C
C=======================================================================
C  IN CASE OF HFB,  THE NORMALISATION FACTORS  FOR BOTH THE PFAFFIAN AND
C  ONISHI FORMULAS FROM WHICH THE OVERLAP KERNEL IS OBTAINED, AS WELL AS
C  SOME BLOCKS OF THE PFAFFIAN MATRIX,  DO  NOT  DEPEND  ON THE SYMMETRY
C  OPERATOR.  ACCORDINGLY,  THEY ARE COMPUTED  HERE  BEFORE ENTERING THE
C  LOOPS OVER THE EULER/EULER-ISO/GAUGE ANGLES. THE NORMALISATION FACTOR
C  ARE CALCULATED BY CALLING  THE PFAFFIAN OR ONISHI ROUNTINES OVRPFA OR
C  OR OVRONI, WHILE THE DIAGONAL BLOCKS OF THE PFAFFIAN MATRIX ARE BUILT
C  IN THE SUBROUTINE PRPFAF. FOR ODD/MULTI-QP STATES, IBLQPY(X,1:NDBLOC)
C  CONTAINS  THE LABELS OF THE UPPER (X=0) AND LOWER (X=1) COMPONENTS OF
C  THE NDBLOC BLOCKED QP IN THE LEFT (Y=L) RIGHT (Y=R) SATES.
C  FROM VERSION 2.99H, THE CUTPFA ROUTINE HAS BEEN REMOVED.
C=======================================================================
C  FOR OFF-DIAGONAL KERNELS, THE NUMBER OF QP LUPPER IS THE SAME FOR THE
C  LEFT AND RIGHT STATES.  THIS IS CHECKED IN THE SUBROUTINE READWF WHEN
C  THE LEFT STATES (SALEFT) ARE READ.
C=======================================================================
C
      IF (IPAHFB.EQ.1) THEN
C
          IF (NBTKNO.NE.1) STOP
     *       'ISO PROJECTION WITH PAIRING IS NOT READY YET IN PROANG'
C
          IF (ISIMPY.EQ.1) STOP
     *       'ISIMPY=1 WITH IPAHFB=1 IS NOT READY YET IN PROANG'
C
          LMAXUR=MAXVAL(LDUPPE(:))+NDBLOC
C
          IF (IONISH.NE.1) THEN
C
             ALLOCATE (TBTALF(1:LMAXUR,1:LMAXUR,0:NDISOS),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('TBTALF','PROANG')
             ALLOCATE (TBTARG(1:LMAXUR,1:LMAXUR,0:NDISOS),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('TBTARG','PROANG')
C
          END IF
C
          DO ICHARG=0,NDISOS
C
             IF (KPAHFB(ICHARG).EQ.0) GO TO 9034
C
C=======================================================================
C         FETCHING THE RIGHT & LEFT WAVE FUNCTIONS FOR THE GIVEN CHARGE.
C         IBLOCR/L INDICATE IF THE  HFB RIGHT/LEFT STATE FOR THE CURRENT
C         ICHARG IS A BLOCKED STATE (1) OR NOT (0).
C=======================================================================
C
             LUPPER=LDUPPE(ICHARG)
             LSTATE=LDTOTS(ICHARG)
             IBLOCR=LPRODR(ICHARG)
             WARIGH(:,:,:)=SARIGH(:,:,:,ICHARG,1)
C
             IF (IDIAGO.EQ.1) THEN
C
                 IBLOCL=IBLOCR
                 WALEFT(:,:,:)=SARIGH(:,:,:,ICHARG,1)
             ELSE
                 IBLOCL=LPRODL(ICHARG)
                 WALEFT(:,:,:)=SALEFT(:,:,:,ICHARG)
C
             END IF
C
C=======================================================================
C         MANAGING THE DATA REQUIRED FOR THE PROJECTION OF  BLOCKED  HFB
C         STATES, WHICH IS POSSIBLE ONLY USING THE  PFAFFIAN FORMULA FOR
C         THE OVERLAPS, I.E. IONISH=0.
C=======================================================================
C         COLLECT IN IBLQPR(Q,:) THE LABELS OF THE UPPER (Q=0) AND LOWER
C         COMPONENTS (Q=1) OF THE BLOCKED QP FOR  RIGHT AND LEFT  STATES
C         AND COUNTS THE NUMBER OF BLOCKED QP.
C         IDBLOR/L COUNT THE NUMBER OF BLCKED QP FOR THE CURRENT ICHARG,
C         AND ARE STORED IN LDBLOR/L.
C=======================================================================
C         FOR NON-BLOCKED STATES,  THE SUBROUTINE  INIADD  IS  CALLED TO
C         INITIALIZE WLABBR, WLABBR.
C=======================================================================
C
             IF (IONISH.EQ.0) THEN
C
                 CALL INIADD
C
                 IBLQPR(0,:)=WLABBR(ICHARG,:)
                 IBLQPR(1,:)=WLABAR(ICHARG,:)
C
                 IF (ISIQTY.EQ.0.AND.ISIMPY.EQ.0) THEN
                   IF (ICHARG.EQ.0) IDBLOR=SUM(ABS(IDSIZN(1:NDBLOC)))
                   IF (ICHARG.EQ.1) IDBLOR=SUM(ABS(IDSIZP(1:NDBLOC)))
C
                 ELSE IF (ISIQTY.EQ.1.AND.ISIMPY.EQ.0) THEN
                   IF (ICHARG.EQ.0) IDBLOR=SUM(ABS(IDSIQN(1:NDBLOC)))
                   IF (ICHARG.EQ.1) IDBLOR=SUM(ABS(IDSIQP(1:NDBLOC)))
                 ELSE
                   STOP ' WRONG SYMMETRY IN PROANG'
                 END IF
C
                 LDBLOR(ICHARG)=IDBLOR
C
                 IF (IDIAGO.EQ.1) THEN
C
                     IDBLOL=IDBLOR
                     IBLQPL(:,:)=IBLQPR(:,:)
                 ELSE
                     IBLQPL(0,:)=WLABBL(ICHARG,:)
                     IBLQPL(1,:)=WLABAL(ICHARG,:)
                     IDBLOL=LDBLOL(ICHARG)
C
                 END IF
C
             ELSE
C
                 IF (IBLOCR.EQ.1.OR.IBLOCL.EQ.1) STOP
     *          'IONISH=1 WITH QP BLOCKING NOT POSSIBLE IN PROANG'
C
             END IF
C
C=======================================================================
C         COMPUTING THE NORM OF THE RIGHT STATE
C=======================================================================
C
             IF (IONISH.EQ.0) THEN
C
                 LDDIAB=LUPPER+NDBLOC
                 ALLOCATE (BTAPRG(1:LDDIAB,1:LDDIAB),STAT=IALLOC)
                 IF (IALLOC.NE.0) CALL NOALLO('BTAPRG','PROANG')
                 ALLOCATE (BTAPLF(1:LDDIAB,1:LDDIAB),STAT=IALLOC)
                 IF (IALLOC.NE.0) CALL NOALLO('BTAPLF','PROANG')
C
                 CALL PRPFAF(LDBASE,LUPPER,IBLOCR,IDBLOR,IBLQPR,
     *                       WARIGH,BTAPLF,BTAPRG)
C
                 PREPFA(1)=C_UNIT
                 PREPFA(2)=C_ZERO
C
                 CALL OVRPFA(LDBASE,LUPPER,IBLOCR,IBLOCR,
     *                       IDBLOR,IDBLOR,IBLQPR,IBLQPR,PREPFA,
     *                       WARIGH,WARIGH,BTAPLF,PFAWRK,ICHARG)
C
             ELSE
C
                 PREONI(1)=C_UNIT
                 PREONI(2)=C_ZERO
C
                 DETWRK(1)=C_UNIT
                 DETWRK(2)=C_ZERO
C
                 CALL OVRONI(LDBASE,LUPPER,PREONI,DETWRK,
     *                       WARIGH,WARIGH,ONIWRK)
C
             END IF
C
C=======================================================================
C          IF IDIAGO=1, STORE THE DIAGONAL BLOCKS AND PREFACTOR.
C=======================================================================
C
             IF (IDIAGO.EQ.1) THEN
C
                 IF (IONISH.EQ.0) THEN
C
                     TBTALF(1:LDDIAB,1:LDDIAB,ICHARG)=
     *                                     BTAPLF(1:LDDIAB,1:LDDIAB)
                     TBTARG(1:LDDIAB,1:LDDIAB,ICHARG)=
     *                                     BTAPRG(1:LDDIAB,1:LDDIAB)
C
                     TREPFA(1,ICHARG)=
     *                             CMPLX(1.0D0/ABS(PFAWRK(1)),0.0D0)
                     TREPFA(2,ICHARG)=-PFAWRK(2)
C
                 ELSE
C
                     TREONI(1,ICHARG)=
     *                             CMPLX(1.0D0/ABS(ONIWRK(1)),0.0D0)
                     TREONI(2,ICHARG)=-ONIWRK(2)
C
                 END IF
C
C=======================================================================
C          IF IDIAGO=0, BUILD THE LEFT STATE CONTRIBUTION.
C=======================================================================
C
             ELSE ! IDIAGO = 0
C
                 IF (IONISH.EQ.0) THEN
C
                     TBTARG(1:LDDIAB,1:LDDIAB,ICHARG)=
     *                                     BTAPRG(1:LDDIAB,1:LDDIAB)
C
                     TREPFA(1,ICHARG)=
     *                       CMPLX(1.0D0/SQRT(ABS(PFAWRK(1))),0.0D0)
                     TREPFA(2,ICHARG)=-0.5D0*PFAWRK(2)
C
                     CALL PRPFAF(LDBASE,LUPPER,IBLOCL,IDBLOL,IBLQPL,
     *                           WALEFT,BTAPLF,BTAPRG)
C
                     PREPFA(1)=C_UNIT
                     PREPFA(2)=C_ZERO
C
                     CALL OVRPFA(LDBASE,LUPPER,IBLOCL,IBLOCL,
     *                           IDBLOL,IDBLOL,IBLQPL,IBLQPL,PREPFA,
     *                           WALEFT,WALEFT,BTAPLF,PFAWRK,ICHARG)
C
                     TBTALF(1:LDDIAB,1:LDDIAB,ICHARG)=
     *                                     BTAPLF(1:LDDIAB,1:LDDIAB)
C
                     TREPFA(1,ICHARG)=TREPFA(1,ICHARG)
     *                      *CMPLX(1.0D0/SQRT(ABS(PFAWRK(1))),0.0D0)
                     TREPFA(2,ICHARG)=TREPFA(2,ICHARG)
     *                               -0.5D0*PFAWRK(2)
C
                 ELSE
C
                     TREONI(1,ICHARG)=
     *                       CMPLX(1.0D0/SQRT(ABS(ONIWRK(1))),0.0D0)
                     TREONI(2,ICHARG)=-0.5D0*ONIWRK(2)
C
                     PREONI(1)=C_UNIT
                     PREONI(2)=C_ZERO
C
                     DETWRK(1)=C_UNIT
                     DETWRK(2)=C_ZERO
C
                     CALL OVRONI(LDBASE,LUPPER,PREONI,DETWRK,
     *                           WALEFT,WALEFT,ONIWRK)
C
                     TREONI(1,ICHARG)=TREONI(1,ICHARG)
     *                      *CMPLX(1.0D0/SQRT(ABS(ONIWRK(1))),0.0D0)
                     TREONI(2,ICHARG)=TREONI(2,ICHARG)
     *                               -0.5D0*ONIWRK(2)
C
                 END IF
C
             END IF
C
             IF (IONISH.EQ.0) DEALLOCATE (BTAPLF,BTAPRG)
C
 9034        CONTINUE
C
          END DO ! ICHARG
      END IF !END IF IPAHFB=1
C
C=======================================================================
C         HERE BEGIN THE LOOPS (NO. 1) OVER THE ALPHA AND GAMMA GAUSS
C         KNOTS.
C=======================================================================
C
      NUALGA=0
      NUAALL=0
      IOPEND=0
C
      DO I=NUABEG,NUAEND
         DO K=NUGBEG,NUGEND
C
            IF (ISALGA(I,K).GE.1.AND.IPAALL.NE.1.AND.ISAKER.EQ.1)GO TO 9
C
            NUALGA=NUALGA+1
C
C=======================================================================
C         THE TRICK BELOW IS INTRODUCED IN ORDER TO SAVE MEMORY,
C         SEE COMMENTS ABOVE
C=======================================================================
C
                             M=I
            IF (IPAKER.EQ.1) M=1
                             N=K
            IF (IPAKER.EQ.1) N=1
C
C=======================================================================
C         HERE BEGINS THE LOOP (NO. 1) OVER THE BETA GAUSS KNOTS.
C=======================================================================
C
            DO J=NUBBEG,NUBEND
C
               ALPROT=XA_PNT(I)
               BETROT=XB_PNT(J)
               GAMROT=XA_PNT(K)
C
C=======================================================================
C         HERE BEGINS THE LOOP (NO. 1) OVER THE BETISO GAUSS KNOTS.
C=======================================================================
C
               DO L=NBTBEG,NBTEND
C
                  IF (ISAALL(I,J,K,L).GE.1.AND.IPAALL.EQ.1.AND.
     *                                         ISAKER.EQ.1) GO TO 899
                  NUAALL=NUAALL+1
C
C=======================================================================
C         HERE BEGIN THE LOOPS (NO. 1) OVER THE ALPHA_T AND GAMMA_T
C         ISOSPIN GAUSS  KNOTS (NOT INDENTED).
C=======================================================================
C
                  DO I_T=NATBEG,NATEND
                     DO K_T=NGTBEG,NGTEND
C
                        ALPISO=XAT_PN(I_T)
                        BETISO=XBT_PN(L)
                        GAMISO=XAT_PN(K_T)
C
                        IF (ISPOIN(I,J,K,I_T,L,K_T).GE.1.AND.
     *                                             ISAKER.EQ.2) GO TO 89
C
C=======================================================================
C         THE TRICK BELOW IS INTRODUCED IN ORDER TO SAVE MEMORY,
C         SEE COMMENTS ABOVE
C=======================================================================
C
                                         M_T=I_T
                        IF (IPAK3D.EQ.1) M_T=1
                                         N_T=K_T
                        IF (IPAK3D.EQ.1) N_T=1
C
C=======================================================================
C         ZEROING ARRAYS WITH KERNELS AGAIN FOR IPAKER=1
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.98B) AND (3.20S), FOR IPAKER=1,
C                    AND AFTER READING THE KERNEL FILES IN "PROANG", THE
C                    KERNEL ARRAYS WERE NOT ZEROED.  HOWEVER,  BEGINNING
C                    WITH VERSION (2.98B), THE KERNELS WERE NOT  DEFINED
C                    BUT ADDITIONALLY SUMMED UP, SO AS TO INTEGRATE OVER
C                    THE PARTICLE NUMBERS AND PARITY. AS A  RESULT,  FOR
C                    IPAKER=1, THEIR VALUES STORED AT M=1 AND  K=1  WERE
C                    ERRONOUSLY PILING UP. THIS BUG WENT UNDETECTED  FOR
C                    A LONG TIME BECAUSE FOR THE  IPAKER=1  CALCULATIONS
C                    PERFORMED FOR SEPARATE VALUES OF M AND K,  THE  BUG
C                    WAS NOT  SHOWING  UP.  THE  BUG  WAS  CORRECTED  ON
C                    28/10/2023 IN VERSION (3.20T).
C=======================================================================
C
      IF (IPAKER.EQ.1) THEN ! NOT INDENTED
C
      QPKERN(:,:,:,:)  =C_ZERO
      ATKERN(:,:,:,:,:)=C_ZERO
      SPKERN(:,:,:,:)  =C_ZERO
      IF (NASORD.GE.0)
     *WTKERN(:,:,:,:,:)=C_ZERO
C
C TER TEKERN=C_ZERO
      OVKERN=C_ZERO
      SKKERN=C_ZERO
      EKKERN=C_ZERO
C
      EPKERN=C_ZERO
C
      CDKERN=C_ZERO
      CDKE10=C_ZERO
      CDKE1P=C_ZERO
      CDKE1M=C_ZERO
      CDKE20=C_ZERO
      CDK21P=C_ZERO
      CDK21M=C_ZERO
      CDK22P=C_ZERO
      CDK22M=C_ZERO
      CXKERN=C_ZERO
      CXKE10=C_ZERO
      CXKE1P=C_ZERO
      CXKE1M=C_ZERO
      CXKE20=C_ZERO
      CXK21P=C_ZERO
      CXK21M=C_ZERO
      CXK22P=C_ZERO
      CXK22M=C_ZERO
      PNKE00=C_ZERO
      PNKE10=C_ZERO
      PNKE1P=C_ZERO
      PNKE1M=C_ZERO
      TZKERN=C_ZERO
      T2KERN=C_ZERO
      BZKERN=C_ZERO
      B2KERN=C_ZERO
C===========================================================
C TER TETERN(:,:,:,:,:)=C_ZERO
      OVTERN(:,:,:,:)=C_ZERO
      SKTERN(:,:,:,:)=C_ZERO
      EKTERN(:,:,:,:)=C_ZERO
      EPTERN(:,:,:,:)=C_ZERO
      CDTERN(:,:,:,:)=C_ZERO
      CDTE10(:,:,:,:)=C_ZERO
      CDTE1P(:,:,:,:)=C_ZERO
      CDTE1M(:,:,:,:)=C_ZERO
      CDTE20(:,:,:,:)=C_ZERO
      CDT21P(:,:,:,:)=C_ZERO
      CDT21M(:,:,:,:)=C_ZERO
      CDT22P(:,:,:,:)=C_ZERO
      CDT22M(:,:,:,:)=C_ZERO
      CXTERN(:,:,:,:)=C_ZERO
      CXTE10(:,:,:,:)=C_ZERO
      CXTE1P(:,:,:,:)=C_ZERO
      CXTE1M(:,:,:,:)=C_ZERO
      CXTE20(:,:,:,:)=C_ZERO
      CXT21P(:,:,:,:)=C_ZERO
      CXT21M(:,:,:,:)=C_ZERO
      CXT22P(:,:,:,:)=C_ZERO
      CXT22M(:,:,:,:)=C_ZERO
      PNTE00(:,:,:,:)=C_ZERO
      PNTE10(:,:,:,:)=C_ZERO
      PNTE1P(:,:,:,:)=C_ZERO
      PNTE1M(:,:,:,:)=C_ZERO
      TZTERN(:,:,:,:)=C_ZERO
      T2TERN(:,:,:,:)=C_ZERO
      BZTERN(:,:,:,:)=C_ZERO
      B2TERN(:,:,:,:)=C_ZERO
C
      END IF ! NOT INDENTED
C
C=======================================================================
C         HERE BEGIN THE LOOPS OF  INTEGRATION  OVER  THE  GAUGE  ANGLES
C         (FOR THE TOTAL-PARTICLE-NUMBER  AND  ISOVECTOR-PARTICLE-NUMBER
C         PROJECTIONS=PNP  AND  IVP)  AND  OVER  THE  PARITY   INVERSION
C         (FOR THE PARITY-SYMMETRY PROJECTION=PSP).
C
C         ATTENTION: THESE THREE LOOPS ARE  N O T  INDENTED.
C
C         ATTENTION: THE TRANSFORMED KERNELS ARE  NOT  STORED,  BUT  THE
C                    INTEGRATION IS PERFORMED ON THE FLY AND  LATER  THE
C                    PNP, IVP, AND/OR PSP PROJECTED KERNELS ARE  STORED.
C                    THIS MEANS THAT PROJECTIONS  ON  ONLY  O_N_E  VALUE
C                    OF THE TOTAL PARTICLE NUMBER "IN_FIX+IZ_FIX", O_N_E
C                    VALUE OF THE ISOV. PARTICLE NUMBER "IN_FIX-IZ_FIX",
C                    AND  ONLY  ON  O_N_E  PARITY  IS  PERFORMED.  THESE
C                    RESTRICTIONS WERE INTRODUCED TO MAINTAIN  THE  SAME
C                    STRUCTURE  OF THE KERNEL  ARRAYS  THAT  BEFORE  HAD
C                    BEEN  IMPLEMENTED  WITHOUT  THE  PNP,  IVP,  AND/OR
C                    PARITY PROJECTIONS.
C=======================================================================
C
                        DO IREFLE=1,NPAKNO
C
                        DO IGAUGE=1,NPNKNO
C
                           PHIGAU=XG_PNT(IGAUGE)
C
                           FACGAP=XP_WGT(IREFLE)*XG_WGT(IGAUGE)*
     *                            EXP(-UNIT_I*PHIGAU*NPNPAR)
C
                        DO IGAUTZ=1,NTZKNO
C
                           PHI_TZ=XT_PNT(IGAUTZ)
C
                           FACGAP=FACGAP        *XT_WGT(IGAUTZ)*
     *                            EXP(-UNIT_I*PHI_TZ*NTZPAR)
C
C=======================================================================
C         BEGINNING THE BLOCK WITHOUT ALPHA_T AND GAMMA_T ROTATION
C=======================================================================
C
                        IF (NATKNO.GT.1) GO TO 6342
C
C    ----->  BEGINNING OF INTERNAL CHARGE LOOP (NO. 1):
C
                        DO ICHARG=0,NDISOS
C
                           MPAHFB=KPAHFB(ICHARG)
C
                           LSTATE=LDTOTS(ICHARG)
                           LUPPER=LDUPPE(ICHARG)
C
C=======================================================================
C         FETCHING THE RIGHT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                           DO ISTATE=1,LSTATE
                              DO IBASE=1,LDBASE
                                 DO ISPIN=0,NDSPIN
C
                                    WARIGH(IBASE,ISTATE,ISPIN)=
     *                              SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1)
C
                                 END DO
                              END DO
                           END DO
C
C=======================================================================
C  ROTATING THE RIGHT WAVE FUNCTIONS IN SPACE BY THE GIVEN EULER ANGLES
C  AND STORING BOTH NEUTRON AND PROTON SPACE - ROTATED STATES IN TARIGH
C
C          TARIGH CONTAINS RIGHT EIGENVECTOR ROTATED IN SPACE
C                  IN DOUBLE-DIMENSION REPRESENTATION
C
C               |       V_n        |       V_p        |
C               | -----------------| -----------------|
C               |       V_n        |       V_p        |
C
C        SUBSEQUENT ROTATION IN THE ISOSPACE WILL RESULT IN THE
C                  FOLLOWING BETISO ANGLE DEPENDENCE
C
C               | COS(BETISO/2) V_n| -SIN(BETISO/2) V_p|
C               | -----------------| ------------------|
C               | SIN(BETISO/2) V_n|  COS(BETISO/2) V_p|
C
C                      !!!I M P O R T A N T!!!
C        THE BETISO DEPENDENCE WILL BE TAKEN CARE OF EXPLICITELY
C            BOTH IN THE OVERLAP AND THE HAMILTONIAN KERNELS
C=======================================================================
C  NOTE:  WHEN MPAHFB=1, THE ROUTINE ROTWAV ROTATES THE  UPPER COMPONENT
C  OF THE QP  (THAT TRANSFORM AS SINGLE-PARTICLE STATES),  WHILE  ROTLQP
C  ROTATES THE LOWER COMPONENTS (THAT ARE TRANSFORMED VIA R*).
C=======================================================================
C
                           IF (NUAKNO.GT.1.OR.NUBKNO.GT.1) THEN
C
                               IF (MPAHFB.EQ.1) THEN
C
                                  CALL ROTWAV(LUPPER,WARIGH)
                                  CALL ROTLQP(LUPPER,LSTATE,WARIGH)
C
                               ELSE
C
                                  CALL ROTWAV(LSTATE,WARIGH)
C
                               END IF
C
                           END IF
C
                           IF (IKEINV.GE.1.OR.IKEKAR.GE.1)
     *
     *                         CALL INVWAV(LSTATE,IKEINV,IKEKAR,WARIGH)
C
C=======================================================================
C         HERE THE PARITY INVERSION IS PERFORMED
C=======================================================================
C
                           IF (IREFLE.EQ.2)
     *
     *                         CALL INVWAV(LSTATE,1,0,WARIGH)
C
C=======================================================================
C         HERE THE GAUGE ROTATION IS PERFORMED
C=======================================================================
C
                           IF (IGAUGE.GT.1)
     *
     *                         CALL GAUWAV(MPAHFB,LUPPER,LSTATE,WARIGH)
C
C=======================================================================
C         HERE THE TZ GAUGE ROTATION IS PERFORMED
C=======================================================================
C
                           IF (IGAUTZ.GT.1)
     *
     *                         CALL GTZWAV(MPAHFB,LUPPER,LSTATE,WARIGH,
     *                                                          ICHARG)
C
C=======================================================================
C
C
                           DO ISTATE=1,LSTATE
                              DO IBASE=1,LDBASE
                                 JBASE=LDBASE+IBASE
                                 DO ISPIN=0,NDSPIN
C
                                    IF (ICHARG.EQ.0) THEN
                                        TARIGH(IBASE,ISTATE,ISPIN)=
     *                                  WARIGH(IBASE,ISTATE,ISPIN)
C
                                        TARIGH(JBASE,ISTATE,ISPIN)=
     *                                  WARIGH(IBASE,ISTATE,ISPIN)
                                    ELSE
                                        JSTATE=LDTOTS(0)+ISTATE
                                        TARIGH(IBASE,JSTATE,ISPIN)=
     *                                  WARIGH(IBASE,ISTATE,ISPIN)
C
                                        TARIGH(JBASE,JSTATE,ISPIN)=
     *                                  WARIGH(IBASE,ISTATE,ISPIN)
                                    END IF
C
                                 END DO
                              END DO
                           END DO
C
C    ----->  END OF INTERNAL CHARGE LOOP (NO. 1):
C
                        END DO
C
C=======================================================================
C       AT THIS POINT WE ARE IN THE NINE-FOLD LOOP OVER  THE  SIX  EULER
C       ANGLES (THREE THE FOR TOTAL ANGULAR MOMENTUM AND THREE  FOR  THE
C       ISOSPIN) PLUS INVERSION PLUS THE GAUGE AND TZGAUGE ANGLES:
C       ALPHA, GAMMA, BETA, ALPHA_T, GAMMA_T, BETA_T, IREFLE,  PHI, PHIT
C       THAY CORRESPOND TO INDICES:
C           I,     K,    J,    I_T,    K_T,    L, IREFLE, IGAUGE, IGAUTZ
C=======================================================================
C       INDENTATION MOVES BACK FROM THE 25TH TO 12TH COLUMN
C=======================================================================
C       THE FOLLOWING PART OF THE PROGRAM WORKS ONLY IF ISOSPIN
C       PROJECTION IS OFF (NBTKNO=1). IN THIS CASE NEUTRONS AND
C                       PROTONS SEPARATE OUT.
C=======================================================================
C
           IF (NBTKNO.EQ.1) THEN
C
               DO ICHARG=0,NDISOS
C
                  MPAHFB=KPAHFB(ICHARG)
C
                  LSTATE=LDTOTS(ICHARG)
                  LUPPER=LDUPPE(ICHARG)
C
                  IF (MPAHFB.EQ.1)THEN
                      IF (LSTATE.GT.4*NDSTAT)
     *                    STOP ' LSTATE.GT.4*NDSTAT IN PROANG'
                  ELSE
                      IF (LSTATE.GT.2*NDSTAT)
     *                    STOP ' LSTATE.GT.2*NDSTAT IN PROANG'
                  END IF
C
                  DO ISTATE=1,LSTATE
                     DO JSTATE=1,LSTATE
C
                          OVRLAP(ISTATE,JSTATE)=C_ZERO
C
                     END DO
                  END DO
C
C=======================================================================
C         FETCHING THE LEFT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                  DO ISTATE=1,LSTATE
                     DO IBASE=1,LDBASE
                        DO ISPIN=0,NDSPIN
C
                           IF (IDIAGO.EQ.1) THEN
C
                               WALEFT(IBASE,ISTATE,ISPIN)=
     *                         SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1)
C
                           ELSE
C
                               WALEFT(IBASE,ISTATE,ISPIN)=
     *                         SALEFT(IBASE,ISTATE,ISPIN,ICHARG)
C
                           END IF
C
                        END DO
                     END DO
                  END DO
C
C=======================================================================
C FETCHING THE RIGHT (SPACE ROTATED) WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                  DO ISTATE=1,LSTATE
                     DO IBASE=1,LDBASE
                        JBASE=LDBASE+IBASE
                        DO ISPIN=0,NDSPIN
C
                              IF (ICHARG.EQ.0) THEN
                              WARIGH(IBASE,ISTATE,ISPIN)=
     *                        TARIGH(IBASE,ISTATE,ISPIN)
                              ELSE
                              JSTATE=LDTOTS(0)+ISTATE
                              WARIGH(IBASE,ISTATE,ISPIN)=
     *                        TARIGH(JBASE,JSTATE,ISPIN)
                              END IF
C
                        END DO
                     END DO
                  END DO
C
C=======================================================================
C PREPARE THE WF FOR TRANSITION DENSITIES IN HFB CASE
C=======================================================================
C         CALCULATING THE OVERLAP BETWEEN THE LEFT AND RIGHT STATES
C=======================================================================
C
                  IF (MPAHFB.EQ.1) THEN
C
                      IF (IONISH.EQ.0) THEN
C
                          IBLOCR=LPRODR(ICHARG)
                          IBLQPR(0,:)=WLABBR(ICHARG,:)
                          IBLQPR(1,:)=WLABAR(ICHARG,:)
                          IDBLOR=LDBLOR(ICHARG)

                          IF (IDIAGO.EQ.1) THEN
                              IBLOCL=IBLOCR
                              IBLQPL(:,:)=IBLQPR(:,:)
                              IDBLOL=IDBLOR
                          ELSE
                              IBLOCL=LPRODL(ICHARG)
                              IBLQPL(0,:)=WLABBL(ICHARG,:)
                              IBLQPL(1,:)=WLABAL(ICHARG,:)
                              IDBLOL=LDBLOL(ICHARG)
                          END IF
C
                          PREPFA(:)=TREPFA(:,ICHARG)
C
                          LDDIAB=LUPPER+NDBLOC
                          ALLOCATE (BTAPRG(1:LDDIAB,1:LDDIAB)
     *                                          ,STAT=IALLOC)
                          IF (IALLOC.NE.0)
     *                               CALL NOALLO('BTAPRG','PROANG')
                          ALLOCATE (BTAPLF(1:LDDIAB,1:LDDIAB)
     *                                          ,STAT=IALLOC)
                          IF (IALLOC.NE.0)
     *                               CALL NOALLO('BTAPLF','PROANG')
C
                          BTAPLF(1:LDDIAB,1:LDDIAB)=
     *                    TBTALF(1:LDDIAB,1:LDDIAB,ICHARG)
                          BTAPRG(1:LDDIAB,1:LDDIAB)=
     *                    TBTARG(1:LDDIAB,1:LDDIAB,ICHARG)
C
                          CALL OVRPFA(LDBASE,LUPPER,IBLOCL,IBLOCR,
     *                         IDBLOL,IDBLOR,IBLQPL,IBLQPR,PREPFA,
     *                         WALEFT,WARIGH,BTAPLF,PFAWRK,ICHARG)
C
                          FACOVR(ICHARG)=PFAWRK(1)*
     *                                         10.0D0**REAL(PFAWRK(2))
C
                          DEALLOCATE (BTAPLF,BTAPRG)
C
                      END IF ! END IONISHI=0
C
C=======================================================================
C         CALCULATING THE OVERLAP MATRIX REMOVING FIRST THE RUSSIAN
C         RUSSIAN CONVENTION IN BOTH WALEFT AND WARIGH
C=======================================================================
C
                      CALL RUSSOF(LUPPER,LSTATE,WALEFT)
                      CALL RUSSOF(LUPPER,LSTATE,WARIGH)
C
                      CALL OVRMAT(LDBASE,LUPPER,WALEFT,WARIGH,OVRLAP)
C
C=======================================================================
C         INVERTING THE OVERLAP MATRIX
C=======================================================================
C
                      CALL ZGECO(OVRLAP,4*NDSTAT,LUPPER,IAUXDI,
     *                                          RICOND,AUXDIA)
                      CALL ZGEDI(OVRLAP,4*NDSTAT,LUPPER,IAUXDI,
     *                                          DETWRK,AUXDIA,11)
C
                      IF (ABS(RICOND).LT.1.0D-12) THEN
C
                          WRITE(NFIPRI,*)
     *                    'BE CAREFUL - THE OVERLAP MATRIX ',
     *                    'MAY BE SINGULAR FOR:'
                          WRITE(NFIPRI,'(''  M='',I3,''  J='',I3,
     *                                   ''  N='',I3,
     *                                   ''  ICHARG='',I1,
     *                                   ''  MPAHFB='',I1,
     *                                   ''  RICOND='',E15.5)')
     *                                   M,J,N,ICHARG,MPAHFB,RICOND
C
                      END IF
C
C=======================================================================
C         COMPUTING THE OVERLAP VIA ONISHI
C=======================================================================
C
                      IF (IONISH.EQ.1) THEN
C
                          PREONI(:)=TREONI(:,ICHARG)
C
                          CALL OVRONI(LDBASE,LUPPER,PREONI,DETWRK,
     *                                WALEFT,WARIGH,ONIWRK)

                          FACOVR(ICHARG)=ONIWRK(1)*
     *                                        10.0D0**REAL(ONIWRK(2))
C
                      END IF
C
C=======================================================================
C         MULTIPLYING THE RIGHT WAVE FUNCTIONS BY THE INVERTED OVERLAP
C         MATRIX AND PUTTING BACK THE RUSSIAN CONVENTION
C=======================================================================
C
                      WARITP(:,:,:)=C_ZERO
C
                      DO IBASE=1,LDBASE
                         DO ISTATE=1,LUPPER
                            ISTALO=ISTATE+LUPPER
                            DO ISPIN=0,NDSPIN
                               DO JSTATE=1,LUPPER
                                  JSTALO=JSTATE+LUPPER
C
                                  WARITP(IBASE,ISTATE,ISPIN)=
     *                            WARITP(IBASE,ISTATE,ISPIN)
     *                           +WARIGH(IBASE,JSTATE,ISPIN)
     *                           *OVRLAP(JSTATE,ISTATE)
C
                                  WARITP(IBASE,ISTALO,ISPIN)=
     *                            WARITP(IBASE,ISTALO,ISPIN)
     *                           +WARIGH(IBASE,JSTALO,ISPIN)
     *                           *OVRLAP(JSTATE,ISTATE)
C
                               END DO
                            END DO
                         END DO
                      END DO
C
                      WARIGH(:,:,:)=WARITP(:,:,:)
C
                      CALL RUSSON(LUPPER,LSTATE,WALEFT)
                      CALL RUSSON(LUPPER,LSTATE,WARIGH)
C
C  ------> STORING RIGHT VECTORS MULTIPLIED BY THE INVERTED OVERLAP
C          MATRIX IN TARIGH.
C
                      IF(ICHARG.EQ.0)THEN
                          TARIGH(1:LDBASE,1:LSTATE,0:NDSPIN)=
     *                    WARIGH(1:LDBASE,1:LSTATE,0:NDSPIN)
C
                          TARIGH(1+LDBASE:2*LDBASE,1:LSTATE,0:NDSPIN)=
     *                    WARIGH(1:LDBASE,1:LSTATE,0:NDSPIN)
                      ELSE
                          JSTATE=LDTOTS(0)
                          TARIGH(1:LDBASE,
     *                         JSTATE+1:JSTATE+LSTATE,0:NDSPIN)=
     *                    WARIGH(1:LDBASE,1:LSTATE,0:NDSPIN)
C
                          TARIGH(1+LDBASE:2*LDBASE,
     *                         JSTATE+1:JSTATE+LSTATE,0:NDSPIN)=
     *                    WARIGH(1:LDBASE,1:LSTATE,0:NDSPIN)
                      END IF
C
C=======================================================================
C PREPARE THE WF FOR TRANSITION DENSITIES IN HF CASE
C=======================================================================
C         CALCULATING THE OVERLAPS BETWEEN THE LEFT AND RIGHT STATES
C=======================================================================
C
                  ELSE ! MPAHFB.EQ.0
C
                      DO ISTATE=1,LSTATE
                         DO JSTATE=1,LSTATE
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  OVRLAP(ISTATE,JSTATE)=
     *                            OVRLAP(ISTATE,JSTATE)
     *                            +CONJG(WALEFT(IBASE,ISTATE,ISPIN))
     *                                  *WARIGH(IBASE,JSTATE,ISPIN)
C
                               END DO
                            END DO
                         END DO
                      END DO
C
C=======================================================================
C         INVERTING THE OVERLAP MATRIX
C=======================================================================
C
C         WRITE (*,773) M,J,N,ICHARG
C 773     FORMAT(1X,'OVERLAP PREPARED FOR:',4I4)
C
                      CALL ZGECO(OVRLAP,4*NDSTAT,LSTATE,IAUXDI,
     *                                           RICOND,AUXDIA)
                      CALL ZGEDI(OVRLAP,4*NDSTAT,LSTATE,IAUXDI,
     *                                           DETWRK,AUXDIA,11)
C
                      FACOVR(ICHARG)=DETWRK(1)
     *                                    *10.0D0**REAL(DETWRK(2))
C
C                     OVKERN(M,J,N,1,ICHARG,1)=FACOVR(ICHARG)
C
                      IF (ABS(RICOND).LT.1.0D-12) THEN
C
                          WRITE(NFIPRI,*)
     *                    'BE CAREFUL - THE OVERLAP MATRIX ',
     *                    'MAY BE SINGULAR FOR:'
                          WRITE(NFIPRI,'(''  M='',I3,''  J='',I3,
     *                                   ''  N='',I3,
     *                                   ''  ICHARG='',I1,
     *                                   ''  MPAHFB='',I1,
     *                                   ''  RICOND='',E15.5)')
     *                                   M,J,N,ICHARG,MPAHFB,RICOND
C
C
                      END IF
C
C         WRITE (*,772) M,J,N,ICHARG
C 772     FORMAT(1X,'OVERLAP INVERTED FOR:',4I4)
C
C=======================================================================
C         MULTIPLYING THE RIGHT WAVE FUNCTIONS BY THE INVERTED OVERLAP
C         MATRIX
C=======================================================================
C
                      DO IBASE=1,LDBASE
                         JBASE=  LDBASE+IBASE
C
                         DO ISTATE=1,LSTATE
                            DO ISPIN=0,NDSPIN
C
                               WARAUX(ISTATE,ISPIN)=C_ZERO
C
                               DO KSTATE=1,LSTATE
C
                                  WARAUX(ISTATE,ISPIN)=
     *                            WARAUX(ISTATE,ISPIN)
     *                           +WARIGH(IBASE,KSTATE,ISPIN)
     *                           *OVRLAP(KSTATE,ISTATE)
C
                               END DO
C
                            END DO
                         END DO
C
                         DO ISTATE=1,LSTATE
                            DO ISPIN=0,NDSPIN
C
C  ------> STORING RIGHT VECTORS MULTIPLIED BY THE INVERTED OVERLAP
C          MATRIX IN TARIGH.
C
                               IF (ICHARG.EQ.0) THEN
                                   TARIGH(IBASE,ISTATE,ISPIN)=
     *                                   WARAUX(ISTATE,ISPIN)
                                   TARIGH(JBASE,ISTATE,ISPIN)=
     *                                   WARAUX(ISTATE,ISPIN)
                               ELSE
                                   KSTATE=LDTOTS(0)+ISTATE
                                   TARIGH(IBASE,KSTATE,ISPIN)=
     *                                   WARAUX(ISTATE,ISPIN)
                                   TARIGH(JBASE,KSTATE,ISPIN)=
     *                                   WARAUX(ISTATE,ISPIN)
                               END IF
C
                            END DO
                         END DO
C
                      END DO
                  END IF!HF CASE END
               END DO
C
C=======================================================================
C    HERE WE DEFINE THE PRODUCT OF NEUTRON AND PROTON OVERLAPS
C=======================================================================
C
               FACOVT=FACOVR(0)*FACOVR(1)*FACGAP
C
               OVKERN(M,J,N,1,0,1)=
     *         OVKERN(M,J,N,1,0,1)+FACOVR(0)*FACGAP
C
               OVKERN(M,J,N,1,1,1)=
     *         OVKERN(M,J,N,1,1,1)+FACOVT
C
           END IF! NBTKNO.EQ.1 END
C
C=======================================================================
C        THE  FOLLOWING  PART  OF  THE  PROGRAM    CALCULATES   OVERLAP,
C        INVERETED   OVERLAP,  AND  MULTIPLIES  RIGHT  VECTORS  BY   THE
C        INVERTED OVERLAP MATRIX IN THE CASE OF AXIAL ISOSPIN PROJECTION
C=======================================================================
C
           IF (NBTKNO.GT.1.AND.NATKNO.EQ.1) THEN
C
               DO ICHARG=0,NDISOS
                  LSTATE=LDTOTS(ICHARG)
C
                  DO ISTATE=1,LSTATE
                     DO IBASE=1,LDBASE
                        JBASE=  LDBASE+IBASE
                        DO ISPIN=0,NDSPIN
C
                          IF (ICHARG.EQ.0) THEN
                          TARIGH(IBASE,ISTATE,ISPIN)=
     *                    TARIGH(IBASE,ISTATE,ISPIN)*
     *                                COS(BETISO/2.)
C
                          TARIGH(JBASE,ISTATE,ISPIN)=
     *                    TARIGH(JBASE,ISTATE,ISPIN)*
     *                                 SIN(BETISO/2.)
                          ELSE
                          JSTATE=LDTOTS(0)+ISTATE
                          TARIGH(IBASE,JSTATE,ISPIN)=
     *                   -TARIGH(IBASE,JSTATE,ISPIN)*
     *                                SIN(BETISO/2.)
C
                          TARIGH(JBASE,JSTATE,ISPIN)=
     *                    TARIGH(JBASE,JSTATE,ISPIN)*
     *                                COS(BETISO/2.)
C
                          END IF
C
                        END DO
                     END DO
                  END DO
C
               END DO
C
               LSTAT2=LDTOTS(0)+LDTOTS(1)
C
               IF (LSTAT2.GT.4*NDSTAT)
     *             STOP ' LSTAT2.GT.4*NDSTAT IN PROANG'
C
               DO ISTATE=1,LSTAT2
                  DO JSTATE=1,LSTAT2
C
                       OVRLAP(ISTATE,JSTATE)=C_ZERO
C
                  END DO
               END DO
C
C-----------------------------------------------------------------------
C           HERE STARTS INTERNAL LOOP OVER CHARGE (NO. 2):
C-----------------------------------------------------------------------
C
               DO ICHARG=0,NDISOS
                  LSTATE=LDTOTS(ICHARG)
C
C=======================================================================
C         FETCHING THE LEFT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                  DO ISTATE=1,LSTATE
                     DO IBASE=1,LDBASE
                        DO ISPIN=0,NDSPIN
C
                           IF (IDIAGO.EQ.1) THEN
C
                               WALEFT(IBASE,ISTATE,ISPIN)=
     *                         SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1)
C
                           ELSE
C
                               WALEFT(IBASE,ISTATE,ISPIN)=
     *                         SALEFT(IBASE,ISTATE,ISPIN,ICHARG)
C
                           END IF
C
                        END DO
                     END DO
                  END DO
C
C=======================================================================
C
                  IF (ICHARG.EQ.0) THEN
C
                      DO ISTATE=1,LDTOTS(0)
                         DO IBASE=1,LDBASE
                            JBASE=  LDBASE+IBASE
                            DO ISPIN=0,NDSPIN
C
                                  TALEFT(IBASE,ISTATE,ISPIN)=
     *                            WALEFT(IBASE,ISTATE,ISPIN)
C
                                  TALEFT(JBASE,ISTATE,ISPIN)=C_ZERO
C
                            END DO
                         END DO
                     END DO
C
                  ELSE
C
                      DO ISTATE=1,LDTOTS(1)
                         JSTATE=  LDTOTS(0)+ISTATE
                         DO IBASE=1,LDBASE
                            JBASE=  LDBASE+IBASE
                            DO ISPIN=0,NDSPIN
C
                                  TALEFT(JBASE,JSTATE,ISPIN)=
     *                            WALEFT(IBASE,ISTATE,ISPIN)
C
                                  TALEFT(IBASE,JSTATE,ISPIN)=C_ZERO
C
                            END DO
                         END DO
                     END DO
C
                  END IF
C
               END DO
C
C-----------------------------------------------------------------------
C     END OF INTERNAL CHARGE LOOP (NO. 2)- THE OVERLAP MATRIX IS LOADED
C-----------------------------------------------------------------------
C
C-----------------------------------------------------------------------
C     LOADING THE OVERLAP MATRIX:
C-----------------------------------------------------------------------
C
               DO ISTATE=1,LSTAT2
                  DO JSTATE=1,LSTAT2
                     DO IBASE=1,2*LDBASE
                        DO ISPIN=0,NDSPIN
C
                           OVRLAP(ISTATE,JSTATE)=
     *                     OVRLAP(ISTATE,JSTATE)
     *                     +CONJG(TALEFT(IBASE,ISTATE,ISPIN))
     *                           *TARIGH(IBASE,JSTATE,ISPIN)
C
                        END DO
                     END DO
                  END DO
               END DO
C-----------------------------------------------------------------------
C     THE OVERLAP MATRIX IS LOADED
C-----------------------------------------------------------------------
C
C=======================================================================
C                    INVERTING THE OVERLAP MATRIX
C=======================================================================
C
               CALL ZGECO(OVRLAP,4*NDSTAT,LSTAT2,IAUXDI,
     *                                    RICOND,AUXDIA)
               CALL ZGEDI(OVRLAP,4*NDSTAT,LSTAT2,IAUXDI,
     *                                    DETWRK,AUXDIA,11)
C
               FACOVT=DETWRK(1)*10.0D0**REAL(DETWRK(2))
     *               *FACGAP
C
               OVKERN(M,J,N,1,L,1)=
     *         OVKERN(M,J,N,1,L,1)+FACOVT
C
CJD            WRITE(*,7876) M,J,N,L,BETISO,OVKERN(M,J,N,1,L,1)
C7876          FORMAT(2X,4I3,F6.3,2X,2F16.10)
C
               IF (ABS(RICOND).LT.1.0D-12) THEN
C
                   WRITE(NFIPRI,*)
     *             'BE CAREFUL - THE OVERLAP MATRIX ',
     *             'MAY BE SINGULAR FOR:'
                   WRITE(NFIPRI,'(''  M='',I3,''  J='',I3,
     *                            ''  N='',I3,''  L='',I3,
     *                            ''  ICHARG='',I1,''  MPAHFB='',I1,
     *                            ''  RICOND='',E15.5)')
     *                            M,J,N,L,ICHARG,MPAHFB,RICOND
C
               END IF
C
C=======================================================================
C
               DO IBASE=1,2*LDBASE
C
                  DO ISTATE=1,LSTAT2
                     DO ISPIN=0,NDSPIN
C
                        WARAUX(ISTATE,ISPIN)=C_ZERO
C
                        DO KSTATE=1,LSTAT2
C
                           WARAUX(ISTATE,ISPIN)=WARAUX(ISTATE,ISPIN)
     *                                  +TARIGH(IBASE,KSTATE,ISPIN)
     *                                  *OVRLAP(KSTATE,ISTATE)
                        END DO
C
                     END DO
                  END DO
C
                  DO ISTATE=1,LSTAT2
                     DO ISPIN=0,NDSPIN
C
                        TARIGH(IBASE,ISTATE,ISPIN)=
     *                        WARAUX(ISTATE,ISPIN)
C
                     END DO
                  END DO
C
               END DO
C
C
C           ===============================================
C                  RIGHT VECTORS ARE LOADED IN TARIGH
C           ===============================================
C
           END IF
C
C=======================================================================
C         ENDING THE BLOCK FOR AXIAL ISOSPIN PROJECTION
C=======================================================================
C
 6342      CONTINUE
C
C=======================================================================
C        THE  FOLLOWING  PART  OF  THE   PROGRAM   CALCULATES   OVERLAP,
C        INVERETED  OVERLAP,  AND  MULTIPLIES  RIGHT  VECTORS   BY   THE
C        INVERTED OVERLAP MATRIX IN THE CASE OF  3D  ISOSPIN  PROJECTION
C=======================================================================
C        INDENTATION MOVES BACK FROM THE 12TH TO 10TH COLUMN
C=======================================================================
C
         IF (NATKNO.GT.1) THEN
C
C    ----->  BEGINNING OF INTERNAL CHARGE LOOP (NO. 1):
C
             LSTATE=LDTOTS(0)
C
             DO ICHARG=0,NDISOS
C
C=======================================================================
C         FETCHING THE RIGHT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                DO ISTATE=1,LSTATE
                   DO IBASE=1,LDBASE
                      DO ISPIN=0,NDSPIN
C
                         WARIGH(IBASE,ISTATE,ISPIN)=
     *                   SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1)
C
                      END DO
                   END DO
                END DO
C
C=======================================================================
C  ROTATING THE RIGHT WAVE FUNCTIONS IN SPACE BY THE GIVEN EULER ANGLES
C  AND STORING BOTH NEUTRON AND PROTON SPACE - ROTATED STATES IN TARIGH
C
C          TARIGH CONTAINS RIGHT EIGENVECTOR ROTATED IN SPACE
C                  IN DOUBLE-DIMENSION REPRESENTATION
C
C=======================================================================
C
                IF (NUBKNO.GT.1)
     *
     *              CALL ROTWAV(LSTATE,WARIGH)
C
                IF (IKEINV.GE.1.OR.IKEKAR.GE.1)
     *
     *              CALL INVWAV(LSTATE,IKEINV,IKEKAR,WARIGH)
C
                DO ISTATE=1,LSTATE
                   DO IBASE=1,LDBASE
                      JBASE=  LDBASE+IBASE
                      DO ISPIN=0,NDSPIN
C
                        IF (ICHARG.EQ.0) THEN
                        TARIGH(IBASE,ISTATE,ISPIN)=
     *                  WARIGH(IBASE,ISTATE,ISPIN)
C
                        ELSE
                        TARIGH(JBASE,ISTATE,ISPIN)=
     *                  WARIGH(IBASE,ISTATE,ISPIN)
C
                        END IF
C
                      END DO
                   END DO
                END DO
C
C    ----->  END OF INTERNAL CHARGE LOOP (NO. 1):
             END DO
C
             CALL ROTISO(LSTATE,TARIGH)
C
             LSTAT2=LDTOTS(0)
C
             IF (LSTAT2.GT.4*NDSTAT)
     *           STOP ' LSTAT2.GT.4*NDSTAT IN PROANG 2'
C
             DO ISTATE=1,LSTAT2
                DO JSTATE=1,LSTAT2
C
                     OVRLAP(ISTATE,JSTATE)=C_ZERO
C
                END DO
             END DO
C
C-----------------------------------------------------------------------
C           HERE STARTS INTERNAL LOOP OVER CHARGE (NO. 2):
C-----------------------------------------------------------------------
C
             DO ICHARG=0,NDISOS
C
C=======================================================================
C         FETCHING THE LEFT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                DO ISTATE=1,LSTATE
                   DO IBASE=1,LDBASE
                      IF (ICHARG.EQ.0) THEN
                          JBASE=IBASE
                      ELSE
                          JBASE=IBASE+LDBASE
                      END IF
                      DO ISPIN=0,NDSPIN
C
                         IF (IDIAGO.EQ.1) THEN
C
                             TALEFT(JBASE,ISTATE,ISPIN)=
     *                       SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1)
C
                         ELSE
C
                             TALEFT(JBASE,ISTATE,ISPIN)=
     *                       SALEFT(IBASE,ISTATE,ISPIN,ICHARG)
C
                             STOP ' NOT READY YET IN PROANG'
C
                         END IF
C
                      END DO
                   END DO
                END DO
C
C-----------------------------------------------------------------------
C            END OF INTERNAL CHARGE LOOP (NO. 2)
C-----------------------------------------------------------------------
C
             END DO
C
C=======================================================================
C         CALCULATING THE OVERLAPS BETWEEN THE LEFT AND RIGHT STATES
C=======================================================================
C
             DO ISTATE=1,LSTATE
                DO JSTATE=1,LSTATE
                   DO IBASE=1,2*LDBASE
                      DO ISPIN=0,NDSPIN
C
                         OVRLAP(ISTATE,JSTATE)=
     *                   OVRLAP(ISTATE,JSTATE)
     *                   +CONJG(TALEFT(IBASE,ISTATE,ISPIN))
     *                         *TARIGH(IBASE,JSTATE,ISPIN)
C
                      END DO
                   END DO
                END DO
             END DO
C
C=======================================================================
C                    INVERTING THE OVERLAP MATRIX
C=======================================================================
C
             CALL ZGECO(OVRLAP,4*NDSTAT,LSTAT2,IAUXDI,
     *                                  RICOND,AUXDIA)
             CALL ZGEDI(OVRLAP,4*NDSTAT,LSTAT2,IAUXDI,
     *                                  DETWRK,AUXDIA,11)
C
             FACOVT=DETWRK(1)*10.0D0**REAL(DETWRK(2))
     *             *FACGAP
C
             OVKERN(M,J,N,M_T,L,N_T)=
     *       OVKERN(M,J,N,M_T,L,N_T)+FACOVT
C
C            WRITE(*,7877) M,J,N, M_T,L,N_T,  I,J,K, I_T,L,K_T,
C    *                     ALPISO,BETISO,GAMISO,
C    *                     OVKERN(M,J,N,M_T,L,N_T),
C    *                 ABS(OVKERN(M,J,N,M_T,L,N_T))
C7877        FORMAT(2X,2(6I3,2X),3F6.3,2X,2F16.10,D18.10)
C
             IF (ABS(RICOND).LT.1.0D-12) THEN
C
                 WRITE(NFIPRI,*)
     *           'BE CAREFUL - THE OVERLAP MATRIX ',
     *           'MAY BE SINGULAR FOR:'
                 WRITE(NFIPRI,'(''  M='',I3,''  J='',I3,
     *                          ''  N='',I3,''  L='',I3,
     *                          ''  ICHARG='',I1,''  MPAHFB='',I1,
     *                          ''  RICOND='',E15.5)')
     *                          M,J,N,L,ICHARG,MPAHFB,RICOND
C
             END IF
C
             DO IBASE=1,2*LDBASE
C
                DO ISTATE=1,LSTATE
                   DO ISPIN=0,NDSPIN
C
                      WARAUX(ISTATE,ISPIN)=C_ZERO
C
                      DO KSTATE=1,LSTATE
C
                         WARAUX(ISTATE,ISPIN)=WARAUX(ISTATE,ISPIN)
     *                                +TARIGH(IBASE,KSTATE,ISPIN)
     *                                *OVRLAP(KSTATE,ISTATE)
                      END DO
C
                   END DO
                END DO
C
                DO ISTATE=1,LSTATE
                   DO ISPIN=0,NDSPIN
C
                      TARIGH(IBASE,ISTATE,ISPIN)=
     *                      WARAUX(ISTATE,ISPIN)
C
                   END DO
                END DO
C
             END DO
C
C=======================================================================
C         ENDING THE BLOCK FOR 3D ISOSPIN PROJECTION
C=======================================================================
C
         END IF
C
C=======================================================================
C
C              HERE STARTS "DENSITIES AND CURRENTS" BLOCK
C
C=======================================================================
C
C=======================================================================
C    NEW "EXTERNAL" CHARGE LOOP (NO. 3) FOR DENSITIS AND CURRENTS BLOCK
C=======================================================================
C
         DO ICHARG=0,NDISOS
C
            MPAHFB=KPAHFB(ICHARG)
C
            LSTATE=LDTOTS(ICHARG)
C
C=======================================================================
C          FETCHING THE LEFT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
            DO ISTATE=1,LSTATE
               DO IBASE=1,LDBASE
                  DO ISPIN=0,NDSPIN
C
                     IF (IDIAGO.EQ.1) THEN
C
                         WALEFT(IBASE,ISTATE,ISPIN)=
     *                   SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1)
C
                     ELSE
C
                         WALEFT(IBASE,ISTATE,ISPIN)=
     *                   SALEFT(IBASE,ISTATE,ISPIN,ICHARG)
C
                     END IF
C
                  END DO
               END DO
            END DO
C
C=======================================================================
C          HERE BEGIN CALCULATIONS OF NEUTRON-NEUTRON AND NEUTRON-PROTON
C                     DENSITIES AND OBSERVABLES
C=======================================================================
C
            IF (ICHARG.EQ.0) THEN
C
                ITPNMX=0
C
C=======================================================================
C                 ZEROING THE NEUTRON DENSITIES
C=======================================================================
C
                CALL ZEDENS(ITPNMX)
C
C=======================================================================
C            FETCHING THE RIGHT WAVE FUNCTIONS TO BE USED TO
C              CALCULATE THE NEUTRON-NEUTRON DENSITIES AND CURRENTS
C=======================================================================
C
                DO IBASE=1,LDBASE
                   DO ISTATE=1,LDTOTS(0)
                      DO ISPIN=0,NDSPIN
                        WARIGH(IBASE,ISTATE,ISPIN)
     *                 =TARIGH(IBASE,ISTATE,ISPIN)
                      END DO
                   END DO
                END DO
C
                CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *                      ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,ICHARG,
     *                                           MIN_QP,IPNMIX,ITPNMX,
     *                             ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *                      ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                                         ITWCEN,1)
C
C=======================================================================
C                 CALCULATING THE NEUTRON TRANSITION DENSITY MATRIX
C                 AND TRANSITION  MATRIX  ELEMENTS  OF  OBSERVABLES
C=======================================================================
C
                CALL DENMAC(MREVER,ICHARG,ISIMPY,MPAHFB,WALEFT,WARIGH,1)
C
                CALL SAVDEN(ISIMPY,ITPNMX)
C
                CALL EKINET(ENEKIN,DLINSQ,EKEKIN,DKINSQ,1)
C
                IF (MPAHFB.EQ.1) THEN
C
C=======================================================================
C        CALCULATING THE   N E U T R O N   P A I R I N G   T E N S O R S
C        THAT CORRESPOND TO RIGHT-LEFT AND  LEFT-RIGHT  MATRIX  ELEMENTS
C=======================================================================
C
                    IF (KETAJ2.EQ.1.OR.KETAT2.EQ.1.OR.
     *                  IGOGPA.GE.1.OR.IREGPA.GE.1.OR.
     *                  ISEPPA.GE.1.OR.ICOUPA.GE.1) THEN
C     ACTIVATE WHEN THE PROJECTION OF SPIN-ORBIT AND TENSOR IS DONE
C                   IF (KETAJ2.EQ.1.OR.KETAT2.EQ.1.OR.
C    *                  ICOUPA.GE.1.OR.MAXVAL(IFSTPA).GE.1.OR.
C    *                  IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1) THEN
C
                        CALL PAIMAC(ICHARG,ISIMPY,
     *                              WARIGH,WALEFT,IKERNE)
C
                        CALL STO2ND(ISIMPY)
C
                        CALL PAIMAC(ICHARG,ISIMPY,
     *                              WALEFT,WARIGH,IKERNE)
C
                        CALL SAVPAI(ISIMPY,ITPNMX)
C
                    END IF
C
                END IF
C
C=======================================================================
C               FOR NBTKNO.EQ.1 KERNELS ARE STORED AT TWO VALUES OF
C                               ICHARG=0 AND 1
C               FOR NBTKNO.NE.1 KERNELS ARE SUMMED-UP FOR THE TWO VALUES
C                               OF ICHARGE=0 AND 1 AND STORED AT L
C=======================================================================
C
                IF (NBTKNO.EQ.1) THEN
                    EKKERN(M,J,N,M_T,ICHARG,N_T)=
     *              EKKERN(M,J,N,M_T,ICHARG,N_T)+EKEKIN
     *                                          *FACOVT
                ELSE
                    EKKERN(M,J,N,M_T,L,N_T     )=
     *              EKKERN(M,J,N,M_T,L,N_T     )+EKEKIN
     *                                          *FACOVT
                END IF
C
C=======================================================================
C        CALCULATING THE ANGULAR MOMENTUM TRANSITION KERNELS
C        FOR NEUTRONS
C=======================================================================
C
                IF (KETAJ2.EQ.1) THEN
C
                    META_R=1
                    BORROT=.TRUE.
C
                    CALL ROTAVR(ISIMPY,ISIGNY,ISIQTY,
     *                 MPAHFB,ICHARG,META_R,IROTAT,MREVER,BORROT,IKERNE,
     *                 DROTSN,EROTSN,PROTSN,TROTSN,AROTLN,PROTLN,PROTKN,
     *                 DKOTSN,EKOTSN,PKOTSN,TKOTSN,AKOTLN,PKOTLN,PKOTKN)
C
                END IF
C
C=======================================================================
C      SAVE BIG_PP AND BIG_PM REPRESENTING DN_RHO ON THE BASIS
C       IN BNN_PP AND BNN_PM FOR FURTHER COULOMB CALCULATIONS
C=======================================================================
C
                BNN_PP(:,:,:)=BIG_PP(:,:,:)
                IF (ISIMPY.NE.1) THEN
                    BNN_PM(:,:,:)=BIG_PM(:,:,:)
                END IF
C
                IF (NBTKNO.EQ.1) GOTO 77
C
                ITPNMX=2
C
C=======================================================================
C                 ZEROING THE NEUTRON-PROTON DENSITIES
C=======================================================================
C
                CALL ZEDENS(ITPNMX)
C
C=======================================================================
C            FETCHING THE RIGHT WAVE FUNCTIONS TO BE USED TO
C           CALCULATE THE NEUTRON-PROTON DENSITIES AND CURRENTS
C=======================================================================
C
                DO IBASE=1,LDBASE
                   JBASE=IBASE+LDBASE
                   DO ISTATE=1,LDTOTS(0)
                      DO ISPIN=0,NDSPIN
                         WARIGH(IBASE,ISTATE,ISPIN)
     *                  =TARIGH(JBASE,ISTATE,ISPIN)
                      END DO
                   END DO
                END DO
C
                CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *                      ISIGNY,ISIMPY,ISIQTY,IPAHFB,MREVER,ICHARG,
     *                                           MIN_QP,IPNMIX,ITPNMX,
     *                             ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *                      ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                                         ITWCEN,1)
C
C=======================================================================
C                 CALCULATING THE NEUTRON TRANSITION DENSITY MATRIX
C                 AND TRANSITION MATRIX ELEMENTS OF THE KINETIC ENE.
C=======================================================================
C
                CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,WALEFT,WARIGH,1)
C
                CALL SAVDEN(ISIMPY,ITPNMX)
C
C=======================================================================
C      SAVE BIG_PP AND BIG_PM REPRESENTING DNPRHO ON THE BASIS
C       IN BNP_PP AND BNP_PM FOR FURTHER COULOMB CALCULATIONS
C=======================================================================
C
                BNP_PP(:,:,:)=BIG_PP(:,:,:)
                IF (ISIMPY.NE.1) THEN
                    BNP_PM(:,:,:)=BIG_PM(:,:,:)
                END IF
C
  77            CONTINUE
C
                IF (NBTKNO.GT.1) GOTO 810
C
C=======================================================================
C                 CALCULATING TRANSITION MATRIX ELEMENTS OF NEUTRON
C                 MAGNETIC OPERATORS (CALCULATED ONLY FOR LPROJT=0).
C=======================================================================
C                 ATTENTION! ARRAY  "ATKERN" ORGANISED AS "QPKERN" BELOW
C=======================================================================
C                 ATTENTION! TO NOT TO MODIFY THE  UNPROJECTED  MOMENTS,
C                            WHICH HAS ALREADY BEEN CALCULATED IN  ARRAY
C                            "AMUL_N", IN THE CALL BELOW, A DUMMY  ARRAY
C                            "ADUM_N" IS USED (COMMENT 1).
C=======================================================================
C
                CALL MAGMOM(ISIMPY,IROTAT,ICHARG,ADUM_N,AMUT_N,NMARED,
     *                                                           NMAORD)
C
                DO LAMBDA=1,NMARED
                   DO MIU=-LAMBDA,LAMBDA
                      DO NUMORD=0,NMAORD
C
                         IF (MIU.GT.0)
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)=
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)+
     *                                   (AMUT_N(LAMBDA, MIU ,NUMORD)
     *                  -UNIT_I*(-1)**MIU*AMUT_N(LAMBDA,-MIU ,NUMORD))
     *                                                           *FACOVT
C
                         IF (MIU.EQ.0)
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)=
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)+
     *                                    AMUT_N(LAMBDA, MIU ,NUMORD)
     *                                                           *FACOVT
C
                         IF (MIU.LT.0)
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)=
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)+
     *                         ((-1)**MIU*AMUT_N(LAMBDA,-MIU ,NUMORD)
     *                            +UNIT_I*AMUT_N(LAMBDA, MIU ,NUMORD))
     *                                                           *FACOVT
C
                      END DO
                   END DO
                END DO
C
C=======================================================================
C                 CALCULATING TRANSITION MATRIX ELEMENTS OF NEUTRON
C                 SPIN-ASYMM. OPERATORS (CALCULATED ONLY FOR LPROJT=0).
C=======================================================================
C                 ATTENTION! ARRAY  "WTKERN" ORGANISED AS "QPKERN" BELOW
C=======================================================================
C                 ATTENTION! TO NOT TO MODIFY THE  UNPROJECTED  MOMENTS,
C                            WHICH HAVE ALREADY BEEN CALCULATED IN ARRAY
C                            "WMUL_N", IN THE CALL BELOW, A DUMMY  ARRAY
C                            "ADUM_N" IS USED (COMMENT 1).
C=======================================================================
C
                CALL ASMMOM(ISIMPY,IROTAT,ADUM_N,WMUT_N,NASRED,NASORD)
C
                DO LAMBDA=1,NASRED
                   DO MIU=-LAMBDA,LAMBDA
                      DO NUMORD=0,NASORD
C
                         WTKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)=
     *                   WTKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)+
     *                                WMUT_N(LAMBDA, MIU ,NUMORD)*FACOVT
                      END DO
                   END DO
                END DO
C
  810           CONTINUE
C
            END IF
C
C=======================================================================
C           HERE BEGIN CALCULATIONS OF PROTON AND PROTON-NEUTRON
C                      DENSITIES AND OBSERVABLES
C=======================================================================
C
            IF (ICHARG.EQ.1) THEN
C
                ITPNMX=1
C
C=======================================================================
C                 ZEROING THE PROTON DENSITIES
C=======================================================================
C
                CALL ZEDENS(ITPNMX)
C
C=======================================================================
C            FETCHING THE RIGHT WAVE FUNCTIONS TO BE USED TO
C          CALCULATE THE PROTON DENSITIES AND CURRENTS IN DENSHF
C=======================================================================
C
                IF (IPNMIX.EQ.1) THEN
C
                    LSHIFT=0
                ELSE
                    LSHIFT=LDTOTS(0)
C
                END IF
C
                DO IBASE=1,LDBASE
                   JBASE=  LDBASE+IBASE
                   DO ISTATE=1,LDTOTS(1)
                      JSTATE=LSHIFT+ISTATE
                      DO ISPIN=0,NDSPIN
                        WARIGH(IBASE,ISTATE,ISPIN)
     *                 =TARIGH(JBASE,JSTATE,ISPIN)
                      END DO
                   END DO
                END DO
C
C=======================================================================
C                 CALCULATING THE PROTON DENSITIES AND CURRENTS
C=======================================================================
C
                CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *                      ISIGNY,ISIMPY,ISIQTY,MPAHFB,MREVER,ICHARG,
     *                                           MIN_QP,IPNMIX,ITPNMX,
     *                             ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *                      ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                                         ITWCEN,1)
C
C=======================================================================
C                 CALCULATING THE PROTON TRANSITION DENSITY MATRIX
C               AND THE TRANSITION MATRIX ELEMENTS OF THE KINETIC ENE.
C=======================================================================
C
                CALL DENMAC(MREVER,ICHARG,ISIMPY,MPAHFB,WALEFT,WARIGH,1)
C
                CALL SAVDEN(ISIMPY,ITPNMX)
C
                CALL EKINET(ENEKIN,DLINSQ,EKEKIN,DKINSQ,1)
C
                IF (MPAHFB.EQ.1) THEN
C
C=======================================================================
C        CALCULATING THE    P R O T O N    P A I R I N G   T E N S O R S
C        THAT CORRESPOND TO RIGHT-LEFT AND  LEFT-RIGHT  MATRIX  ELEMENTS
C=======================================================================
C
                    IF (KETAJ2.EQ.1.OR.KETAT2.EQ.1.OR.
     *                  IGOGPA.GE.1.OR.IREGPA.GE.1.OR.
     *                  ISEPPA.GE.1.OR.ICOUPA.GE.1) THEN
C
                        CALL PAIMAC(ICHARG,ISIMPY,
     *                              WARIGH,WALEFT,IKERNE)
C
                        CALL STO2ND(ISIMPY)
C
                        CALL PAIMAC(ICHARG,ISIMPY,
     *                              WALEFT,WARIGH,IKERNE)
C
                        CALL SAVPAI(ISIMPY,ITPNMX)
C
                    END IF
C
                END IF
C
C=======================================================================
C        CALCULATING THE ANGULAR MOMENTUM TRANSITION KERNELS
C        FOR PROTONS
C=======================================================================
C
                IF (KETAJ2.EQ.1) THEN
C
                    META_R=1
                    BORROT=.TRUE.
C
                    CALL ROTAVR(ISIMPY,ISIGNY,ISIQTY,
     *                 MPAHFB,ICHARG,META_R,IROTAT,MREVER,BORROT,IKERNE,
     *                 DROTSP,EROTSP,PROTSP,TROTSP,AROTLP,PROTLP,PROTKP,
     *                 DKOTSP,EKOTSP,PKOTSP,TKOTSP,AKOTLP,PKOTLP,PKOTKP)
C
                END IF
C
C=======================================================================
C     CALCULATING THE PROTON KINETIC ENERGY AND COULOMB TRANSITION
C          MATRIX ELEMENTS IN A RUN WITHOUT ISOSPIN PROJECTION
C=======================================================================
C
                IF (NBTKNO.EQ.1) THEN
C
                    EKKERN(M,J,N,M_T,ICHARG,N_T)=
     *              EKKERN(M,J,N,M_T,ICHARG,N_T)+EKEKIN
     *                                          *FACOVT
C
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.22N) AND (2.32) THE CALL  TO
C                       "COUMAT" BELOW WAS PERFORMED WITH  AN  UNDEFINED
C                       VALUE OF  "IKERNE"  INSTEAD  OF  IKERNE=1.  THIS
C                       RESULTED (IN "INTCOU") IN CALCULATIONS PERFORMED
C                       FOR REAL PARTS OF TRANSITION MULTIPOLE  MOMENTS.
C                       THIS BUG WAS CORRECTED ON 23/11/2007 IN  VERSION
C                       (2.32A).
C=======================================================================
C
                    IF (ICOUDI.EQ.1.AND.ICOUEX.EQ.1) THEN
C
C  =====================================================================
C  ---> GREEN FUNCTION METHOD IS USED FOR THE DIRECT TERM WHILE SLATER
C       IS APPLIED TO CALCULATE EXCHANGE COULOMB IN THE AMP RUN:
C  =====================================================================
C
                        CALL COUMAT(NUMCOU,BOUCOU,ISIMPY,IKERNE)
C
                        CALL COULOD(ISIMPY,EKECOD)
C
                        CDKERN(M,J,N,1,1,1)=
     *                  CDKERN(M,J,N,1,1,1)+EKECOD
     *                                     *FACOVT
C
                        CALL TRUCHD
C
                        CALL COULOE(EKECOE)
C
                        CXKERN(M,J,N,1,1,1)=
     *                  CXKERN(M,J,N,1,1,1)+EKECOE
     *                                     *FACOVT
C
                    END IF
C
                    IF (ICOUDI.EQ.2.AND.ICOUEX.EQ.2) THEN
C
C  =====================================================================
C  ---> GAUSSIAN EXPANSION METHOD IS USED FOR BOTH THE DIRECT
C       AND EXCHANGE COULOMB IN THE AMP RUN:
C  =====================================================================
C
                        CALL SAVDEN(ISIMPY,1)
C
                        CALL COUENE(ISIMPY,
     *                              ICOTYP,ICOUDI,ICOUEX,
     *                                            IDOTHC,
     *                              EKECOD,EKESCA,EKEVEC)
C
                        EKECOE = EKESCA+EKEVEC
C
                        CDKERN(M,J,N,1,1,1)=
     *                  CDKERN(M,J,N,1,1,1)+EKECOD
     *                                     *FACOVT
                        CXKERN(M,J,N,1,1,1)=
     *                  CXKERN(M,J,N,1,1,1)+EKECOE
     *                                     *FACOVT
C
                    END IF
C
                ELSE
C
                    EKKERN(M,J,N,M_T,L,N_T)=EKKERN(M,J,N,M_T,L,N_T)
     *                                     +EKEKIN
     *                                     *FACOVT
                END IF
C
C=======================================================================
C      SAVE BIG_PP AND BIG_PM REPRESENTING DE_RHO ON THE BASIS
C       IN BPP_PP AND BPP_PM FOR FURTHER COULOMB CALCULATIONS
C=======================================================================
C
                BPP_PP(:,:,:)=BIG_PP(:,:,:)
                IF (ISIMPY.NE.1) THEN
                    BPP_PM(:,:,:)=BIG_PM(:,:,:)
                END IF
C
                IF (NBTKNO.EQ.1) GO TO 78
C
                ITPNMX=3
C
C=======================================================================
C                 ZEROING THE PROTON-NEUTRON DENSITIES
C=======================================================================
C
                CALL ZEDENS(ITPNMX)
C
C=======================================================================
C            FETCHING THE RIGHT WAVE FUNCTIONS TO BE USED TO
C      CALCULATE THE PROTON-NEUTRON DENSITIES AND CURRENTS IN DENSHF
C=======================================================================
C
                IF (IPNMIX.EQ.1) THEN
C
                    LSHIFT=0
                ELSE
                    LSHIFT=LDTOTS(0)
C
                END IF
C
                DO IBASE=1,LDBASE
                   DO ISTATE=1,LDTOTS(1)
                      JSTATE=LSHIFT+ISTATE
                      DO ISPIN=0,NDSPIN
                        WARIGH(IBASE,ISTATE,ISPIN)
     *                 =TARIGH(IBASE,JSTATE,ISPIN)
                      END DO
                   END DO
                END DO
C
C=======================================================================
C         CALCULATING THE PROTON-NEUTRON DENSITIES AND CURRENTS
C=======================================================================
C
                CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *                      ISIGNY,ISIMPY,ISIQTY,IPAHFB,MREVER,ICHARG,
     *                                           MIN_QP,IPNMIX,ITPNMX,
     *                             ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *                      ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                                         ITWCEN,1)
C
C=======================================================================
C                 CALCULATING THE PROTON TRANSITION DENSITY MATRIX
C                 AND TRANSITION MATRIX  ELEMENTS  OF  OBSERVABLES
C=======================================================================
C
                CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,WALEFT,WARIGH,1)
C
                CALL SAVDEN(ISIMPY,ITPNMX)
C
C=======================================================================
C      SAVE BIG_PP AND BIG_PM REPRESENTING DPNRHO ON THE BASIS
C       IN BPN_PP AND BPN_PM FOR FURTHER COULOMB CALCULATIONS
C=======================================================================
C
                BPN_PP(:,:,:)=BIG_PP(:,:,:)
                IF (ISIMPY.NE.1) THEN
                    BPN_PM(:,:,:)=BIG_PM(:,:,:)
                END IF
C
  78            CONTINUE
C
                IF (NBTKNO.GT.1) GOTO 81
C
C=======================================================================
C                 CALCULATING TRANSITION MATRIX ELEMENTS OF PROTON
C                 MULTIPOLE OPERATORS (CALCULATED ONLY FOR LPROJT=0).
C=======================================================================
C                 ATTENTION!
C                 ARRAY  "QPKERN" FOR INDICES (LAMBDA,MIU) CONTAINS  THE
C                 MATRIX ELEMENTS OF THE  COMPLETE  (COMPLEX)  MULTIPOLE
C                 OPERATOR WITHOUT PUTTING ITS REAL AND IMAGINARY  PARTS
C                 INTO THE MAGNETIC COMPONENTS WITH  MIU>=0  AND  MIU<0,
C                 RESPECTIVELY, AS IS THE CASE ELSEWHERE IN THE CODE.
C=======================================================================
C                 ATTENTION! SEE "COMMENT 1" ABOVE.
C=======================================================================
C
                CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,QDUM_P,QMUT_P,
     *                                    COMULT,JMULMO,ISHIFY,1)
C
                DO LAMBDA=0,NMURED
                   DO MIU=-LAMBDA,LAMBDA
C
                      IF (MIU.GT.0)
     *                    QPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *                    QPKERN(M,J,N,IND_LM(LAMBDA,MIU))+
     *                                            (QMUT_P(LAMBDA, MIU)
     *                           -UNIT_I*(-1)**MIU*QMUT_P(LAMBDA,-MIU))
     *                                            *FACOVT
C
                      IF (MIU.EQ.0)
     *                    QPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *                    QPKERN(M,J,N,IND_LM(LAMBDA,MIU))+
     *                                             QMUT_P(LAMBDA, MIU)
     *                                            *FACOVT
C
                      IF (MIU.LT.0)
     *                    QPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *                    QPKERN(M,J,N,IND_LM(LAMBDA,MIU))+
     *                                  ((-1)**MIU*QMUT_P(LAMBDA,-MIU)
     *                                     +UNIT_I*QMUT_P(LAMBDA, MIU))
     *                                            *FACOVT
C
                   END DO
                END DO
C
C=======================================================================
C                 CALCULATING TRANSITION MATRIX ELEMENTS OF PROTON
C                 MAGNETIC OPERATORS AND ADDING THEM TO THOSE FOR
C                 NEUTRONS, WHICH HAVE BEEN CALCULATED ABOVE.
C=======================================================================
C                 ATTENTION! ARRAY  "ATKERN" ORGANISED AS "QPKERN" ABOVE
C=======================================================================
C                 ATTENTION! SEE "COMMENT 1" ABOVE.
C=======================================================================
C
                CALL MAGMOM(ISIMPY,IROTAT,ICHARG,ADUM_P,AMUT_P,NMARED,
     *                                                           NMAORD)
C=======================================================================
C               ADDING THE TWO-BODY-CURRENT CONTRIBUTIONS TO THE  DIPOLE
C               MAGNETIC MOMENTS
C=======================================================================
C               ATTENTION: FOR NOW, THE  TWO-BODY-CURRENT  CONTRIBUTIONS
C                          TO  THE  DIPOLE MAGNETIC  MOMENTS  ARE  ADDED
C                          TO THE STANDARD  ONES  WITHOUT  STORING  THAT
C                          INFORMATION ON THE KERNEL FILE. THE  USER  IS
C                          RESPONSIBLE  FOR  READING  THE  KERNEL   FILE
C                          WITHIN EXACTLY THE SAME CONDITIONS WITH WHICH
C                          IT HAS BEEN CREATED.
C=======================================================================
C
                IF (MAXVAL(MAG2BC).GE.1) THEN
C
                    CALL ADD2BC(ISIMPY)
C
                    AMUT_P(1,-1,0)=AMUT_P(1,-1,0)+A2BCIN(-1)+A2BCSA(-1)
                    AMUT_P(1, 0,0)=AMUT_P(1, 0,0)+A2BCIN( 0)+A2BCSA( 0)
                    AMUT_P(1,+1,0)=AMUT_P(1,+1,0)+A2BCIN(+1)+A2BCSA(+1)
C
                END IF
C
C=======================================================================
C
                DO LAMBDA=1,NMARED
                   DO MIU=-LAMBDA,LAMBDA
                      DO NUMORD=0,NMAORD
C
                         IF (MIU.GT.0)
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)=
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)+
     *                                   (AMUT_P(LAMBDA, MIU ,NUMORD)
     *                  -UNIT_I*(-1)**MIU*AMUT_P(LAMBDA,-MIU ,NUMORD))
     *                                                           *FACOVT
C
                         IF (MIU.EQ.0)
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)=
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)+
     *                                    AMUT_P(LAMBDA, MIU ,NUMORD)
     *                                                           *FACOVT
C
                         IF (MIU.LT.0)
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)=
     *                       ATKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)+
     *                         ((-1)**MIU*AMUT_P(LAMBDA,-MIU ,NUMORD)
     *                            +UNIT_I*AMUT_P(LAMBDA, MIU ,NUMORD))
     *                                                           *FACOVT
C
                      END DO
                   END DO
                END DO
C
C=======================================================================
C                 CALCULATING TRANSITION MATRIX ELEMENTS OF PROTON
C                 SPIN-ASYMMETRY OPERATORS AND ADDING THEM TO THOSE FOR
C                 NEUTRONS, WHICH HAVE BEEN CALCULATED ABOVE.
C=======================================================================
C                 ATTENTION! ARRAY  "WTKERN" ORGANISED AS "QPKERN" ABOVE
C=======================================================================
C                 ATTENTION! SEE "COMMENT 1" ABOVE.
C=======================================================================
C
                CALL ASMMOM(ISIMPY,IROTAT,ADUM_P,WMUT_P,NASRED,NASORD)
C
                DO LAMBDA=1,NASRED
                   DO MIU=-LAMBDA,LAMBDA
                      DO NUMORD=0,NASORD
C
                         WTKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)=
     *                   WTKERN(M,J,N,IND_LM(LAMBDA, MIU),NUMORD)+
     *                                WMUT_P(LAMBDA, MIU ,NUMORD)*FACOVT
                      END DO
                   END DO
                END DO
C
C=======================================================================
C                 CALCULATING TRANSITION MATRIX  ELEMENTS  OF  MULTIPOLE
C                 SURFACE OR SCHIFF OPERATORS.
C=======================================================================
C                 ATTENTION! SEE "COMMENT 1" ABOVE.
C=======================================================================
C
                CALL MOMSIF(ISIMPY,ISIGNY,ISIQTY,SDUM_P,SMUT_P,
     *                                           COMULT,JSIFMO)
C
C=======================================================================
C                 ATTENTION! THE PRESENT DEFINITION OF THE SCHIFF MOMETS
C                            IN MOMSCH IS INCOMPATIBLE  WITH  PROJECTION
C                            AND CANNOT BE USED. HOWEVER,  FOR ISCHIF=2,
C                            THE  CODE  EVALUATES  AND  PRINTS   CORRECT
C                            REDUCED MATRIX ELEMENTS OF  SCHIFF  MOMENTS
C                            BASED ON THE SURFACE MOMENTS  OF  PROJECTED
C                            STATES.
C=======================================================================
C                 ATTENTION! SEE "COMMENT 1" ABOVE.
C=======================================================================
C
                IF (ISCHIF.EQ.1)
     *          CALL MOMSCH(SDUM_P,SMUT_P,JSIFMO,QDUM_P,QMUT_P,JMULMO)
C
C=======================================================================
C                 ATTENTION! ARRAY  "SPKERN" ORGANISED AS "QPKERN" ABOVE
C=======================================================================
C
                DO LAMBDA=NSIMIN,NSIRED
                   DO MIU=-LAMBDA,LAMBDA
C
                      IF (MIU.GT.0)
     *                    SPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *                    SPKERN(M,J,N,IND_LM(LAMBDA,MIU))+
     *                                            (SMUT_P(LAMBDA, MIU)
     *                           -UNIT_I*(-1)**MIU*SMUT_P(LAMBDA,-MIU))
     *                                            *FACOVT
C
                      IF (MIU.EQ.0)
     *                    SPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *                    SPKERN(M,J,N,IND_LM(LAMBDA,MIU))+
     *                                             SMUT_P(LAMBDA, MIU)
     *                                            *FACOVT
C
                      IF (MIU.LT.0)
     *                    SPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *                    SPKERN(M,J,N,IND_LM(LAMBDA,MIU))+
     *                                  ((-1)**MIU*SMUT_P(LAMBDA,-MIU)
     *                                     +UNIT_I*SMUT_P(LAMBDA, MIU))
     *                                            *FACOVT
C
                   END DO
                END DO
C
  81            CONTINUE
C
            END IF
C
C=======================================================================
C                 HERE END CALCULATIONS FOR NEUTRONS AND PROTONS
C                     END OF "EXTERNAL" CHARGE LOOP (NO. 3)
C=======================================================================
C
         END DO
C
C=======================================================================
C        CALCULATING  T H E   I S O S P I N  TRANSITION  KERNELS
C=======================================================================
C
         IF (KETAT2.EQ.1) THEN
C
             CALL KEISP2(MREVER,ISIMPY,
     *                   BNN_PP,BNN_PM,BNP_PP,BNP_PM,
     *                   BPP_PP,BPP_PM,BPN_PP,BPN_PM)
C
             TZKERN(M,J,N,M_T,L,N_T)=
     *       TZKERN(M,J,N,M_T,L,N_T)+TKEISO(3)
     *                              *FACOVT
             T2KERN(M,J,N,M_T,L,N_T)=
     *       T2KERN(M,J,N,M_T,L,N_T)+TKEIS2(0)
     *                              *FACOVT
C
         END IF
C
C=======================================================================
C        CALCULATING  THE  ANGULAR MOMENTUM  TRANSITION  KERNELS
C        SUMMING UP NEUTRON AND PROTON CONTRIBUTIONS TO ANGULAR MOMENTA
C=======================================================================
C
         IF (KETAJ2.EQ.1) THEN
C
             CALL TOTANG
C
             BZKERN(M,J,N,M_T,L,N_T)=
     *       BZKERN(M,J,N,M_T,L,N_T)+AKOTLT(3)
     *                              *FACOVT
             B2KERN(M,J,N,M_T,L,N_T)=
     *       B2KERN(M,J,N,M_T,L,N_T)+TKOTST(0)
     *                              *FACOVT
C
         END IF
C
C=======================================================================
C        CALCULATING  T H E   C O U L O M B  TRANSITION  KERNELS
C                     FOR THE I S O S P I N PROJECTION
C=======================================================================
C
         Q00T=C_ZERO
         Q10T=C_ZERO
         Q1PT=C_ZERO
         Q1MT=C_ZERO
C
C=======================================================================
C            NEUTRON AND PROTON <--> NEUTRON AND PROTON
C=======================================================================
C
         BIG_PP(:,:,:)=BNN_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BNN_PM(:,:,:)
         END IF
C
         CALL SAVDEN(ISIMPY,0)
C
         BIG_PP(:,:,:)=BPP_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BPP_PM(:,:,:)
         END IF
C
         CALL SAVDEN(ISIMPY,1)
C
C=======================================================================
C          CALCULATING  T H E   G O G N Y   E N E R G Y
C=======================================================================
C
         IF (I_GOGA.GE.1.AND.NEWGOG.EQ.0) THEN
C
             CALL GOGENE(I_SLOW,SLOWEV,ISGOGA,I_GOGA,ISIMPY,EKEGOG)
C
             IF (NBTKNO.EQ.1) THEN
C
C                CHECK WHY L=1 IS USED HERE AND IF FACOVT SHOULD BE USED
C
                 SKKERN(M,J,N,1,1,1)=SKKERN(M,J,N,1,1,1)+EKEGOG
     *                                                  *FACOVT
             ELSE
                 SKKERN(M,J,N,M_T,L,N_T)=SKKERN(M,J,N,M_T,L,N_T)+EKEGOG
     *                                                          *FACOVT
C
             END IF
C
         END IF
C
C=======================================================================
C          CALCULATING  T H E   REGULARIZED-SKYRME OR GOGNY  E N E R G Y
C=======================================================================
C          ATTENTION: A SIMULTANEOUS USE OF REGULARIZED  A  N  D   GOGNY
C                     IS NOT PERMITTED IN "PROANG" YET
C=======================================================================
C
         IF (I_REGA.GE.1.AND.NEWGOG.EQ.0.OR.
     *       I_GOGA.GE.1.AND.NEWGOG.EQ.1) THEN
C
             CALL REGENE(I_SLOW,SLOWEV,SLOWPA,
     *                   I_REGA,IREGPA,ISREGA,ISREGP,
     *                   I_GOGA,IGOGPA,ISGOGA,ISGOGP,
     *                   N3LORD,ISIMPY,IN_FIX,IZ_FIX,EKEREG,NEWGOG)
C
             IF (NBTKNO.EQ.1) THEN
C
                 SKKERN(M,J,N,1,1,1)=SKKERN(M,J,N,1,1,1)+EKEREG
     *                                                  *FACOVT
             ELSE
                 SKKERN(M,J,N,M_T,L,N_T)=SKKERN(M,J,N,M_T,L,N_T)+EKEREG
     *                                                          *FACOVT
C
             END IF
C
         END IF
C
C=======================================================================
C          CALCULATING  T H E   SEPARABLE-FORCE   E N E R G Y
C=======================================================================
C
         IF (I_SEPA.GE.1.OR.ISEPPA.GE.1) THEN
C
             IF (IPNMIX.NE.1) THEN
C
              CALL SEPENE(ISSEPA,I_SEPA,SLOWPA,ISSEPP,ISEPPA,
     *                    N3SERD,ISIMPY,IN_FIX,IZ_FIX,EKESEP,
     *                                  I_SLOW,SLOWEV,LDPNMX)
C
             ELSE
C
              CALL SEPMIE(ISSEPA,I_SEPA,SLOWPA,ISSEPP,ISEPPA,
     *                    N3SERD,ISIMPY,IN_FIX,IZ_FIX,EKESEP,
     *                                  I_SLOW,SLOWEV,LDPNMX)
C
             END IF
C
             IF (NBTKNO.EQ.1) THEN
C
                 SKKERN(M,J,N,1,1,1)=SKKERN(M,J,N,1,1,1)+EKESEP
     *                                                  *FACOVT
             ELSE
                 SKKERN(M,J,N,M_T,L,N_T)=SKKERN(M,J,N,M_T,L,N_T)+EKESEP
     *                                                          *FACOVT
C
             END IF
C
         END IF
C
         IF (NBTKNO.GT.1) THEN
C
C=======================================================================
C            NEUTRON AND PROTON <--> NEUTRON-PROTON AND PROTON-NEUTRON
C=======================================================================
C
             BIG_PP(:,:,:)=BNP_PP(:,:,:)
             IF (ISIMPY.NE.1) THEN
                 BIG_PM(:,:,:)=BNP_PM(:,:,:)
             END IF
C
             CALL SAVDEN(ISIMPY,0)
C
             BIG_PP(:,:,:)=BPN_PP(:,:,:)
             IF (ISIMPY.NE.1) THEN
                 BIG_PM(:,:,:)=BPN_PM(:,:,:)
             END IF
C
             CALL SAVDEN(ISIMPY,1)
C
C=======================================================================
C          CALCULATING  T H E   G O G N Y   E N E R G Y
C=======================================================================
C
             IF (I_GOGA.GE.1) THEN
C
C                CALL GOGENP(I_SLOW,SLOWEV,ISGOGA,I_GOGA,ISIMPY,EKEGOG)
C
                 IF (NBTKNO.EQ.1) THEN
C
                     SKKERN(M,J,N,1,1,1)=SKKERN(M,J,N,1,1,1)+EKEGOG
     *                                                      *FACOVT
                 ELSE
                     SKKERN(M,J,N,M_T,L,N_T)=SKKERN(M,J,N,M_T,L,N_T)
     *                                                      +EKEGOG
     *                                                      *FACOVT
C
                 END IF
C
                 STOP ' NP MIXING FOR GOGENP NOT YET IMPLEMENTED'
C
             END IF
C
C=======================================================================
C          CALCULATING  T H E   REGULARIZED-SKYRME   E N E R G Y
C=======================================================================
C
             IF (I_REGA.GE.1) THEN
C
                 IF (N3LORD.GE.0) THEN
C
                  CALL REGENP(I_SLOW,SLOWEV,ISREGA,I_REGA,N3LORD,
     *                                             ISIMPY,EKEREG)
                 ELSE
C                 CALL SKGENP(I_SLOW,SLOWEV,ISREGA,I_REGA,N3LORD,
C    *                                             ISIMPY,EKEREG)
C
                     STOP ' NP MIXING FOR SKGENP NOT YET IMPLEMENTED'
C
                 END IF
C
                 IF (NBTKNO.EQ.1) THEN
C
                     SKKERN(M,J,N,1,1,1)=SKKERN(M,J,N,1,1,1)+EKEREG
     *                                                      *FACOVT
                 ELSE
                     SKKERN(M,J,N,M_T,L,N_T)=SKKERN(M,J,N,M_T,L,N_T)
     *                                                      +EKEREG
     *                                                      *FACOVT
C
                 END IF
C
             END IF
C
C=======================================================================
C          CALCULATING  T H E   SEPARABLE-FORCE   E N E R G Y
C=======================================================================
C
             IF (I_SEPA.GE.1.OR.ISEPPA.GE.1) THEN
C
                 IF (N3SERD.GE.0) THEN
C
                     STOP ' WRONG N3SERD IN PROANG'
C
                 ELSE
C                 CALL SEPENP(I_SLOW,SLOWEV,ISSEPA,I_SEPA,N3SERD,
C    *                                             ISIMPY,EKESEP)
C
                     STOP ' NP MIXING FOR SEPENP NOT YET IMPLEMENTED'
C
                 END IF
C
                 IF (NBTKNO.EQ.1) THEN
C
                     SKKERN(M,J,N,1,1,1)=SKKERN(M,J,N,1,1,1)+EKESEP
     *                                                      *FACOVT
                 ELSE
                     SKKERN(M,J,N,M_T,L,N_T)=SKKERN(M,J,N,M_T,L,N_T)
     *                                                      +EKESEP
     *                                                      *FACOVT
C
                 END IF
C
             END IF
C
         END IF
C
C=======================================================================
C          CALCULATING  T H E   COULOMB   E N E R G Y
C=======================================================================
C=======================================================================
C            MONOPOLE '00' SOURCE <--> MONOPOLE '00' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=BNN_PP(:,:,:)+BPP_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BNN_PM(:,:,:)+BPP_PM(:,:,:)
         END IF
C
         DO IBRA=1,LDBASE
            Q00T=Q00T+(BIG_PP(IBRA,IBRA,0)
     *                +BIG_PP(IBRA,IBRA,1))
         END DO
C
         PNKE00(M,J,N,M_T,L,N_T)=
     *   PNKE00(M,J,N,M_T,L,N_T)+Q00T
     *                          *FACOVT
C
CWS         WRITE(*,7878) M,J,N,M_T,L,N_T,PNKE00(M,J,N,M_T,L,N_T)
CWS 7878    FORMAT(2X,'-->',6I4,2F16.10)
C
         IF (NBTKNO.EQ.1.OR.JCSKIP.NE.0) GOTO 821
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD0000=EKECOD
         CX0000=EKECOE
C
 821     CONTINUE
C
C=======================================================================
C             DIPOLE '10' SOURCE   <-->   DIPOLE '10' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=BNN_PP(:,:,:)-BPP_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BNN_PM(:,:,:)-BPP_PM(:,:,:)
         END IF
C
         DO IBRA=1,LDBASE
            Q10T=Q10T+(BIG_PP(IBRA,IBRA,0)
     *                +BIG_PP(IBRA,IBRA,1))
         END DO
C
         PNKE10(M,J,N,M_T,L,N_T)=
     *   PNKE10(M,J,N,M_T,L,N_T)+Q10T
     *                          *FACOVT
C
CWS         WRITE(*,7878) M,J,N,M_T,L,N_T,PNKE10(M,J,N,M_T,L,N_T)
C
         IF (NBTKNO.EQ.1.OR.JCSKIP.NE.0) GOTO 822
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD1010=EKECOD
         CX1010=EKECOE
C
 822     CONTINUE
C
C=======================================================================
C           DIPOLE '1+1' SOURCE <--> DIPOLE '1+1' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=-SQRT(2.D0)*BPN_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=-SQRT(2.D0)*BPN_PM(:,:,:)
         END IF
C
         DO IBRA=1,LDBASE
            Q1PT=Q1PT+(BIG_PP(IBRA,IBRA,0)
     *                +BIG_PP(IBRA,IBRA,1))
         END DO
C
         PNKE1M(M,J,N,M_T,L,N_T)=
     *   PNKE1M(M,J,N,M_T,L,N_T)-Q1PT
     *                          *FACOVT
C
         IF (NBTKNO.EQ.1.OR.JCSKIP.NE.0) GOTO 823
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD1P1P=EKECOD
         CX1P1P=EKECOE
C
 823     CONTINUE
C
C=======================================================================
C          DIPOLE '1-1' SOURCE   <-->   DIPOLE '1-1' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=SQRT(2.D0)*BNP_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=SQRT(2.D0)*BNP_PM(:,:,:)
         END IF
C
         DO IBRA=1,LDBASE
            Q1MT=Q1MT+(BIG_PP(IBRA,IBRA,0)
     *                +BIG_PP(IBRA,IBRA,1))
         END DO
C
         PNKE1P(M,J,N,M_T,L,N_T)=
     *   PNKE1P(M,J,N,M_T,L,N_T)-Q1MT
     *                          *FACOVT
C
         IF (NBTKNO.EQ.1.OR.JCSKIP.NE.0) GOTO 82
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD1M1M=EKECOD
         CX1M1M=EKECOE
C
C=======================================================================
C      MIXED '[00 + 10]/2' SOURCE  <--> MIXED '[00 + 10]/2' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=BNN_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BNN_PM(:,:,:)
         END IF
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD0010=(4.0D0*EKECOD-CD0000-CD1010)/2.0D0
         CX0010=(4.0D0*EKECOE-CX0000-CX1010)/2.0D0
C
C=======================================================================
C        MIXED '00 + 1+1' SOURCE  <--> MIXED '00 + 1+1' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=BNN_PP(:,:,:)+BPP_PP(:,:,:)
     *                   -SQRT(2.D0)*BPN_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BNN_PM(:,:,:)+BPP_PM(:,:,:)
     *                       -SQRT(2.D0)*BPN_PM(:,:,:)
         END IF
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD001P=(EKECOD-CD0000-CD1P1P)/2.0D0
         CX001P=(EKECOE-CX0000-CX1P1P)/2.0D0
C
C=======================================================================
C        MIXED '00 + 1-1' SOURCE  <--> MIXED '00 + 1-1' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=BNN_PP(:,:,:)+BPP_PP(:,:,:)
     *                   +SQRT(2.D0)*BNP_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BNN_PM(:,:,:)+BPP_PM(:,:,:)
     *                       +SQRT(2.D0)*BNP_PM(:,:,:)
         END IF
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD001M=(EKECOD-CD0000-CD1M1M)/2.0D0
         CX001M=(EKECOE-CX0000-CX1M1M)/2.0D0
C
C=======================================================================
C        MIXED '10 + 1+1' SOURCE  <--> MIXED '10 + 1+1' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=BNN_PP(:,:,:)-BPP_PP(:,:,:)
     *                   -SQRT(2.D0)*BPN_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BNN_PM(:,:,:)-BPP_PM(:,:,:)
     *                       -SQRT(2.D0)*BPN_PM(:,:,:)
         END IF
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD101P=(EKECOD-CD1010-CD1P1P)/2.0D0
         CX101P=(EKECOE-CX1010-CX1P1P)/2.0D0
C
C=======================================================================
C        MIXED '10 + 1-1' SOURCE  <--> MIXED '10 + 1-1' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=BNN_PP(:,:,:)-BPP_PP(:,:,:)
     *                   +SQRT(2.D0)*BNP_PP(:,:,:)
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=BNN_PM(:,:,:)-BPP_PM(:,:,:)
     *                       +SQRT(2.D0)*BNP_PM(:,:,:)
         END IF
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD101M=(EKECOD-CD1010-CD1M1M)/2.0D0
         CX101M=(EKECOE-CX1010-CX1M1M)/2.0D0
C
C=======================================================================
C      MIXED '1+1 + 1-1' SOURCE  <--> MIXED '1+1 + 1-1' TRACE
C=======================================================================
C
         BIG_PP(:,:,:)=-SQRT(2.D0)*(BNP_PP(:,:,:)-BPN_PP(:,:,:))
         IF (ISIMPY.NE.1) THEN
             BIG_PM(:,:,:)=-SQRT(2.D0)*(BNP_PM(:,:,:)-BPN_PM(:,:,:))
         END IF
C
         CALL SAVDEN(ISIMPY,1)
C
         CALL COUENE(ISIMPY,
     *               ICOTYP,ICOUDI,ICOUEX,
     *                             IDOTHC,
     *               EKECOD,EKESCA,EKEVEC)
C
         EKECOE=EKESCA+EKEVEC
         CD1P1M=(EKECOD-CD1P1P-CD1M1M)/2.0D0
         CX1P1M=(EKECOE-CX1P1P-CX1M1M)/2.0D0
C
C=======================================================================
C
C    ONE AND TWO BODY (COVARIANT) TENSORS USED HERE ARE DEFINED AS
C    FOLLOWS (STANDARD TEXTBOOK DEFINITION):
C
C                 T_10  =  \tau_z;
C                 T_1+1 =-[\tau_x + i\tau_y]/sqrt2
C                 T_1-1 =+[\tau_x - i\tau_y]/sqrt2
C
C=======================================================================
C    MISSING FACTORS 1/2 AND -1/4 IN FRONT OF DIRECT AND EXCHANGE TERMS
C    ARE EXPLICITLY INCLUDED IN COUENE
C=======================================================================
C
                  CDKERN(M,J,N,M_T,L,N_T)=
     *            CDKERN(M,J,N,M_T,L,N_T)+
     *                 (CD0000+CD1010/3.D0-2.D0*CD1P1M/3.D0)/4.D0
     *                 *FACOVT
                  CDKE10(M,J,N,M_T,L,N_T)=
     *            CDKE10(M,J,N,M_T,L,N_T)-
     *                  CD0010/2.D0
     *                 *FACOVT
                  CDKE1P(M,J,N,M_T,L,N_T)=
     *            CDKE1P(M,J,N,M_T,L,N_T)+
     *                  CD001M/2.D0
     *                 *FACOVT
                  CDKE1M(M,J,N,M_T,L,N_T)=
     *            CDKE1M(M,J,N,M_T,L,N_T)+
     *                  CD001P/2.D0
     *                 *FACOVT
                  CDKE20(M,J,N,M_T,L,N_T)=
     *            CDKE20(M,J,N,M_T,L,N_T)+
     *                 (CD1010+CD1P1M)/6.D0
     *                 *FACOVT
                  CDK21P(M,J,N,M_T,L,N_T)=
     *            CDK21P(M,J,N,M_T,L,N_T)-
     *                  CD101M/SQRT(3.D0)/2.D0
     *                 *FACOVT
                  CDK21M(M,J,N,M_T,L,N_T)=
     *            CDK21M(M,J,N,M_T,L,N_T)-
     *                  CD101P/SQRT(3.D0)/2.D0
     *                 *FACOVT
                  CDK22P(M,J,N,M_T,L,N_T)=
     *            CDK22P(M,J,N,M_T,L,N_T)+
     *                  CD1M1M/SQRT(6.D0)/2.D0
     *                 *FACOVT
                  CDK22M(M,J,N,M_T,L,N_T)=
     *            CDK22M(M,J,N,M_T,L,N_T)+
     *                  CD1P1P/SQRT(6.D0)/2.D0
     *                 *FACOVT
C
                  CXKERN(M,J,N,M_T,L,N_T)=
     *            CXKERN(M,J,N,M_T,L,N_T)+
     *                 (CX0000+CX1010/3.D0-2.D0*CX1P1M/3.D0)/4.D0
     *                 *FACOVT
                  CXKE10(M,J,N,M_T,L,N_T)=
     *            CXKE10(M,J,N,M_T,L,N_T)-
     *                  CX0010/2.D0
     *                 *FACOVT
                  CXKE1P(M,J,N,M_T,L,N_T)=
     *            CXKE1P(M,J,N,M_T,L,N_T)+
     *                  CX001M/2.D0
     *                 *FACOVT
                  CXKE1M(M,J,N,M_T,L,N_T)=
     *            CXKE1M(M,J,N,M_T,L,N_T)+
     *                  CX001P/2.D0
     *                 *FACOVT
                  CXKE20(M,J,N,M_T,L,N_T)=
     *            CXKE20(M,J,N,M_T,L,N_T)+
     *                 (CX1010+CX1P1M)/6.D0
     *                 *FACOVT
                  CXK21P(M,J,N,M_T,L,N_T)=
     *            CXK21P(M,J,N,M_T,L,N_T)-
     *                  CX101M/SQRT(3.D0)/2.D0
     *                 *FACOVT
                  CXK21M(M,J,N,M_T,L,N_T)=
     *            CXK21M(M,J,N,M_T,L,N_T)-
     *                  CX101P/SQRT(3.D0)/2.D0
     *                 *FACOVT
                  CXK22P(M,J,N,M_T,L,N_T)=
     *            CXK22P(M,J,N,M_T,L,N_T)+
     *                  CX1M1M/SQRT(6.D0)/2.D0
     *                 *FACOVT
                  CXK22M(M,J,N,M_T,L,N_T)=
     *            CXK22M(M,J,N,M_T,L,N_T)+
     *                  CX1P1P/SQRT(6.D0)/2.D0
     *                 *FACOVT
C
  82     CONTINUE
C
C=======================================================================
C      CALCULATING  T H E   S K Y R M E   TRANSITION  E N E R G Y
C=======================================================================
C            ATTENTION: IN VERSIONS FROM 2.55Y TO 2.56H, FOR NBTKNO.NE.1
C                       THE CALL TO "TRUTOD" BELOW  WAS  NOT  PERFORMED.
C                       AS  A  RESULT,  FOR   DENSITY-DEPENDENT   FORCES
C                       SIMULTANEOUS PROJECTION ON SPIN AND ISOSPIN  WAS
C                       NOT GIVING CORRECT RESULTS. THIS  BUG  HAS  BEEN
C                       CORRECTED ON 03/01/2013 IN VERSION (2.56I).
C=======================================================================
C            ATTENTION: LDTWCE NOT TRANSFERED INTO PROANG
C=======================================================================
         IF (IDENSU.EQ.1.AND.(NPNKNO.GT.1.OR.NTZKNO.GT.1)) THEN
C
             IF (IGAUGE.EQ.1.AND.IGAUTZ.EQ.1) THEN
                 JDENSU=0
                 CALL TRUTOD(1,1)
                 DENSIU(:,:,:)=DENSIC(:,:,:,1)
             ELSE
                 JDENSU=1
                 CALL TRUTOD(1,1)
             END IF
C
         ELSE
C
             JDENSU=0
             CALL TRUTOD(1,1)
C
         END IF
C
         CALL ESKYRM(ENDUMM,ENDUMM,ENDUMM,ENDUMM,ENDUMM,ENDUMM,ENDUMM,
     *                                                  EKESKY,LDPNMX,
     *                                                         IVIPRI,1)
C
         IF (NBTKNO.EQ.1) THEN
C
             SKKERN(M,J,N,1,1,1)=SKKERN(M,J,N,1,1,1)+EKESKY
     *                                              *FACOVT
C
         ELSE
C
             CALL ESKYNP(ENDUMM,ENDUMM,ENDUMM,ENDUMM,ENDUMM,ENDUMM,
     *                                        ENDUMM,EKESKY,LDPNMX)
C
             SKKERN(M,J,N,M_T,L,N_T)=SKKERN(M,J,N,M_T,L,N_T)+EKESKY
     *                                                      *FACOVT
C
C TER        DO NUCOUT=1,NDCOUT
C TER           TEKERN(M,J,N,M_T,L,N_T,NUCOUT       )=ECCALL(NUCOUT)
C TER           TEKERN(M,J,N,M_T,L,N_T,NUCOUT+NDCOUT)=ECC_NP(NUCOUT)
C TER        END DO
         END IF
C
C=======================================================================
C        CALCULATING THE NEUTRON AND PROTON PAIRING  ENERGIES.
C=======================================================================
C        TO PROPERLY TAKE INTO ACCOUNT THE  DENSITY-DEPENDENT
C        TERM OF THE PAIRING FORCE, CALLS FOR  BOTH  NEUTRONS
C        AND PROTONS MUST BE PERFORMED OUTSIDE  THE  "ICHARG"
C        LOOP.
C=======================================================================
C
         DO ICHARG=0,NDISOS
C
            IF (KPAHFB(ICHARG).EQ.1) THEN
C
                CALL EPAIRI(IN_FIX,IZ_FIX,ICHARG,EKEPAI,1)
C
                EPKERN(M,J,N,M_T,ICHARG,N_T)=
     *          EPKERN(M,J,N,M_T,ICHARG,N_T)+EKEPAI
     *                                      *FACOVT
            END IF
C
         END DO
C
C=======================================================================
C         HERE END THE LOOPS OVER GAUGE ANGLE AND REFLECTION
C=======================================================================
C
         END DO ! END OF LOOP FOR TZ.NUM. PROJECTION (NO INDENTATION)
         END DO ! END OF LOOP FOR PA.NUM. PROJECTION (NO INDENTATION)
         END DO ! END OF LOOP FOR PARITY  PROJECTION (NO INDENTATION)
C
C=======================================================================
C         HERE WE CALCULATE THE  PARTICLE-NUMBER-  AND  PARITY-PROJECTED
C         KERNELS BY DIVIDING THE PROJECTED MATRIX ELEMENTS BY PROJECTED
C         OVERLAPS
C=======================================================================
C
         IF (NBTKNO.EQ.1) THEN
C
             DO LAMBDA=0,NMURED
                DO MIU=-LAMBDA,LAMBDA
C
                   QPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *             QPKERN(M,J,N,IND_LM(LAMBDA,MIU))/
     *             OVKERN(M,J,N,M_T,1,N_T)
C
                   ATKERN(M,J,N,IND_LM(LAMBDA,MIU),:)=
     *             ATKERN(M,J,N,IND_LM(LAMBDA,MIU),:)/
     *             OVKERN(M,J,N,M_T,1,N_T)
C
                   SPKERN(M,J,N,IND_LM(LAMBDA,MIU))=
     *             SPKERN(M,J,N,IND_LM(LAMBDA,MIU))/
     *             OVKERN(M,J,N,M_T,1,N_T)
C
                   IF (NASORD.GE.0)
     *             WTKERN(M,J,N,IND_LM(LAMBDA,MIU),:)=
     *             WTKERN(M,J,N,IND_LM(LAMBDA,MIU),:)/
     *             OVKERN(M,J,N,M_T,1,N_T)
C
                END DO
             END DO
C
         END IF
C
         SKKERN(M,J,N,M_T,L,N_T)=SKKERN(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
C
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS 2.98C  AND  3.01F,  ARRAY  "EPKERN"
C                   BELOW WAS DIVIDED UNDER AN INCORRECT CONDITION. AS A
C                   RESULT, IN CASE OF HYBRID PAIRING VANISHING FOR  ONE
C                   TYPE OF PARTICLES ONLY, PROJECTION COULD  NOT  WORK.
C                   THIS BUG WAS CORRECTED ON 4/12/2020 IN VERSION 3.01G
C=======================================================================
C
         IF (NBTKNO.EQ.1) THEN
C
             EKKERN(M,J,N,M_T,0,N_T)=EKKERN(M,J,N,M_T,0,N_T)/
     *                               OVKERN(M,J,N,M_T,1,N_T)
             EKKERN(M,J,N,M_T,1,N_T)=EKKERN(M,J,N,M_T,1,N_T)/
     *                               OVKERN(M,J,N,M_T,1,N_T)
             EPKERN(M,J,N,M_T,0,N_T)=EPKERN(M,J,N,M_T,0,N_T)/
     *                               OVKERN(M,J,N,M_T,1,N_T)
             EPKERN(M,J,N,M_T,1,N_T)=EPKERN(M,J,N,M_T,1,N_T)/
     *                               OVKERN(M,J,N,M_T,1,N_T)
         ELSE
C
             EKKERN(M,J,N,M_T,L,N_T)=EKKERN(M,J,N,M_T,L,N_T)/
     *                               OVKERN(M,J,N,M_T,L,N_T)
             EPKERN(M,J,N,M_T,L,N_T)=EPKERN(M,J,N,M_T,L,N_T)/
     *                               OVKERN(M,J,N,M_T,L,N_T)
         END IF
C
         CDKERN(M,J,N,M_T,L,N_T)=CDKERN(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CDKE10(M,J,N,M_T,L,N_T)=CDKE10(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CDKE1P(M,J,N,M_T,L,N_T)=CDKE1P(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CDKE1M(M,J,N,M_T,L,N_T)=CDKE1M(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CDKE20(M,J,N,M_T,L,N_T)=CDKE20(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CDK21P(M,J,N,M_T,L,N_T)=CDK21P(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CDK21M(M,J,N,M_T,L,N_T)=CDK21M(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CDK22P(M,J,N,M_T,L,N_T)=CDK22P(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CDK22M(M,J,N,M_T,L,N_T)=CDK22M(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXKERN(M,J,N,M_T,L,N_T)=CXKERN(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXKE10(M,J,N,M_T,L,N_T)=CXKE10(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXKE1P(M,J,N,M_T,L,N_T)=CXKE1P(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXKE1M(M,J,N,M_T,L,N_T)=CXKE1M(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXKE20(M,J,N,M_T,L,N_T)=CXKE20(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXK21P(M,J,N,M_T,L,N_T)=CXK21P(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXK21M(M,J,N,M_T,L,N_T)=CXK21M(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXK22P(M,J,N,M_T,L,N_T)=CXK22P(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         CXK22M(M,J,N,M_T,L,N_T)=CXK22M(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         PNKE00(M,J,N,M_T,L,N_T)=PNKE00(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         PNKE10(M,J,N,M_T,L,N_T)=PNKE10(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         PNKE1P(M,J,N,M_T,L,N_T)=PNKE1P(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         PNKE1M(M,J,N,M_T,L,N_T)=PNKE1M(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         TZKERN(M,J,N,M_T,L,N_T)=TZKERN(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         T2KERN(M,J,N,M_T,L,N_T)=T2KERN(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         BZKERN(M,J,N,M_T,L,N_T)=BZKERN(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
         B2KERN(M,J,N,M_T,L,N_T)=B2KERN(M,J,N,M_T,L,N_T)/
     *                           OVKERN(M,J,N,M_T,L,N_T)
C
C=======================================================================
C         HERE WE HANDLE THE SAVING OF IPAALL=1 KERNELS ON DISK
C=======================================================================
C         IDENTATION MOVES FORWARD FROM THE 10TH TO 13TH COLUMN
C=======================================================================
C
            IF (ISAKER.EQ.1.AND.IPAALL.EQ.1) THEN
C
C=======================================================================
C         SEARCHING FOR THE NEXT AVAILABLE KERNEL FILE
C=======================================================================
C
                IF (IOPEND.NE.1) THEN
C
                    IF (KFIKER.LE.0) THEN
C
                       IFIBEG=001
                       IFIEND=999
                    ELSE
                       IFIBEG=KFIKER
                       IFIEND=KFIKER
C
                    END IF
C
                    DO IFIKER=IFIBEG,IFIEND
C
                       WRITE(FILACT(01:05),'(''N'',I3,''-'')') IFIKER
C
                       DO NUCHAR=02,04
C
                          IF (FILACT(NUCHAR:NUCHAR).EQ.' ')
     *                        FILACT(NUCHAR:NUCHAR)='0'
C
                       END DO
C
                       OPEN(NFIKER,FILE=FILACT,STATUS='NEW',ERR=8919,
     *                             FORM='UNFORMATTED')
C
                       CLOSE(NFIKER)
C
C=======================================================================
C         THE NEXT AVAILABLE KERNEL FILE FILE FOUND
C=======================================================================
C
                       IOPEND=1
C
                       GO TO 8918
C
 8919                  CONTINUE
C
                    END DO
C
C                   STOP' ALL KERNEL FILES N001-N999 ARE ALREADY IN USE'
C
                    FILACT(02:04)='000'
C
                    OPEN(NFIKER,FILE=FILACT,STATUS='NEW',
     *                          FORM='UNFORMATTED')
C
                    CLOSE(NFIKER)
C
 8918               CONTINUE
C
                END IF
C
C=======================================================================
C         OPENING THE FILE
C=======================================================================
C
                OPEN(NFIKER,FILE=FILACT,STATUS='OLD',
     *                      POSITION='APPEND',FORM='UNFORMATTED')
C
C=======================================================================
C         WRITING THE FILE
C=======================================================================
C
                WRITE(NFIKER) I,K,IVERKE
C
                WRITE(NFIKER) IPAALL,J,L
C
                WRITE(NFIKER) FILACT
C
                WRITE(NFIKER) NUBKNO,NBTKNO,NMURED,NMARED,NSIRED
C
                   WRITE(NFIKER) J,
     *                OVKERN(M,J,N,1,0,1),OVKERN(M,J,N,1,L,1),
     *                EKKERN(M,J,N,1,0,1),EKKERN(M,J,N,1,L,1),
     *                CDKERN(M,J,N,1,L,1),
     *                CXKERN(M,J,N,1,L,1),
     *                SKKERN(M,J,N,1,L,1),
     *               ((QPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=0,NMURED),
     *               ((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=1,NMARED),
     *               ((SPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                          LAMBDA=NSIMIN,NSIRED)
                   WRITE(NFIKER)
     *                CDKE10(M,J,N,1,L,1),
     *                CDKE1P(M,J,N,1,L,1),
     *                CXKE10(M,J,N,1,L,1),
     *                CXKE1P(M,J,N,1,L,1),
     *                CDKE1M(M,J,N,1,L,1),
     *                CDKE20(M,J,N,1,L,1),
     *                CDK21P(M,J,N,1,L,1),
     *                CDK21M(M,J,N,1,L,1),
     *                CDK22P(M,J,N,1,L,1),
     *                CDK22M(M,J,N,1,L,1),
     *                CXKE1M(M,J,N,1,L,1),
     *                CXKE20(M,J,N,1,L,1),
     *                CXK21P(M,J,N,1,L,1),
     *                CXK21M(M,J,N,1,L,1),
     *                CXK22P(M,J,N,1,L,1),
     *                CXK22M(M,J,N,1,L,1),
     *                PNKE00(M,J,N,1,L,1),
     *                PNKE10(M,J,N,1,L,1),
     *                PNKE1P(M,J,N,1,L,1),
     *                PNKE1M(M,J,N,1,L,1)
C
                   WRITE(NFIKER)
     *                TZKERN(M,J,N,1,L,1),
     *                T2KERN(M,J,N,1,L,1)
C
                   WRITE(NFIKER)
     *                EPKERN(M,J,N,0,L,1),
     *                EPKERN(M,J,N,1,L,1)
C
                   WRITE(NFIKER)
     *                BZKERN(M,J,N,1,L,1),
     *                B2KERN(M,J,N,1,L,1)
C
                CLOSE(NFIKER)
C
            END IF
C
C=======================================================================
C         HERE WE HANDLE THE SAVING OF ISAKER=2 KERNELS ON DISK
C=======================================================================
C
            IF (ISAKER.EQ.2) THEN
C
C=======================================================================
C         SEARCHING FOR THE NEXT AVAILABLE KERNEL FILE
C=======================================================================
C
                IF (IOPEND.NE.1) THEN
C
                    IFIBEG=0
                    IFIEND=9
C
                    DO IFIKER=IFIBEG,IFIEND
C
                       IF (NAMKER.EQ.1) THEN
C
                           WRITE(FILACT(07:07),'(I1)') IFIKER
                           OPEN(NFIKER,FILE=FILACT,STATUS='NEW',
     *                             ERR=3229,FORM='UNFORMATTED')
                       ELSE
                           WRITE(FILAC2(07:07),'(I1)') IFIKER
                           OPEN(NFIKER,FILE=FILAC2,STATUS='NEW',
     *                             ERR=3229,FORM='UNFORMATTED')
                       END IF
C
                       CLOSE(NFIKER)
C
C=======================================================================
C         THE NEXT AVAILABLE KERNEL FILE FILE FOUND
C=======================================================================
C
                       IOPEND=1
C
                       GO TO 3228
C
 3229                  CONTINUE
C
                    END DO
C
                    STOP' ALL KERNEL FILES 0-9 ARE ALREADY IN USE'
C
 3228               CONTINUE
C
                END IF
C
C=======================================================================
C         OPENING THE FILE
C=======================================================================
C
                IF (NAMKER.EQ.1) THEN
C
                    WRITE(FILACT(07:07),'(I1)') IFIKER
                    OPEN(NFIKER,FILE=FILACT,STATUS='OLD',
     *               POSITION='APPEND',FORM='UNFORMATTED')
                ELSE
                    WRITE(FILAC2(07:07),'(I1)') IFIKER
                    OPEN(NFIKER,FILE=FILAC2,STATUS='OLD',
     *               POSITION='APPEND',FORM='UNFORMATTED')
C
                END IF
C
C=======================================================================
C         WRITING THE FILE
C=======================================================================
C
                WRITE(NFIKER) I,K,IVERK2
C
                WRITE(NFIKER) NUAKNO,NUBKNO,NATKNO,NBTKNO
C
                WRITE(NFIKER) IPAALL,J,L
C
                WRITE(NFIKER) IPAK3D,I_T,K_T
C
                WRITE(NFIKER) NPNKNO,IN_FIX+IZ_FIX,NPAKNO,IPAPRO
C
                WRITE(NFIKER) KPROJE,ISOSTZ
C
                WRITE(NFIKER) NTZKNO,IN_FIX-IZ_FIX
C
                IF (NAMKER.EQ.1) THEN
C
                    WRITE(NFIKER) FILACT
                ELSE
                    WRITE(NFIKER) FILAC2
C
                END IF
C
                WRITE(NFIKER) NMURED,NMARED,NSIRED
C
                WRITE(NFIKER)
     *                OVKERN(M,J,N,M_T,0,N_T),OVKERN(M,J,N,M_T,L,N_T),
     *                EKKERN(M,J,N,M_T,0,N_T),EKKERN(M,J,N,M_T,L,N_T),
     *                CDKERN(M,J,N,M_T,L,N_T),
     *                CXKERN(M,J,N,M_T,L,N_T),
     *                SKKERN(M,J,N,M_T,L,N_T),
C TER*               (TEKERN(M,J,N,M_T,L,N_T,NUCOUT),NUCOUT=1,2*NDCOUT),
     *               ((QPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=0,NMURED),
     *               ((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=1,NMARED),
     *               ((SPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                          LAMBDA=NSIMIN,NSIRED)
C
                WRITE(NFIKER) GYRORP,GYRSPN,GYRSPP,IGYROS
C
                WRITE(NFIKER) GIN2BC,GSA2BC,IGY2BC
C
                WRITE(NFIKER) NMAORD
C
                WRITE(NFIKER)
     *              (((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),NUMORD),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=1,NMARED),
     *                                               NUMORD=1,NMAORD)
C
                WRITE(NFIKER) NASRED,NASORD
C
                IF (NASORD.GE.0) WRITE(NFIKER)
     *              (((WTKERN(M,J,N,IND_LM(LAMBDA,MIU),NUMORD),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=1,NASRED),
     *                                               NUMORD=0,NASORD)
C
                WRITE(NFIKER)
     *             CDKE10(M,J,N,M_T,L,N_T),
     *             CDKE1P(M,J,N,M_T,L,N_T),
     *             CXKE10(M,J,N,M_T,L,N_T),
     *             CXKE1P(M,J,N,M_T,L,N_T),
     *             CDKE1M(M,J,N,M_T,L,N_T),
     *             CDKE20(M,J,N,M_T,L,N_T),
     *             CDK21P(M,J,N,M_T,L,N_T),
     *             CDK21M(M,J,N,M_T,L,N_T),
     *             CDK22P(M,J,N,M_T,L,N_T),
     *             CDK22M(M,J,N,M_T,L,N_T),
     *             CXKE1M(M,J,N,M_T,L,N_T),
     *             CXKE20(M,J,N,M_T,L,N_T),
     *             CXK21P(M,J,N,M_T,L,N_T),
     *             CXK21M(M,J,N,M_T,L,N_T),
     *             CXK22P(M,J,N,M_T,L,N_T),
     *             CXK22M(M,J,N,M_T,L,N_T),
     *             PNKE00(M,J,N,M_T,L,N_T),
     *             PNKE10(M,J,N,M_T,L,N_T),
     *             PNKE1P(M,J,N,M_T,L,N_T),
     *             PNKE1M(M,J,N,M_T,L,N_T)
C
                WRITE(NFIKER)
     *             TZKERN(M,J,N,M_T,L,N_T),
     *             T2KERN(M,J,N,M_T,L,N_T)
C
                WRITE(NFIKER)
     *             EPKERN(M,J,N,M_T,0,N_T),
     *             EPKERN(M,J,N,M_T,L,N_T)
C
                WRITE(NFIKER)
     *             BZKERN(M,J,N,M_T,L,N_T),
     *             B2KERN(M,J,N,M_T,L,N_T)
C
                CLOSE(NFIKER)
C
            END IF
C
            ISPOIN(I,J,K,I_T,L,K_T)=ISPOIN(I,J,K,I_T,L,K_T)+1
C
C=======================================================================
C           INDENTATION MOVES FORWARD FROM THE 13TH TO THE CORRECT
C           25TH COLUMN
C=======================================================================
C
 89                     CONTINUE
C
C=======================================================================
C         HERE END THE LOOPS (NO. 1) OVER THE ISOSPIN ALPHA_T AND BETA_T
C         ISOSPIN GAUSS KNOTS.
C=======================================================================
C
                     END DO
                  END DO
C
                  ISAALL(I,J,K,L)=ISAALL(I,J,K,L)+1
C
 899              CONTINUE
C
C=======================================================================
C         HERE ENDS THE LOOP (NO. 1) OVER THE BETA_T ISOSPIN GAUSS KNOTS
C=======================================================================
C
               END DO
C
C=======================================================================
C         HERE ENDS THE LOOP (NO. 1) OVER THE BETA GAUSS KNOTS
C=======================================================================
C
            END DO
C
            ISALGA(I,K)=ISALGA(I,K)+1
C
C=======================================================================
C         HERE WE HANDLE THE SAVING OF IPAALL=0 KERNELS ON DISK
C=======================================================================
C
            IF (ISAKER.EQ.1.AND.IPAALL.NE.1) THEN
C
C=======================================================================
C         SEARCHING FOR THE NEXT AVAILABLE KERNEL FILE
C=======================================================================
C
                IF (IOPEND.NE.1) THEN
C
                    IF (KFIKER.LE.0) THEN
C
                       IFIBEG=001
                       IFIEND=999
                    ELSE
                       IFIBEG=KFIKER
                       IFIEND=KFIKER
C
                    END IF
C
                    DO IFIKER=IFIBEG,IFIEND
C
                       WRITE(FILACT(01:05),'(''N'',I3,''-'')') IFIKER
C
                       DO NUCHAR=02,04
C
                          IF (FILACT(NUCHAR:NUCHAR).EQ.' ')
     *                        FILACT(NUCHAR:NUCHAR)='0'
C
                       END DO
C
                       OPEN(NFIKER,FILE=FILACT,STATUS='NEW',ERR=19,
     *                             FORM='UNFORMATTED')
C
                       CLOSE(NFIKER)
C
C=======================================================================
C         THE NEXT AVAILABLE KERNEL FILE FOUND
C=======================================================================
C
                       IOPEND=1
C
                       GO TO 18
C
   19                  CONTINUE
C
                    END DO
C
C                   STOP' ALL KERNEL FILES N001-N999 ARE ALREADY IN USE'
C
                    FILACT(02:04)='000'
C
                    OPEN(NFIKER,FILE=FILACT,STATUS='NEW',
     *                          FORM='UNFORMATTED')
C
                    CLOSE(NFIKER)
C
   18               CONTINUE
C
                END IF
C
C=======================================================================
C         OPENING THE FILE
C=======================================================================
C
                OPEN(NFIKER,FILE=FILACT,STATUS='OLD',
     *                      POSITION='APPEND',FORM='UNFORMATTED')
C
C=======================================================================
C         WRITING THE FILE
C=======================================================================
C
                WRITE(NFIKER) I,K,IVERKE
C
                WRITE(NFIKER) IPAALL,0,0
C
                WRITE(NFIKER) FILACT
C
                WRITE(NFIKER) NUBKNO,NBTKNO,NMURED,NMARED,NSIRED
C
                DO J=1,NUBKNO
C
                   WRITE(NFIKER) J,
     *                (OVKERN(M,J,N,1,L,1),L=0,NBTKNO),
     *                (EKKERN(M,J,N,1,L,1),L=0,NBTKNO),
     *                (CDKERN(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXKERN(M,J,N,1,L,1),L=1,NBTKNO),
     *                (SKKERN(M,J,N,1,L,1),L=1,NBTKNO),
     *               ((QPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=0,NMURED),
     *               ((ATKERN(M,J,N,IND_LM(LAMBDA,MIU),0),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                               LAMBDA=1,NMARED),
     *               ((SPKERN(M,J,N,IND_LM(LAMBDA,MIU)),
     *                                            MIU=-LAMBDA,LAMBDA),
     *                                          LAMBDA=NSIMIN,NSIRED)
C
                   WRITE(NFIKER)
     *                (CDKE10(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CDKE1P(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXKE10(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXKE1P(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CDKE1M(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CDKE20(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CDK21P(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CDK21M(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CDK22P(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CDK22M(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXKE1M(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXKE20(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXK21P(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXK21M(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXK22P(M,J,N,1,L,1),L=1,NBTKNO),
     *                (CXK22M(M,J,N,1,L,1),L=1,NBTKNO),
     *                (PNKE00(M,J,N,1,L,1),L=1,NBTKNO),
     *                (PNKE10(M,J,N,1,L,1),L=1,NBTKNO),
     *                (PNKE1P(M,J,N,1,L,1),L=1,NBTKNO),
     *                (PNKE1M(M,J,N,1,L,1),L=1,NBTKNO)
C
                   WRITE(NFIKER)
     *                (TZKERN(M,J,N,1,L,1),L=1,NBTKNO),
     *                (T2KERN(M,J,N,1,L,1),L=1,NBTKNO)
C
                   WRITE(NFIKER)
     *                (EPKERN(M,J,N,1,L,1),L=0,NBTKNO)
C
                   WRITE(NFIKER)
     *                (BZKERN(M,J,N,1,L,1),L=1,NBTKNO),
     *                (B2KERN(M,J,N,1,L,1),L=1,NBTKNO)
C
                END DO
C
                CLOSE(NFIKER)
C
            END IF
C
C=======================================================================
C         HERE END THE LOOPS (NO.1) OVER THE ALPHA AND GAMMA GAUSS KNOTS
C=======================================================================
C
    9       CONTINUE
C
         END DO
      END DO
C
      IF (ISAKER.EQ.1.AND.IPAALL.NE.1) THEN
C
          IF (IOPEND.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE GCM KERNELS IN FUNCTION OF THE EULER'',
     *               '' ANGLES ARE SAVED; FILE (FILKER):'',   2X,1H*,/,
     *        1H*,2X,A68,                                     7X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                                         79(1H*),/,1H*,77X,1H*,/,
     *              1H*,2X,A14,     I4,'' <= I <='',   I3,
     *                    ''  AND'',I4,'' <= K <='',   I3,
     *                    ''; TOT'',I6,'' PNTS ARE SAVD'',    1X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                                                        79(1H*))')
     *
     *            FILKER,
     *            FILACT(01:14),NUABEG,NUAEND,NUGBEG,NUGEND,NUALGA
C
          ELSE
C
              IF (ICOMIX.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IPRKER=0
C
      IF (IPRKER.EQ.1) THEN
C
          AKKMAX=0.0D0
          JKKMAX=0
          IKKMAX=0
          KKKMAX=0
          LKKMAX=0
C
CJD? DOROBIC PETLE IZOSPINOWE DO DRUKOWANIA
C
          DO I=1,NUAKNO
             DO J=1,NUBKNO
                DO K=1,NUAKNO
C
                   IF (NBTKNO.EQ.1) THEN
C
                       WRITE(NFIPRI,1001) I,J,K,1,ISALGA(I,K),
     *                                          ISAALL(I,J,K,1),
     *              'ON',OVKERN(I,J,K,1,0,1),'OP',OVKERN(I,J,K,1,1,1),
     *              'KN',EKKERN(I,J,K,1,0,1),'KP',EKKERN(I,J,K,1,1,1),
     *              'CD',CDKERN(I,J,K,1,1,1),
C    *              'CD',CDKERN(I,J,K,1,1,1),'CX',CXKERN(I,J,K,1,1,1),
     *              'SK',SKKERN(I,J,K,1,1,1)
 1001                  FORMAT(6I3,6(1X,A2,1PE9.2,1PE9.2))
C
                   ELSE
C
                       DO L=1,NBTKNO
C
                          WRITE(NFIPRI,2001) I,J,K,L,ISALGA(I,K),
     *                                               ISAALL(I,J,K,L),
     *                   'OV',OVKERN(I,J,K,1,L,1),
     *                   'EN',EKKERN(I,J,K,1,L,1)+CDKERN(I,J,K,1,L,1)
     *                       +CXKERN(I,J,K,1,L,1)+SKKERN(I,J,K,1,L,1),
     *                   'KI',EKKERN(I,J,K,1,L,1),
     *                   'CD',CDKERN(I,J,K,1,L,1),
     *                   'CX',CXKERN(I,J,K,1,L,1),
     *                   'SK',SKKERN(I,J,K,1,L,1)
 2001                     FORMAT(6I3,6(1X,A2,1PE9.2,1PE9.2))
C
                          IF (AKKMAX.LT.
     *                ABS(EKKERN(I,J,K,1,L,1)+CDKERN(I,J,K,1,L,1)
     *                   +CXKERN(I,J,K,1,L,1)+SKKERN(I,J,K,1,L,1))) THEN
C
                     AKKMAX=ABS(EKKERN(I,J,K,1,L,1)+CDKERN(I,J,K,1,L,1)
     *                         +CXKERN(I,J,K,1,L,1)+SKKERN(I,J,K,1,L,1))
                             JKKMAX=J
                             IKKMAX=I
                             KKKMAX=K
                             LKKMAX=L
C
                          END IF
C
                       END DO
C
                   END IF
C
                END DO
             END DO
          END DO
C
          IF (NBTKNO.NE.1) THEN
C
              WRITE(NFIPRI,'(/,1X,4I3,1PE13.6,/)')
     *              IKKMAX,JKKMAX,KKKMAX,LKKMAX,AKKMAX
C
          END IF
C
      END IF
C
C=======================================================================
C         ZEROING VARIABLES THAT ARE USED FOR CALCULATION OF SUM RULES
C=======================================================================
C
      RKER_T=C_ZERO
      RSKY_T=C_ZERO
      RKIN_T=C_ZERO
      RPAI_T=C_ZERO
      RCOU_D=C_ZERO
      RCOU_X=C_ZERO
      RPARTN=C_ZERO
      RISOSP=C_ZERO
      RTZISO=C_ZERO
      RT2ISO=C_ZERO
      RBZROT=C_ZERO
      RB2ROT=C_ZERO
C
      DO LAMBDA=0,NDMULR
         DO MIU=-LAMBDA,LAMBDA
C
            RMUL_P(LAMBDA,MIU)=C_ZERO
            RMAG_T(LAMBDA,MIU)=C_ZERO
            RSIF_P(LAMBDA,MIU)=C_ZERO
            RASM_T(LAMBDA,MIU)=C_ZERO
C
         END DO
      END DO
C
C=======================================================================
C         THIS JUMP SUSPENDS INTEGRATION OF KERNELS FOR A PARALLEL RUN
C=======================================================================
C
      IF (IPAKER.EQ.1) GO TO 10
C
C=======================================================================
C                          KERNELS ARE LOADED
C                   HERE STARTS THE "INTEGRATION" BLOCK
C=======================================================================
C
C=======================================================================
C         ALLOCATING ARRAYS FOR INTEGRATION OVER THE SPIN EULER ANGLES
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.96D AND 2.990, THE ARRAYS  BELOW
C                    WERE  ALLOCATED   WITH  INVERTED   DIMENSIONS   OF
C                       "NUISOM,0:NUPROM" INSTEAD OF "NUPROM,0:NUISOM"
C                    THIS BUG, WHICH  FOR  THE  ISOSPIN  PROJECTION  WAS
C                    CAUSING THE SEGMENTATION-FAULT ERROR, WAS CORRECTED
C                    ON 28/09/2020 IN VERSION 2.991.
C=======================================================================
C
      ALLOCATE (TKE_TT(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TKE_TT','PROANG')
      ALLOCATE (TSK_TT(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TSK_TT','PROANG')
      ALLOCATE (TKI_NT(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TKI_NT','PROANG')
      ALLOCATE (TKI_PT(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TKI_PT','PROANG')
      ALLOCATE (TCO_DT(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TCO_DT','PROANG')
      ALLOCATE (TCO_XT(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TCO_XT','PROANG')
      ALLOCATE (TPA_NT(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPA_NT','PROANG')
      ALLOCATE (TPA_PT(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPA_PT','PROANG')
      ALLOCATE (TPN_00(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPN_00','PROANG')
      ALLOCATE (TPN_10(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPN_10','PROANG')
      ALLOCATE (TPN_1P(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPN_1P','PROANG')
      ALLOCATE (TPN_1M(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPN_1M','PROANG')
      ALLOCATE (TTZ_IS(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TTZ_IS','PROANG')
      ALLOCATE (TT2_IS(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TT2_IS','PROANG')
      ALLOCATE (TBZ_RO(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TBZ_RO','PROANG')
      ALLOCATE (TB2_RO(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TB2_RO','PROANG')
      ALLOCATE (TC1_D0(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1_D0','PROANG')
      ALLOCATE (TC1_DP(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1_DP','PROANG')
      ALLOCATE (TC1_DM(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1_DM','PROANG')
      ALLOCATE (TC2_D0(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC2_D0','PROANG')
      ALLOCATE (TC21DP(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC21DP','PROANG')
      ALLOCATE (TC21DM(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC21DM','PROANG')
      ALLOCATE (TC22DP(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC22DP','PROANG')
      ALLOCATE (TC22DM(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC22DM','PROANG')
      ALLOCATE (TC1_X0(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1_X0','PROANG')
      ALLOCATE (TC1_XP(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1_XP','PROANG')
      ALLOCATE (TC1_XM(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1_XM','PROANG')
      ALLOCATE (TC2_X0(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC2_X0','PROANG')
      ALLOCATE (TC21XP(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC21XP','PROANG')
      ALLOCATE (TC21XM(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC21XM','PROANG')
      ALLOCATE (TC22XP(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC22XP','PROANG')
      ALLOCATE (TC22XM(NUPROM,0:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC22XM','PROANG')
C
C=======================================================================
C         ZEROING ARRAYS FOR INTEGRATION OVER THE SPIN EULER ANGLES
C=======================================================================
C
C TER TTE_TT=C_ZERO
      TKE_TT(:,:)=C_ZERO
      TSK_TT(:,:)=C_ZERO
      TKI_NT(:,:)=C_ZERO
      TKI_PT(:,:)=C_ZERO
      TCO_DT(:,:)=C_ZERO
      TCO_XT(:,:)=C_ZERO
      TPA_NT(:,:)=C_ZERO
      TPA_PT(:,:)=C_ZERO
      TPN_00(:,:)=C_ZERO
      TPN_10(:,:)=C_ZERO
      TPN_1P(:,:)=C_ZERO
      TPN_1M(:,:)=C_ZERO
      TTZ_IS(:,:)=C_ZERO
      TT2_IS(:,:)=C_ZERO
      TBZ_RO(:,:)=C_ZERO
      TB2_RO(:,:)=C_ZERO
      TC1_D0(:,:)=C_ZERO
      TC1_DP(:,:)=C_ZERO
      TC1_DM(:,:)=C_ZERO
      TC2_D0(:,:)=C_ZERO
      TC21DP(:,:)=C_ZERO
      TC21DM(:,:)=C_ZERO
      TC22DP(:,:)=C_ZERO
      TC22DM(:,:)=C_ZERO
      TC1_X0(:,:)=C_ZERO
      TC1_XP(:,:)=C_ZERO
      TC1_XM(:,:)=C_ZERO
      TC2_X0(:,:)=C_ZERO
      TC21XP(:,:)=C_ZERO
      TC21XM(:,:)=C_ZERO
      TC22XP(:,:)=C_ZERO
      TC22XM(:,:)=C_ZERO
C
      OPROJE=C_ZERO
      EPROJE=C_ZERO
C
C=======================================================================
C         ALLOCATING ARRAYS OF MULTIPOLE, MAGNETIC, AND SPIN-ASY MOMENTS
C=======================================================================
C
      ALLOCATE (TMUL_P(NDMULM,NUPREM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TMUL_P','PROANG')
      ALLOCATE (TMAG_T(NDMULM,NUPREM,0:NMAORD),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TMAG_T','PROANG')
      ALLOCATE (TSIF_P(NDMULM,NUPREM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TSIF_P','PROANG')
      IF (NASORD.GE.0)
     *ALLOCATE (TASM_T(NDMULM,NUPREM,0:NASORD),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TASM_T','PROANG')
C
C=======================================================================
C         ZEROING ARRAYS OF MULTIPOLE, MAGNETIC, AND SPIN-ASY MOMENTS
C=======================================================================
C
      TMUL_P(:,:)=C_ZERO
      TMAG_T(:,:,:)=C_ZERO
      TSIF_P(:,:)=C_ZERO
      IF (NASORD.GE.0)
     *TASM_T(:,:,:)=C_ZERO
C
C=======================================================================
C         ALLOCATING ARRAYS FOR INTEGRATION OVER THE ISOSPIN EULR ANGLES
C=======================================================================
C
      ALLOCATE (TKER_T(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TKER_T','PROANG')
      ALLOCATE (TSKY_T(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TSKY_T','PROANG')
      ALLOCATE (TKIN_N(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TKIN_N','PROANG')
      ALLOCATE (TKIN_P(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TKIN_P','PROANG')
      ALLOCATE (TCOU_D(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TCOU_D','PROANG')
      ALLOCATE (TCOU_X(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TCOU_X','PROANG')
      ALLOCATE (TPAI_N(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPAI_N','PROANG')
      ALLOCATE (TPAI_P(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPAI_P','PROANG')
      ALLOCATE (TPNU00(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPNU00','PROANG')
      ALLOCATE (TPNU10(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPNU10','PROANG')
      ALLOCATE (TPNU1P(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPNU1P','PROANG')
      ALLOCATE (TPNU1M(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TPNU1M','PROANG')
      ALLOCATE (TTZISO(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TTZISO','PROANG')
      ALLOCATE (TT2ISO(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TT2ISO','PROANG')
      ALLOCATE (TBZROT(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TBZROT','PROANG')
      ALLOCATE (TB2ROT(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TB2ROT','PROANG')
      ALLOCATE (TC10_D(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC10_D','PROANG')
      ALLOCATE (TC1P_D(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1P_D','PROANG')
      ALLOCATE (TC1M_D(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1M_D','PROANG')
      ALLOCATE (TC20_D(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC20_D','PROANG')
      ALLOCATE (TC21PD(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC21PD','PROANG')
      ALLOCATE (TC21MD(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC21MD','PROANG')
      ALLOCATE (TC22PD(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC22PD','PROANG')
      ALLOCATE (TC22MD(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC22MD','PROANG')
      ALLOCATE (TC10_X(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC10_X','PROANG')
      ALLOCATE (TC1P_X(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1P_X','PROANG')
      ALLOCATE (TC1M_X(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC1M_X','PROANG')
      ALLOCATE (TC20_X(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC20_X','PROANG')
      ALLOCATE (TC21PX(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC21PX','PROANG')
      ALLOCATE (TC21MX(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC21MX','PROANG')
      ALLOCATE (TC22PX(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC22PX','PROANG')
      ALLOCATE (TC22MX(NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('TC22MX','PROANG')
C
C=======================================================================
C    HERE START THE LOOPS OVER THE BETA (J), ALPHA (I), GAMMA (K), AND
C                        BETISO (L) GAUSS KNOTS
C                 INTEGRATION OVER ALPHA_T AND GAMMA_T COMES FIRST
C             IT IS FOLLOWED BY INTEGRATION OVER BETISO (L)
C        THEN IT IS FOLLOWED BY INTEGRATION OVER GAMMA AND ALPHA.
C                   FINAL INTEGRATION GOES OVER BETA
C=======================================================================
C
      DO J=1,NUBKNO
        DO I=1,NUAKNO
          DO K=1,NUAKNO
C
C=======================================================================
C         ZEROING ARRAYS FOR INTEGRATION OVER THE ISOSPIN EULER ANGLES
C=======================================================================
C
C TER        TTER_T=C_ZERO
             TKER_T(:)=C_ZERO
             TSKY_T(:)=C_ZERO
             TKIN_N(:)=C_ZERO
             TKIN_P(:)=C_ZERO
             TCOU_D(:)=C_ZERO
             TCOU_X(:)=C_ZERO
             TPAI_N(:)=C_ZERO
             TPAI_P(:)=C_ZERO
             TPNU00(:)=C_ZERO
             TPNU10(:)=C_ZERO
             TPNU1P(:)=C_ZERO
             TPNU1M(:)=C_ZERO
             TTZISO(:)=C_ZERO
             TT2ISO(:)=C_ZERO
             TBZROT(:)=C_ZERO
             TB2ROT(:)=C_ZERO
             TC10_D(:)=C_ZERO
             TC1P_D(:)=C_ZERO
             TC1M_D(:)=C_ZERO
             TC20_D(:)=C_ZERO
             TC21PD(:)=C_ZERO
             TC21MD(:)=C_ZERO
             TC22PD(:)=C_ZERO
             TC22MD(:)=C_ZERO
             TC10_X(:)=C_ZERO
             TC1P_X(:)=C_ZERO
             TC1M_X(:)=C_ZERO
             TC20_X(:)=C_ZERO
             TC21PX(:)=C_ZERO
             TC21MX(:)=C_ZERO
             TC22PX(:)=C_ZERO
             TC22MX(:)=C_ZERO
C
C=======================================================================
C
             DO L=1,NBTKNO
C
C TER          UTER_T=C_ZERO
               UKER_T=C_ZERO
C
               USKY_T=C_ZERO
               UKIN_N=C_ZERO
               UKIN_P=C_ZERO
C
               UPAI_N=C_ZERO
               UPAI_P=C_ZERO
C
               UCOU_D=C_ZERO
               UC10_D=C_ZERO
               UC1P_D=C_ZERO
               UC1M_D=C_ZERO
               UC20_D=C_ZERO
               UC21PD=C_ZERO
               UC21MD=C_ZERO
               UC22PD=C_ZERO
               UC22MD=C_ZERO
C
               UCOU_X=C_ZERO
               UC10_X=C_ZERO
               UC1P_X=C_ZERO
               UC1M_X=C_ZERO
               UC20_X=C_ZERO
               UC21PX=C_ZERO
               UC21MX=C_ZERO
               UC22PX=C_ZERO
               UC22MX=C_ZERO
C
               UPNU00=C_ZERO
               UPNU10=C_ZERO
               UPNU1P=C_ZERO
               UPNU1M=C_ZERO
C
               UTZISO=C_ZERO
               UT2ISO=C_ZERO
C
               UBZROT=C_ZERO
               UB2ROT=C_ZERO
C
               DO I_T=1,NATKNO
C
                  DO KSOSAC=KSOSTA(JSOSMA),KSOSTO(JSOSMA),2
C
C=======================================================================
C         BELOW WE INTEGRATE KERNELS OVER THE GAMMA_T EULER ANGLE AND
C         AT THE SAME TIME WE MULTIPLY THEM BY THE  GAUSS  WEIGHTS
C=======================================================================
C
                     DO K_T=1,NATKNO
C
                        GAMM_K=XAT_PN(K_T)*0.5D0*KSOSAC
C
                        FACINT=XAT_WG(K_T)
     *                                 *(COS(GAMM_K)+UNIT_I*SIN(GAMM_K))
C
                        IF (NBTKNO.EQ.1) THEN
                            FACINT=FACINT*XBT_WG(L)*OVKERN(I,J,K,1,1,1)
                        ELSE
                            FACINT=FACINT*XBT_WG(L)
     *                                          *OVKERN(I,J,K,I_T,L,K_T)
                        END IF
C
                        FACI1M=FACINT
                        FACI1P=FACINT
                        FACI2M=FACINT
                        FACI2P=FACINT
C
C=======================================================================
C            INTEGRATING THE NORM, ENERGY AND COULOMB KERNELS
C=======================================================================
C
                        UKER_T(I_T,KSOSAC)=UKER_T(I_T,KSOSAC)+FACINT
C
                        IF (NBTKNO.EQ.1) THEN
C
                            UKIN_N(I_T,KSOSAC)=UKIN_N(I_T,KSOSAC)
     *                                       +FACINT*EKKERN(I,J,K,1,0,1)
                            UKIN_P(I_T,KSOSAC)=UKIN_P(I_T,KSOSAC)
     *                                       +FACINT*EKKERN(I,J,K,1,1,1)
C
                            UPAI_N(I_T,KSOSAC)=UPAI_N(I_T,KSOSAC)
     *                                    +FACINT*EPKERN(I,J,K,1,0,1)
                            UPAI_P(I_T,KSOSAC)=UPAI_P(I_T,KSOSAC)
     *                                    +FACINT*EPKERN(I,J,K,1,1,1)
                         ELSE
C
                            UKIN_N(I_T,KSOSAC)=UKIN_N(I_T,KSOSAC)
     *                                   +FACINT*EKKERN(I,J,K,I_T,L,K_T)
                            UKIN_P(I_T,KSOSAC)=C_ZERO
                         END IF
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER                UTER_T(I_T,KSOSAC,NUCOUT)=UTER_T(I_T,KSOSAC,NUCOUT)
C TER*                            +FACINT*TEKERN(I,J,K,I_T,L,K_T,NUCOUT)
C TER        END DO
C
C                  T E S T I N G
C
C JD              DATA IDUPA/0/
C                 IF (IDUPA.EQ.0) WRITE(*,*) ' TYLKO ISOSKALAR'
C JD              IF (IDUPA.EQ.0) WRITE(*,*) ' BEZ KULOMBA    '
C JD              IDUPA=1
C
C JD              CDKERN(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CDKE10(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CDKE1P(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CDKE1M(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CDKE20(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CDK21P(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CDK21M(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CDK22P(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CDK22M(I,J,K,I_T,L,K_T)=C_ZERO
C
C JD              CXKERN(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CXKE10(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CXKE1P(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CXKE1M(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CXKE20(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CXK21P(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CXK21M(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CXK22P(I,J,K,I_T,L,K_T)=C_ZERO
C JD              CXK22M(I,J,K,I_T,L,K_T)=C_ZERO
C
                         USKY_T(I_T,KSOSAC)=USKY_T(I_T,KSOSAC)
     *                                   +FACINT*SKKERN(I,J,K,I_T,L,K_T)
                         UCOU_D(I_T,KSOSAC)=UCOU_D(I_T,KSOSAC)
     *                                   +FACINT*CDKERN(I,J,K,I_T,L,K_T)
                         UC10_D(I_T,KSOSAC)=UC10_D(I_T,KSOSAC)
     *                                   +FACINT*CDKE10(I,J,K,I_T,L,K_T)
                         UC1P_D(I_T,KSOSAC)=UC1P_D(I_T,KSOSAC)
     *                                   +FACI1P*CDKE1P(I,J,K,I_T,L,K_T)
                         UC1M_D(I_T,KSOSAC)=UC1M_D(I_T,KSOSAC)
     *                                   +FACI1M*CDKE1M(I,J,K,I_T,L,K_T)
                         UC20_D(I_T,KSOSAC)=UC20_D(I_T,KSOSAC)
     *                                   +FACINT*CDKE20(I,J,K,I_T,L,K_T)
                         UC21PD(I_T,KSOSAC)=UC21PD(I_T,KSOSAC)
     *                                   +FACI1P*CDK21P(I,J,K,I_T,L,K_T)
                         UC21MD(I_T,KSOSAC)=UC21MD(I_T,KSOSAC)
     *                                   +FACI1M*CDK21M(I,J,K,I_T,L,K_T)
                         UC22PD(I_T,KSOSAC)=UC22PD(I_T,KSOSAC)
     *                                   +FACI2P*CDK22P(I,J,K,I_T,L,K_T)
                         UC22MD(I_T,KSOSAC)=UC22MD(I_T,KSOSAC)
     *                                   +FACI2M*CDK22M(I,J,K,I_T,L,K_T)
C
                         UCOU_X(I_T,KSOSAC)=UCOU_X(I_T,KSOSAC)
     *                                   +FACINT*CXKERN(I,J,K,I_T,L,K_T)
                         UC10_X(I_T,KSOSAC)=UC10_X(I_T,KSOSAC)
     *                                   +FACINT*CXKE10(I,J,K,I_T,L,K_T)
                         UC1P_X(I_T,KSOSAC)=UC1P_X(I_T,KSOSAC)
     *                                   +FACI1P*CXKE1P(I,J,K,I_T,L,K_T)
                         UC1M_X(I_T,KSOSAC)=UC1M_X(I_T,KSOSAC)
     *                                   +FACI1M*CXKE1M(I,J,K,I_T,L,K_T)
                         UC20_X(I_T,KSOSAC)=UC20_X(I_T,KSOSAC)
     *                                   +FACINT*CXKE20(I,J,K,I_T,L,K_T)
                         UC21PX(I_T,KSOSAC)=UC21PX(I_T,KSOSAC)
     *                                   +FACI1P*CXK21P(I,J,K,I_T,L,K_T)
                         UC21MX(I_T,KSOSAC)=UC21MX(I_T,KSOSAC)
     *                                   +FACI1M*CXK21M(I,J,K,I_T,L,K_T)
                         UC22PX(I_T,KSOSAC)=UC22PX(I_T,KSOSAC)
     *                                   +FACI2P*CXK22P(I,J,K,I_T,L,K_T)
                         UC22MX(I_T,KSOSAC)=UC22MX(I_T,KSOSAC)
     *                                   +FACI2M*CXK22M(I,J,K,I_T,L,K_T)
C
                         UPNU00(I_T,KSOSAC)=UPNU00(I_T,KSOSAC)
     *                                   +FACINT*PNKE00(I,J,K,I_T,L,K_T)
                         UPNU10(I_T,KSOSAC)=UPNU10(I_T,KSOSAC)
     *                                   +FACINT*PNKE10(I,J,K,I_T,L,K_T)
                         UPNU1P(I_T,KSOSAC)=UPNU1P(I_T,KSOSAC)
     *                                   +FACI1P*PNKE1P(I,J,K,I_T,L,K_T)
                         UPNU1M(I_T,KSOSAC)=UPNU1M(I_T,KSOSAC)
     *                                   +FACI1M*PNKE1M(I,J,K,I_T,L,K_T)
C
                         UTZISO(I_T,KSOSAC)=UTZISO(I_T,KSOSAC)
     *                                   +FACINT*TZKERN(I,J,K,I_T,L,K_T)
                         UT2ISO(I_T,KSOSAC)=UT2ISO(I_T,KSOSAC)
     *                                   +FACINT*T2KERN(I,J,K,I_T,L,K_T)
C
                         UBZROT(I_T,KSOSAC)=UBZROT(I_T,KSOSAC)
     *                                   +FACINT*BZKERN(I,J,K,I_T,L,K_T)
                         UB2ROT(I_T,KSOSAC)=UB2ROT(I_T,KSOSAC)
     *                                   +FACINT*B2KERN(I,J,K,I_T,L,K_T)
C
C=======================================================================
C           HERE END THE LOOPS  OVER THE  GAMMA_T  GAUSS  KNOTS
C         AND THE LOOP OVER THE K_T PROJECTION ON THE INTRINSIC AXIS
C=======================================================================
C
                      END DO
                  END DO
C
C=======================================================================
C           HERE END THE LOOP OVER THE  ALPHA_T  GAUSS  KNOTS
C=======================================================================
C
               END DO
C
C=======================================================================
C         ZEROING AUXILIARY ARRAYS OF OVERLAP AND ENERGY KERNELS
C=======================================================================
C
C TER          WTER_T=C_ZERO
               WKER_T=C_ZERO
C
               WSKY_T=C_ZERO
               WKIN_N=C_ZERO
               WKIN_P=C_ZERO
C
               WPAI_N=C_ZERO
               WPAI_P=C_ZERO
C
               WCOU_D=C_ZERO
               WC10_D=C_ZERO
               WC1P_D=C_ZERO
               WC1M_D=C_ZERO
               WC20_D=C_ZERO
               WC21PD=C_ZERO
               WC21MD=C_ZERO
               WC22PD=C_ZERO
               WC22MD=C_ZERO
C
               WCOU_X=C_ZERO
               WC10_X=C_ZERO
               WC1P_X=C_ZERO
               WC1M_X=C_ZERO
               WC20_X=C_ZERO
               WC21PX=C_ZERO
               WC21MX=C_ZERO
               WC22PX=C_ZERO
               WC22MX=C_ZERO
C
               WPNU00=C_ZERO
               WPNU10=C_ZERO
               WPNU1P=C_ZERO
               WPNU1M=C_ZERO
C
               WTZISO=C_ZERO
               WT2ISO=C_ZERO
C
               WBZROT=C_ZERO
               WB2ROT=C_ZERO
C
               DO LSOSAC=KSOSTA(JSOSMA),KSOSTO(JSOSMA),2
C
                  DO KSOSAC=KSOSTA(JSOSMA),KSOSTO(JSOSMA),2
C
                     DO I_T=1,NATKNO
C
                        ALPH_L=XAT_PN(I_T)*0.5D0*LSOSAC
C
                        FACINT=XAT_WG(I_T)
     *                        *(COS(ALPH_L)+UNIT_I*SIN(ALPH_L))
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER          WTER_T(LSOSAC,KSOSAC,NUCOUT)=WTER_T(LSOSAC,KSOSAC,NUCOUT)
C TER*                                 +FACINT*UTER_T(I_T,KSOSAC,NUCOUT)
C TER        END DO
                        WKER_T(LSOSAC,KSOSAC)=WKER_T(LSOSAC,KSOSAC)
     *                                        +FACINT*UKER_T(I_T,KSOSAC)
C
                        WSKY_T(LSOSAC,KSOSAC)=WSKY_T(LSOSAC,KSOSAC)
     *                                        +FACINT*USKY_T(I_T,KSOSAC)
                        WKIN_N(LSOSAC,KSOSAC)=WKIN_N(LSOSAC,KSOSAC)
     *                                        +FACINT*UKIN_N(I_T,KSOSAC)
                        WKIN_P(LSOSAC,KSOSAC)=WKIN_P(LSOSAC,KSOSAC)
     *                                        +FACINT*UKIN_P(I_T,KSOSAC)
C
                        WPAI_N(LSOSAC,KSOSAC)=WPAI_N(LSOSAC,KSOSAC)
     *                                     +FACINT*UPAI_N(I_T,KSOSAC)
                        WPAI_P(LSOSAC,KSOSAC)=WPAI_P(LSOSAC,KSOSAC)
     *                                        +FACINT*UPAI_P(I_T,KSOSAC)
C
                        WCOU_D(LSOSAC,KSOSAC)=WCOU_D(LSOSAC,KSOSAC)
     *                                        +FACINT*UCOU_D(I_T,KSOSAC)
                        WC10_D(LSOSAC,KSOSAC)=WC10_D(LSOSAC,KSOSAC)
     *                                        +FACINT*UC10_D(I_T,KSOSAC)
                        WC1P_D(LSOSAC,KSOSAC)=WC1P_D(LSOSAC,KSOSAC)
     *                                        +FACINT*UC1P_D(I_T,KSOSAC)
                        WC1M_D(LSOSAC,KSOSAC)=WC1M_D(LSOSAC,KSOSAC)
     *                                        +FACINT*UC1M_D(I_T,KSOSAC)
                        WC20_D(LSOSAC,KSOSAC)=WC20_D(LSOSAC,KSOSAC)
     *                                        +FACINT*UC20_D(I_T,KSOSAC)
                        WC21PD(LSOSAC,KSOSAC)=WC21PD(LSOSAC,KSOSAC)
     *                                        +FACINT*UC21PD(I_T,KSOSAC)
                        WC21MD(LSOSAC,KSOSAC)=WC21MD(LSOSAC,KSOSAC)
     *                                        +FACINT*UC21MD(I_T,KSOSAC)
                        WC22PD(LSOSAC,KSOSAC)=WC22PD(LSOSAC,KSOSAC)
     *                                        +FACINT*UC22PD(I_T,KSOSAC)
                        WC22MD(LSOSAC,KSOSAC)=WC22MD(LSOSAC,KSOSAC)
     *                                        +FACINT*UC22MD(I_T,KSOSAC)
C
                        WCOU_X(LSOSAC,KSOSAC)=WCOU_X(LSOSAC,KSOSAC)
     *                                        +FACINT*UCOU_X(I_T,KSOSAC)
                        WC10_X(LSOSAC,KSOSAC)=WC10_X(LSOSAC,KSOSAC)
     *                                        +FACINT*UC10_X(I_T,KSOSAC)
                        WC1P_X(LSOSAC,KSOSAC)=WC1P_X(LSOSAC,KSOSAC)
     *                                        +FACINT*UC1P_X(I_T,KSOSAC)
                        WC1M_X(LSOSAC,KSOSAC)=WC1M_X(LSOSAC,KSOSAC)
     *                                        +FACINT*UC1M_X(I_T,KSOSAC)
                        WC20_X(LSOSAC,KSOSAC)=WC20_X(LSOSAC,KSOSAC)
     *                                        +FACINT*UC20_X(I_T,KSOSAC)
                        WC21PX(LSOSAC,KSOSAC)=WC21PX(LSOSAC,KSOSAC)
     *                                        +FACINT*UC21PX(I_T,KSOSAC)
                        WC21MX(LSOSAC,KSOSAC)=WC21MX(LSOSAC,KSOSAC)
     *                                        +FACINT*UC21MX(I_T,KSOSAC)
                        WC22PX(LSOSAC,KSOSAC)=WC22PX(LSOSAC,KSOSAC)
     *                                        +FACINT*UC22PX(I_T,KSOSAC)
                        WC22MX(LSOSAC,KSOSAC)=WC22MX(LSOSAC,KSOSAC)
     *                                        +FACINT*UC22MX(I_T,KSOSAC)
C
                        WPNU00(LSOSAC,KSOSAC)=WPNU00(LSOSAC,KSOSAC)
     *                                        +FACINT*UPNU00(I_T,KSOSAC)
                        WPNU10(LSOSAC,KSOSAC)=WPNU10(LSOSAC,KSOSAC)
     *                                        +FACINT*UPNU10(I_T,KSOSAC)
                        WPNU1P(LSOSAC,KSOSAC)=WPNU1P(LSOSAC,KSOSAC)
     *                                        +FACINT*UPNU1P(I_T,KSOSAC)
                        WPNU1M(LSOSAC,KSOSAC)=WPNU1M(LSOSAC,KSOSAC)
     *                                        +FACINT*UPNU1M(I_T,KSOSAC)
C
                        WTZISO(LSOSAC,KSOSAC)=WTZISO(LSOSAC,KSOSAC)
     *                                        +FACINT*UTZISO(I_T,KSOSAC)
                        WT2ISO(LSOSAC,KSOSAC)=WT2ISO(LSOSAC,KSOSAC)
     *                                        +FACINT*UT2ISO(I_T,KSOSAC)
C
                        WBZROT(LSOSAC,KSOSAC)=WBZROT(LSOSAC,KSOSAC)
     *                                        +FACINT*UBZROT(I_T,KSOSAC)
                        WB2ROT(LSOSAC,KSOSAC)=WB2ROT(LSOSAC,KSOSAC)
     *                                        +FACINT*UB2ROT(I_T,KSOSAC)
C
C=======================================================================
C         HERE ENDS THE LOOP OVER THE ALPHA_T GAUSS KNOTS (I_T), AND THE
C         LOOPS OVER THE L AND K ISOSPIN PROJECTIONS
C=======================================================================
C
                     END DO
C
                  END DO
               END DO
C
C=======================================================================
C
C              DO ISOSAC=JSOSMI,JSOSMA,2
C                 DO LSOSAC=KSOSTA(ISOSAC),KSOSTO(ISOSAC),2
C                    DO KSOSAC=KSOSTA(ISOSAC),KSOSTO(ISOSAC),2
C
               DO INDISO=1,NUISOM
C
                  ISOSAC=ISOMAT(INDISO)
                  LSOSAC=LSOMAT(INDISO)
                  KSOSAC=KSOMAT(INDISO)
C
                        FACINT=C_UNIT
                        FACI1M=C_ZERO
                        FACI1P=C_ZERO
                        FACI2M=C_ZERO
                        FACI2P=C_ZERO
C
                        IF (NBTKNO.GT.1) THEN
C
                           FACINT=DSMALH(ISOSAC,LSOSAC,KSOSAC,
     *                                   XBT_PN(L),NEWWIG,ISWIND,NUANGU)
C
                        IF (NATKNO.EQ.1) THEN
C
                           IF(LSOSAC-2.GE.-ISOSAC)
     *                        FACI1P=DSMALH(ISOSAC,LSOSAC-2,KSOSAC,
     *                                   XBT_PN(L),NEWWIG,ISWIND,NUANGU)
                           IF(LSOSAC+2.LE. ISOSAC)
     *                        FACI1M=DSMALH(ISOSAC,LSOSAC+2,KSOSAC,
     *                                   XBT_PN(L),NEWWIG,ISWIND,NUANGU)
                           IF(LSOSAC-4.GE.-ISOSAC)
     *                        FACI2P=DSMALH(ISOSAC,LSOSAC-4,KSOSAC,
     *                                   XBT_PN(L),NEWWIG,ISWIND,NUANGU)
                           IF(LSOSAC+4.LE. ISOSAC)
     *                        FACI2M=DSMALH(ISOSAC,LSOSAC+4,KSOSAC,
     *                                   XBT_PN(L),NEWWIG,ISWIND,NUANGU)
C
                        ELSE
C
                           FACI1M=FACINT
                           FACI1P=FACINT
                           FACI2M=FACINT
                           FACI2P=FACINT
C
                        END IF
C
                        END IF
C
C=======================================================================
C            INTEGRATING THE NORM, ENERGY AND COULOMB KERNELS
C=======================================================================
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER                   TTER_T(INDISO,NUCOUT)=
C TER*                  TTER_T(INDISO,NUCOUT)+
C TER*                         FACINT*WTER_T(LSOSAC,KSOSAC,NUCOUT)
C TER        END DO
                        TKER_T(INDISO)=
     *                  TKER_T(INDISO)+
     *                         FACINT*WKER_T(LSOSAC,KSOSAC)
C
                        IF (NBTKNO.EQ.1) THEN
C
                            TKIN_N(INDISO)=
     *                      TKIN_N(INDISO)+
     *                             FACINT*WKIN_N(LSOSAC,KSOSAC)
                            TKIN_P(INDISO)=
     *                      TKIN_P(INDISO)+
     *                             FACINT*WKIN_P(LSOSAC,KSOSAC)
C
                            TPAI_N(INDISO)=
     *                      TPAI_N(INDISO)+
     *                             FACINT*WPAI_N(LSOSAC,KSOSAC)
                            TPAI_P(INDISO)=
     *                      TPAI_P(INDISO)+
     *                             FACINT*WPAI_P(LSOSAC,KSOSAC)
C
                        ELSE
C
                            TKIN_N(INDISO)=
     *                      TKIN_N(INDISO)+
     *                             FACINT*WKIN_N(LSOSAC,KSOSAC)
                            TKIN_P(INDISO)=
     *                      C_ZERO
C
                        END IF
C
                        TSKY_T(INDISO)=
     *                  TSKY_T(INDISO)+
     *                         FACINT*WSKY_T(LSOSAC,KSOSAC)
                        TCOU_D(INDISO)=
     *                  TCOU_D(INDISO)+
     *                         FACINT*WCOU_D(LSOSAC,KSOSAC)
                        TC10_D(INDISO)=
     *                  TC10_D(INDISO)+
     *                         FACINT*WC10_D(LSOSAC,KSOSAC)
                        TC1P_D(INDISO)=
     *                  TC1P_D(INDISO)+
     *                         FACI1P*WC1P_D(LSOSAC,KSOSAC)
                        TC1M_D(INDISO)=
     *                  TC1M_D(INDISO)+
     *                         FACI1M*WC1M_D(LSOSAC,KSOSAC)
                        TC20_D(INDISO)=
     *                  TC20_D(INDISO)+
     *                         FACINT*WC20_D(LSOSAC,KSOSAC)
                        TC21PD(INDISO)=
     *                  TC21PD(INDISO)+
     *                         FACI1P*WC21PD(LSOSAC,KSOSAC)
                        TC21MD(INDISO)=
     *                  TC21MD(INDISO)+
     *                         FACI1M*WC21MD(LSOSAC,KSOSAC)
                        TC22PD(INDISO)=
     *                  TC22PD(INDISO)+
     *                         FACI2P*WC22PD(LSOSAC,KSOSAC)
                        TC22MD(INDISO)=
     *                  TC22MD(INDISO)+
     *                         FACI2M*WC22MD(LSOSAC,KSOSAC)
C
                        TCOU_X(INDISO)=
     *                  TCOU_X(INDISO)+
     *                         FACINT*WCOU_X(LSOSAC,KSOSAC)
                        TC10_X(INDISO)=
     *                  TC10_X(INDISO)+
     *                         FACINT*WC10_X(LSOSAC,KSOSAC)
                        TC1P_X(INDISO)=
     *                  TC1P_X(INDISO)+
     *                         FACI1P*WC1P_X(LSOSAC,KSOSAC)
                        TC1M_X(INDISO)=
     *                  TC1M_X(INDISO)+
     *                         FACI1M*WC1M_X(LSOSAC,KSOSAC)
                        TC20_X(INDISO)=
     *                  TC20_X(INDISO)+
     *                         FACINT*WC20_X(LSOSAC,KSOSAC)
                        TC21PX(INDISO)=
     *                  TC21PX(INDISO)+
     *                         FACI1P*WC21PX(LSOSAC,KSOSAC)
                        TC21MX(INDISO)=
     *                  TC21MX(INDISO)+
     *                         FACI1M*WC21MX(LSOSAC,KSOSAC)
                        TC22PX(INDISO)=
     *                  TC22PX(INDISO)+
     *                         FACI2P*WC22PX(LSOSAC,KSOSAC)
                        TC22MX(INDISO)=
     *                  TC22MX(INDISO)+
     *                         FACI2M*WC22MX(LSOSAC,KSOSAC)
C
                        TPNU00(INDISO)=
     *                  TPNU00(INDISO)+
     *                         FACINT*WPNU00(LSOSAC,KSOSAC)
                        TPNU10(INDISO)=
     *                  TPNU10(INDISO)+
     *                         FACINT*WPNU10(LSOSAC,KSOSAC)
                        TPNU1P(INDISO)=
     *                  TPNU1P(INDISO)+
     *                         FACI1P*WPNU1P(LSOSAC,KSOSAC)
                        TPNU1M(INDISO)=
     *                  TPNU1M(INDISO)+
     *                         FACI1M*WPNU1M(LSOSAC,KSOSAC)
C
                        TTZISO(INDISO)=
     *                  TTZISO(INDISO)+
     *                         FACINT*WTZISO(LSOSAC,KSOSAC)
                        TT2ISO(INDISO)=
     *                  TT2ISO(INDISO)+
     *                         FACINT*WT2ISO(LSOSAC,KSOSAC)
C
                        TBZROT(INDISO)=
     *                  TBZROT(INDISO)+
     *                         FACINT*WBZROT(LSOSAC,KSOSAC)
                        TB2ROT(INDISO)=
     *                  TB2ROT(INDISO)+
     *                         FACINT*WB2ROT(LSOSAC,KSOSAC)
C
C=======================================================================
C        HERE END THE LOOPS OVER BETA_T ISOSPIN GAUSS KNOTS AND THE
C        ISOSPIN QUANTUM NUMBERS ISOSAC,KSOSAC,LSOSAC
C=======================================================================
C
C                    END DO
C                 END DO
               END DO
            END DO
C
            DO INDISO=1,NUISOM
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER          TETERN(I,J,K,INDISO,NUCOUT)=TTER_T(INDISO,NUCOUT)
C TER        END DO
               OVTERN(I,J,K,INDISO)=TKER_T(INDISO)
               SKTERN(I,J,K,INDISO)=TSKY_T(INDISO)
C
               IF (NBTKNO.EQ.1) THEN
                   EKTERN(I,J,K,0)=TKIN_N(INDISO)
                   EKTERN(I,J,K,1)=TKIN_P(INDISO)
C
                   EPTERN(I,J,K,0)=TPAI_N(INDISO)
                   EPTERN(I,J,K,1)=TPAI_P(INDISO)
C
               ELSE
                   EKTERN(I,J,K,INDISO)=TKIN_N(INDISO)
               END IF
C
               CDTERN(I,J,K,INDISO)=TCOU_D(INDISO)
               CDTE10(I,J,K,INDISO)=TC10_D(INDISO)
               CDTE1P(I,J,K,INDISO)=TC1P_D(INDISO)
               CDTE1M(I,J,K,INDISO)=TC1M_D(INDISO)
               CDTE20(I,J,K,INDISO)=TC20_D(INDISO)
               CDT21P(I,J,K,INDISO)=TC21PD(INDISO)
               CDT21M(I,J,K,INDISO)=TC21MD(INDISO)
               CDT22P(I,J,K,INDISO)=TC22PD(INDISO)
               CDT22M(I,J,K,INDISO)=TC22MD(INDISO)
C
               CXTERN(I,J,K,INDISO)=TCOU_X(INDISO)
               CXTE10(I,J,K,INDISO)=TC10_X(INDISO)
               CXTE1P(I,J,K,INDISO)=TC1P_X(INDISO)
               CXTE1M(I,J,K,INDISO)=TC1M_X(INDISO)
               CXTE20(I,J,K,INDISO)=TC20_X(INDISO)
               CXT21P(I,J,K,INDISO)=TC21PX(INDISO)
               CXT21M(I,J,K,INDISO)=TC21MX(INDISO)
               CXT22P(I,J,K,INDISO)=TC22PX(INDISO)
               CXT22M(I,J,K,INDISO)=TC22MX(INDISO)
C
               PNTE00(I,J,K,INDISO)=TPNU00(INDISO)
               PNTE10(I,J,K,INDISO)=TPNU10(INDISO)
               PNTE1P(I,J,K,INDISO)=TPNU1P(INDISO)
               PNTE1M(I,J,K,INDISO)=TPNU1M(INDISO)
C
               TZTERN(I,J,K,INDISO)=TTZISO(INDISO)
               T2TERN(I,J,K,INDISO)=TT2ISO(INDISO)
C
               BZTERN(I,J,K,INDISO)=TBZROT(INDISO)
               B2TERN(I,J,K,INDISO)=TB2ROT(INDISO)
C
            END DO
C
          END DO
        END DO
      END DO
C
C=======================================================================
C         ALLOCATING ARRAYS FOR INTEGRATION OVER THE ISOSPIN EULR ANGLES
C=======================================================================
C
      ALLOCATE (ZKER_T(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZKER_T','PROANG')
      ALLOCATE (ZSKY_T(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZSKY_T','PROANG')
      ALLOCATE (ZKIN_N(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZKIN_N','PROANG')
      ALLOCATE (ZKIN_P(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZKIN_P','PROANG')
      ALLOCATE (ZPAI_N(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZPAI_N','PROANG')
      ALLOCATE (ZPAI_P(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZPAI_P','PROANG')
      ALLOCATE (ZCOU_D(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZCOU_D','PROANG')
      ALLOCATE (ZC10_D(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC10_D','PROANG')
      ALLOCATE (ZC1P_D(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC1P_D','PROANG')
      ALLOCATE (ZC1M_D(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC1M_D','PROANG')
      ALLOCATE (ZC20_D(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC20_D','PROANG')
      ALLOCATE (ZC21PD(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC21PD','PROANG')
      ALLOCATE (ZC21MD(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC21MD','PROANG')
      ALLOCATE (ZC22PD(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC22PD','PROANG')
      ALLOCATE (ZC22MD(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC22MD','PROANG')
      ALLOCATE (ZCOU_X(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZCOU_X','PROANG')
      ALLOCATE (ZC10_X(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC10_X','PROANG')
      ALLOCATE (ZC1P_X(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC1P_X','PROANG')
      ALLOCATE (ZC1M_X(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC1M_X','PROANG')
      ALLOCATE (ZC20_X(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC20_X','PROANG')
      ALLOCATE (ZC21PX(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC21PX','PROANG')
      ALLOCATE (ZC21MX(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC21MX','PROANG')
      ALLOCATE (ZC22PX(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC22PX','PROANG')
      ALLOCATE (ZC22MX(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZC22MX','PROANG')
      ALLOCATE (ZPNU00(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZPNU00','PROANG')
      ALLOCATE (ZPNU10(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZPNU10','PROANG')
      ALLOCATE (ZPNU1P(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZPNU1P','PROANG')
      ALLOCATE (ZPNU1M(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZPNU1M','PROANG')
      ALLOCATE (ZTZISO(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZTZISO','PROANG')
      ALLOCATE (ZT2ISO(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZT2ISO','PROANG')
      ALLOCATE (ZBZROT(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZBZROT','PROANG')
      ALLOCATE (ZB2ROT(1:NDAKNO,-NDPROI:NDPROI,1:NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('ZB2ROT','PROANG')
C
C=======================================================================
C           ALLOCATING ARRAYS FOR KERNEL INTEGRATION
C=======================================================================
C
C=======================================================================
C TER ALLOCATE (CTER_T(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM,2*NDCOUT),
C TER*                                          STAT=IALLOC)
C TER IF (IALLOC.NE.0) CALL NOALLO('CTER_T','PROANG')
      ALLOCATE (CKER_T(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CKER_T','PROANG')
      ALLOCATE (CSKY_T(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CSKY_T','PROANG')
      ALLOCATE (CKIN_N(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CKIN_N','PROANG')
      ALLOCATE (CKIN_P(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CKIN_P','PROANG')
C=======================================================================
C FOR PAIRING
      ALLOCATE (CPAI_N(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CPAI_N','PROANG')
      ALLOCATE (CPAI_P(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CPAI_P','PROANG')
C=======================================================================
      ALLOCATE (CCOU_D(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CCOU_D','PROANG')
      ALLOCATE (CC10_D(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC10_D','PROANG')
      ALLOCATE (CC1P_D(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC1P_D','PROANG')
      ALLOCATE (CC1M_D(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC1M_D','PROANG')
      ALLOCATE (CC20_D(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC20_D','PROANG')
      ALLOCATE (CC21PD(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC21PD','PROANG')
      ALLOCATE (CC21MD(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC21MD','PROANG')
      ALLOCATE (CC22PD(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC22PD','PROANG')
      ALLOCATE (CC22MD(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC22MD','PROANG')
      ALLOCATE (CCOU_X(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CCOU_X','PROANG')
      ALLOCATE (CC10_X(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC10_X','PROANG')
      ALLOCATE (CC1P_X(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC1P_X','PROANG')
      ALLOCATE (CC1M_X(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC1M_X','PROANG')
      ALLOCATE (CC20_X(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC20_X','PROANG')
      ALLOCATE (CC21PX(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC21PX','PROANG')
      ALLOCATE (CC21MX(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC21MX','PROANG')
      ALLOCATE (CC22PX(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC22PX','PROANG')
      ALLOCATE (CC22MX(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CC22MX','PROANG')
      ALLOCATE (CPNU00(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CPNU00','PROANG')
      ALLOCATE (CPNU10(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CPNU10','PROANG')
      ALLOCATE (CPNU1P(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CPNU1P','PROANG')
      ALLOCATE (CPNU1M(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CPNU1M','PROANG')
      ALLOCATE (CTZISO(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CTZISO','PROANG')
      ALLOCATE (CT2ISO(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CT2ISO','PROANG')
      ALLOCATE (CBZROT(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CBZROT','PROANG')
      ALLOCATE (CB2ROT(-NDPROI:NDPROI,-NDPROI:NDPROI,1:NUISOM),
     *                                          STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CB2ROT','PROANG')
C
C=======================================================================
C
      DO J=1,NUBKNO
C
      DO INDISO=1,NUISOM
C
        DO I=1,NUAKNO
C
          DO KPROAC=-JPROMA,JPROMA,2
C
C=======================================================================
C         ZEROING AUXILIARY ARRAYS OF OVERLAP AND ENERGY KERNELS
C=======================================================================
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER        ZTER_T(I,KPROAC,INDISO,NUCOUT)=C_ZERO
C TER        END DO
             ZKER_T(I,KPROAC,INDISO)=C_ZERO
C
             ZSKY_T(I,KPROAC,INDISO)=C_ZERO
             ZKIN_N(I,KPROAC,INDISO)=C_ZERO
             ZKIN_P(I,KPROAC,INDISO)=C_ZERO
C
             ZPAI_N(I,KPROAC,INDISO)=C_ZERO
             ZPAI_P(I,KPROAC,INDISO)=C_ZERO
C
             ZCOU_D(I,KPROAC,INDISO)=C_ZERO
             ZC10_D(I,KPROAC,INDISO)=C_ZERO
             ZC1P_D(I,KPROAC,INDISO)=C_ZERO
             ZC1M_D(I,KPROAC,INDISO)=C_ZERO
             ZC20_D(I,KPROAC,INDISO)=C_ZERO
             ZC21PD(I,KPROAC,INDISO)=C_ZERO
             ZC21MD(I,KPROAC,INDISO)=C_ZERO
             ZC22PD(I,KPROAC,INDISO)=C_ZERO
             ZC22MD(I,KPROAC,INDISO)=C_ZERO
C
             ZCOU_X(I,KPROAC,INDISO)=C_ZERO
             ZC10_X(I,KPROAC,INDISO)=C_ZERO
             ZC1P_X(I,KPROAC,INDISO)=C_ZERO
             ZC1M_X(I,KPROAC,INDISO)=C_ZERO
             ZC20_X(I,KPROAC,INDISO)=C_ZERO
             ZC21PX(I,KPROAC,INDISO)=C_ZERO
             ZC21MX(I,KPROAC,INDISO)=C_ZERO
             ZC22PX(I,KPROAC,INDISO)=C_ZERO
             ZC22MX(I,KPROAC,INDISO)=C_ZERO
C
             ZPNU00(I,KPROAC,INDISO)=C_ZERO
             ZPNU10(I,KPROAC,INDISO)=C_ZERO
             ZPNU1P(I,KPROAC,INDISO)=C_ZERO
             ZPNU1M(I,KPROAC,INDISO)=C_ZERO
C
             ZTZISO(I,KPROAC,INDISO)=C_ZERO
             ZT2ISO(I,KPROAC,INDISO)=C_ZERO
C
             ZBZROT(I,KPROAC,INDISO)=C_ZERO
             ZB2ROT(I,KPROAC,INDISO)=C_ZERO
C
C=======================================================================
C         ZEROING AUXILIARY ARRAYS OF MULTIPOLE, MAGNETIC, SPIN-ASY, AND
C         SURFACE OR SCHIFF MOMENTS. THESE ARRAYS WILL BE USED ONLY WHEN
C         THERE IS NO PROJECTION ON THE ISOSPIN
C=======================================================================
C
             IF (NBTKNO.EQ.1) THEN
C
                 DO LAMBDA=0,NDMULR
                    DO MIU=-LAMBDA,LAMBDA
C
                      ZMUL_P(I,KPROAC,IND_LM(LAMBDA,MIU))  =C_ZERO
                      ZMAG_T(I,KPROAC,IND_LM(LAMBDA,MIU),:)=C_ZERO
                      ZSIF_P(I,KPROAC,IND_LM(LAMBDA,MIU))  =C_ZERO
                      IF (NASORD.GE.0)
     *                ZASM_T(I,KPROAC,IND_LM(LAMBDA,MIU),:)=C_ZERO
C
                    END DO
                 END DO
C
             END IF
C
C=======================================================================
C         BELOW WE INTEGRATE KERNELS OVER THE GAMMA EULER ANGLE AND
C         AT THE SAME TIME WE MULTIPLY THEM BY THE  GAUSS  WEIGHTS
C=======================================================================
C
              DO K=1,NUAKNO
C
                 GAMM_K=XA_PNT(K)*0.5D0*KPROAC
C
                 FACINT=XA_WGT(K)*(COS(GAMM_K)+UNIT_I*SIN(GAMM_K))
C
C=======================================================================
C                    INTEGRATING THE NORM KERNEL
C=======================================================================
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER      ZTER_T(I,KPROAC,INDISO,NUCOUT)=ZTER_T(I,KPROAC,INDISO,NUCOUT)
C TER*                               +FACINT*TETERN(I,J,K,INDISO,NUCOUT)
C TER        END DO
                 ZKER_T(I,KPROAC,INDISO)=ZKER_T(I,KPROAC,INDISO)
     *                              +FACINT*OVTERN(I,J,K,INDISO)
C
C=======================================================================
C                    INTEGRATING THE ENERGY KERNELS
C=======================================================================
C
                 ZSKY_T(I,KPROAC,INDISO)=ZSKY_T(I,KPROAC,INDISO)
     *                              +FACINT*SKTERN(I,J,K,INDISO)
C
                 IF (NBTKNO.EQ.1) THEN
                     ZKIN_N(I,KPROAC,INDISO)=ZKIN_N(I,KPROAC,INDISO)
     *                               +FACINT*EKTERN(I,J,K,0)
                     ZKIN_P(I,KPROAC,INDISO)=ZKIN_P(I,KPROAC,INDISO)
     *                               +FACINT*EKTERN(I,J,K,1)
C
                     ZPAI_N(I,KPROAC,INDISO)=ZPAI_N(I,KPROAC,INDISO)
     *                               +FACINT*EPTERN(I,J,K,0)
                     ZPAI_P(I,KPROAC,INDISO)=ZPAI_P(I,KPROAC,INDISO)
     *                               +FACINT*EPTERN(I,J,K,1)
C
                 ELSE
                     ZKIN_N(I,KPROAC,INDISO)=ZKIN_N(I,KPROAC,INDISO)
     *                                  +FACINT*EKTERN(I,J,K,INDISO)
                     ZKIN_P(I,KPROAC,INDISO)=C_ZERO
                 END IF
C
                 ZCOU_D(I,KPROAC,INDISO)=ZCOU_D(I,KPROAC,INDISO)
     *                              +FACINT*CDTERN(I,J,K,INDISO)
                 ZC10_D(I,KPROAC,INDISO)=ZC10_D(I,KPROAC,INDISO)
     *                              +FACINT*CDTE10(I,J,K,INDISO)
                 ZC1P_D(I,KPROAC,INDISO)=ZC1P_D(I,KPROAC,INDISO)
     *                              +FACINT*CDTE1P(I,J,K,INDISO)
                 ZC1M_D(I,KPROAC,INDISO)=ZC1M_D(I,KPROAC,INDISO)
     *                              +FACINT*CDTE1M(I,J,K,INDISO)
                 ZC20_D(I,KPROAC,INDISO)=ZC20_D(I,KPROAC,INDISO)
     *                              +FACINT*CDTE20(I,J,K,INDISO)
                 ZC21PD(I,KPROAC,INDISO)=ZC21PD(I,KPROAC,INDISO)
     *                              +FACINT*CDT21P(I,J,K,INDISO)
                 ZC21MD(I,KPROAC,INDISO)=ZC21MD(I,KPROAC,INDISO)
     *                              +FACINT*CDT21M(I,J,K,INDISO)
                 ZC22PD(I,KPROAC,INDISO)=ZC22PD(I,KPROAC,INDISO)
     *                              +FACINT*CDT22P(I,J,K,INDISO)
                 ZC22MD(I,KPROAC,INDISO)=ZC22MD(I,KPROAC,INDISO)
     *                              +FACINT*CDT22M(I,J,K,INDISO)
C
                 ZCOU_X(I,KPROAC,INDISO)=ZCOU_X(I,KPROAC,INDISO)
     *                              +FACINT*CXTERN(I,J,K,INDISO)
                 ZC10_X(I,KPROAC,INDISO)=ZC10_X(I,KPROAC,INDISO)
     *                              +FACINT*CXTE10(I,J,K,INDISO)
                 ZC1P_X(I,KPROAC,INDISO)=ZC1P_X(I,KPROAC,INDISO)
     *                              +FACINT*CXTE1P(I,J,K,INDISO)
                 ZC1M_X(I,KPROAC,INDISO)=ZC1M_X(I,KPROAC,INDISO)
     *                              +FACINT*CXTE1M(I,J,K,INDISO)
                 ZC20_X(I,KPROAC,INDISO)=ZC20_X(I,KPROAC,INDISO)
     *                              +FACINT*CXTE20(I,J,K,INDISO)
                 ZC21PX(I,KPROAC,INDISO)=ZC21PX(I,KPROAC,INDISO)
     *                              +FACINT*CXT21P(I,J,K,INDISO)
                 ZC21MX(I,KPROAC,INDISO)=ZC21MX(I,KPROAC,INDISO)
     *                              +FACINT*CXT21M(I,J,K,INDISO)
                 ZC22PX(I,KPROAC,INDISO)=ZC22PX(I,KPROAC,INDISO)
     *                              +FACINT*CXT22P(I,J,K,INDISO)
                 ZC22MX(I,KPROAC,INDISO)=ZC22MX(I,KPROAC,INDISO)
     *                              +FACINT*CXT22M(I,J,K,INDISO)
C
                 ZPNU00(I,KPROAC,INDISO)=ZPNU00(I,KPROAC,INDISO)
     *                              +FACINT*PNTE00(I,J,K,INDISO)
                 ZPNU10(I,KPROAC,INDISO)=ZPNU10(I,KPROAC,INDISO)
     *                              +FACINT*PNTE10(I,J,K,INDISO)
                 ZPNU1P(I,KPROAC,INDISO)=ZPNU1P(I,KPROAC,INDISO)
     *                              +FACINT*PNTE1P(I,J,K,INDISO)
                 ZPNU1M(I,KPROAC,INDISO)=ZPNU1M(I,KPROAC,INDISO)
     *                              +FACINT*PNTE1M(I,J,K,INDISO)
C
                 ZTZISO(I,KPROAC,INDISO)=ZTZISO(I,KPROAC,INDISO)
     *                              +FACINT*TZTERN(I,J,K,INDISO)
                 ZT2ISO(I,KPROAC,INDISO)=ZT2ISO(I,KPROAC,INDISO)
     *                              +FACINT*T2TERN(I,J,K,INDISO)
C
                 ZBZROT(I,KPROAC,INDISO)=ZBZROT(I,KPROAC,INDISO)
     *                              +FACINT*BZTERN(I,J,K,INDISO)
                 ZB2ROT(I,KPROAC,INDISO)=ZB2ROT(I,KPROAC,INDISO)
     *                              +FACINT*B2TERN(I,J,K,INDISO)
C
                 IF (NBTKNO.EQ.1) THEN
C
                            FACMOM=OVKERN(I,J,K,1,1,1)*4.0D0*PI*PI
C
C=======================================================================
C             INTEGRATING THE KERNELS OF THE MULTIPOLE MOMENTS
C=======================================================================
C
                     DO LAMBDA=0,NMURED
                        DO MIU=-LAMBDA,LAMBDA
C
                        ZMUL_P(I,KPROAC,IND_LM(LAMBDA,MIU))=
     *                  ZMUL_P(I,KPROAC,IND_LM(LAMBDA,MIU))
     *                                                    +FACINT*FACMOM
     *                                 *QPKERN(I,J,K,IND_LM(LAMBDA,MIU))
C
                        END DO
                     END DO
C
C=======================================================================
C                    INTEGRATING THE KERNELS OF THE MAGNETIC MOMENTS
C=======================================================================
C
                     DO LAMBDA=1,NMARED
                        DO MIU=-LAMBDA,LAMBDA
                           ZMAG_T(I,KPROAC,IND_LM(LAMBDA,MIU),:)=
     *                     ZMAG_T(I,KPROAC,IND_LM(LAMBDA,MIU),:)
     *                                                    +FACINT*FACMOM
     *                       *ATKERN(I,J,K,IND_LM(LAMBDA,MIU),:)
C
C     WRITE (*,'(3I4,I5,I5,I3,4(3X,2D15.7))')
C    *               I,J,K,KPROAC,LAMBDA,MIU,
C    *               FACINT,FACMOM,FACINT*FACMOM,
C    *               ATKERN(I,J,K,IND_LM(LAMBDA,MIU),0)
C
                        END DO
                     END DO
C
C=======================================================================
C                    INTEGRATING THE KERNELS OF THE SPIN-ASYMM. MOMENTS
C=======================================================================
C
                     IF (NASORD.GE.0) THEN
C
                         DO LAMBDA=1,NASRED
                            DO MIU=-LAMBDA,LAMBDA
                               ZASM_T(I,KPROAC,IND_LM(LAMBDA,MIU),:)=
     *                         ZASM_T(I,KPROAC,IND_LM(LAMBDA,MIU),:)
     *                                                    +FACINT*FACMOM
     *                           *WTKERN(I,J,K,IND_LM(LAMBDA,MIU),:)
C
                            END DO
                         END DO
C
                     END IF
C
C=======================================================================
C                    INTEGRATING THE KERNELS OF THE SURFACE OR SCHIFF
C                    MOMENTS
C=======================================================================
C
                     DO LAMBDA=NSIMIN,NSIRED
                        DO MIU=-LAMBDA,LAMBDA
C
                        ZSIF_P(I,KPROAC,IND_LM(LAMBDA,MIU))=
     *                  ZSIF_P(I,KPROAC,IND_LM(LAMBDA,MIU))
     *                                                    +FACINT*FACMOM
     *                                 *SPKERN(I,J,K,IND_LM(LAMBDA,MIU))
C
                        END DO
                     END DO
C
                 END IF
C
C=======================================================================
C           HERE END THE LOOPS  OVER THE  GAMMA  GAUSS  KNOTS
C         AND THE LOOP OVER THE K PROJECTION ON THE INTRINSIC AXIS
C=======================================================================
C
              END DO
           END DO
C
C=======================================================================
C           HERE END THE LOOPS  OVER THE  ALPHA  GAUSS  KNOTS
C=======================================================================
C
        END DO
C
C=======================================================================
C         HERE STARTS THE LOOP OVER THE K' PROJECTION ON THE INTRINSIC
C         AXIS; INDEX "LPROAC", AND OVER THE K PROJECTION ON THE
C         INTRINSIC AXIS; INDEX "KPROAC".
C=======================================================================
C
        DO LPROAC=-JPROMA,JPROMA,2
C
           DO KPROAC=-JPROMA,JPROMA,2
C
C=======================================================================
C         ZEROING AUXILIARY ARRAYS OF OVERLAP AND ENERGY KERNELS
C=======================================================================
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER         CTER_T(LPROAC,KPROAC,INDISO,NUCOUT)=C_ZERO
C TER        END DO
              CKER_T(LPROAC,KPROAC,INDISO)=C_ZERO
C
              CSKY_T(LPROAC,KPROAC,INDISO)=C_ZERO
              CKIN_N(LPROAC,KPROAC,INDISO)=C_ZERO
              CKIN_P(LPROAC,KPROAC,INDISO)=C_ZERO
C
              CPAI_N(LPROAC,KPROAC,INDISO)=C_ZERO
              CPAI_P(LPROAC,KPROAC,INDISO)=C_ZERO
C
              CCOU_D(LPROAC,KPROAC,INDISO)=C_ZERO
              CC10_D(LPROAC,KPROAC,INDISO)=C_ZERO
              CC1P_D(LPROAC,KPROAC,INDISO)=C_ZERO
              CC1M_D(LPROAC,KPROAC,INDISO)=C_ZERO
              CC20_D(LPROAC,KPROAC,INDISO)=C_ZERO
              CC21PD(LPROAC,KPROAC,INDISO)=C_ZERO
              CC21MD(LPROAC,KPROAC,INDISO)=C_ZERO
              CC22PD(LPROAC,KPROAC,INDISO)=C_ZERO
              CC22MD(LPROAC,KPROAC,INDISO)=C_ZERO
C
              CCOU_X(LPROAC,KPROAC,INDISO)=C_ZERO
              CC10_X(LPROAC,KPROAC,INDISO)=C_ZERO
              CC1P_X(LPROAC,KPROAC,INDISO)=C_ZERO
              CC1M_X(LPROAC,KPROAC,INDISO)=C_ZERO
              CC20_X(LPROAC,KPROAC,INDISO)=C_ZERO
              CC21PX(LPROAC,KPROAC,INDISO)=C_ZERO
              CC21MX(LPROAC,KPROAC,INDISO)=C_ZERO
              CC22PX(LPROAC,KPROAC,INDISO)=C_ZERO
              CC22MX(LPROAC,KPROAC,INDISO)=C_ZERO
C
              CPNU00(LPROAC,KPROAC,INDISO)=C_ZERO
              CPNU10(LPROAC,KPROAC,INDISO)=C_ZERO
              CPNU1P(LPROAC,KPROAC,INDISO)=C_ZERO
              CPNU1M(LPROAC,KPROAC,INDISO)=C_ZERO
C
              CTZISO(LPROAC,KPROAC,INDISO)=C_ZERO
              CT2ISO(LPROAC,KPROAC,INDISO)=C_ZERO
C
              CBZROT(LPROAC,KPROAC,INDISO)=C_ZERO
              CB2ROT(LPROAC,KPROAC,INDISO)=C_ZERO
C
C=======================================================================
C         ZEROING AUXILIARY ARRAYS OF MULTIPOLE, MAGNETIC, SPIN-ASY, AND
C         SURFACE MOMENTS
C=======================================================================
C
              IF (NBTKNO.EQ.1) THEN
C
                  DO LAMBDA=0,NDMULR
                     DO MIU=-LAMBDA,LAMBDA
C
                       CMUL_P(LPROAC,KPROAC,IND_LM(LAMBDA,MIU))  =C_ZERO
                       CMAG_T(LPROAC,KPROAC,IND_LM(LAMBDA,MIU),:)=C_ZERO
                       CSIF_P(LPROAC,KPROAC,IND_LM(LAMBDA,MIU))  =C_ZERO
                       IF (NASORD.GE.0)
     *                 CASM_T(LPROAC,KPROAC,IND_LM(LAMBDA,MIU),:)=C_ZERO
C
                     END DO
                  END DO
C
              END IF
C
C=======================================================================
C         HERE WE INTEGRATE THE KERNELS OVER THE ALPHA EULER ANGLE
C=======================================================================
C
              DO I=1,NUAKNO
C
                 ALPH_L=XA_PNT(I)*0.5D0*LPROAC
                 FACINT=XA_WGT(I)*(COS(ALPH_L)+UNIT_I*SIN(ALPH_L))
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER            CTER_T(LPROAC,KPROAC,INDISO,NUCOUT)=
C TER*           CTER_T(LPROAC,KPROAC,INDISO,NUCOUT)
C TER*                            +FACINT*ZTER_T(I,KPROAC,INDISO,NUCOUT)
C TER        END DO
                 CKER_T(LPROAC,KPROAC,INDISO)=
     *           CKER_T(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZKER_T(I,KPROAC,INDISO)
C
                 CSKY_T(LPROAC,KPROAC,INDISO)=
     *           CSKY_T(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZSKY_T(I,KPROAC,INDISO)
                 CKIN_N(LPROAC,KPROAC,INDISO)=
     *           CKIN_N(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZKIN_N(I,KPROAC,INDISO)
                 CKIN_P(LPROAC,KPROAC,INDISO)=
     *           CKIN_P(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZKIN_P(I,KPROAC,INDISO)
C
                 CPAI_N(LPROAC,KPROAC,INDISO)=
     *           CPAI_N(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZPAI_N(I,KPROAC,INDISO)
                 CPAI_P(LPROAC,KPROAC,INDISO)=
     *           CPAI_P(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZPAI_P(I,KPROAC,INDISO)
C
                 CCOU_D(LPROAC,KPROAC,INDISO)=
     *           CCOU_D(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZCOU_D(I,KPROAC,INDISO)
                 CC10_D(LPROAC,KPROAC,INDISO)=
     *           CC10_D(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC10_D(I,KPROAC,INDISO)
                 CC1P_D(LPROAC,KPROAC,INDISO)=
     *           CC1P_D(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC1P_D(I,KPROAC,INDISO)
                 CC1M_D(LPROAC,KPROAC,INDISO)=
     *           CC1M_D(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC1M_D(I,KPROAC,INDISO)
                 CC20_D(LPROAC,KPROAC,INDISO)=
     *           CC20_D(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC20_D(I,KPROAC,INDISO)
                 CC21PD(LPROAC,KPROAC,INDISO)=
     *           CC21PD(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC21PD(I,KPROAC,INDISO)
                 CC21MD(LPROAC,KPROAC,INDISO)=
     *           CC21MD(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC21MD(I,KPROAC,INDISO)
                 CC22PD(LPROAC,KPROAC,INDISO)=
     *           CC22PD(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC22PD(I,KPROAC,INDISO)
                 CC22MD(LPROAC,KPROAC,INDISO)=
     *           CC22MD(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC22MD(I,KPROAC,INDISO)
C
                 CCOU_X(LPROAC,KPROAC,INDISO)=
     *           CCOU_X(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZCOU_X(I,KPROAC,INDISO)
                 CC10_X(LPROAC,KPROAC,INDISO)=
     *           CC10_X(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC10_X(I,KPROAC,INDISO)
                 CC1P_X(LPROAC,KPROAC,INDISO)=
     *           CC1P_X(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC1P_X(I,KPROAC,INDISO)
                 CC1M_X(LPROAC,KPROAC,INDISO)=
     *           CC1M_X(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC1M_X(I,KPROAC,INDISO)
                 CC20_X(LPROAC,KPROAC,INDISO)=
     *           CC20_X(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC20_X(I,KPROAC,INDISO)
                 CC21PX(LPROAC,KPROAC,INDISO)=
     *           CC21PX(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC21PX(I,KPROAC,INDISO)
                 CC21MX(LPROAC,KPROAC,INDISO)=
     *           CC21MX(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC21MX(I,KPROAC,INDISO)
                 CC22PX(LPROAC,KPROAC,INDISO)=
     *           CC22PX(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC22PX(I,KPROAC,INDISO)
                 CC22MX(LPROAC,KPROAC,INDISO)=
     *           CC22MX(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZC22MX(I,KPROAC,INDISO)
C
                 CPNU00(LPROAC,KPROAC,INDISO)=
     *           CPNU00(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZPNU00(I,KPROAC,INDISO)
                 CPNU10(LPROAC,KPROAC,INDISO)=
     *           CPNU10(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZPNU10(I,KPROAC,INDISO)
                 CPNU1P(LPROAC,KPROAC,INDISO)=
     *           CPNU1P(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZPNU1P(I,KPROAC,INDISO)
                 CPNU1M(LPROAC,KPROAC,INDISO)=
     *           CPNU1M(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZPNU1M(I,KPROAC,INDISO)
C
                 CTZISO(LPROAC,KPROAC,INDISO)=
     *           CTZISO(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZTZISO(I,KPROAC,INDISO)
                 CT2ISO(LPROAC,KPROAC,INDISO)=
     *           CT2ISO(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZT2ISO(I,KPROAC,INDISO)
C
                 CBZROT(LPROAC,KPROAC,INDISO)=
     *           CBZROT(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZBZROT(I,KPROAC,INDISO)
                 CB2ROT(LPROAC,KPROAC,INDISO)=
     *           CB2ROT(LPROAC,KPROAC,INDISO)
     *                                 +FACINT*ZB2ROT(I,KPROAC,INDISO)
C
C=======================================================================
C                    INTEGRATING KERNELS OF THE MULTIPOLE MOMENTS
C=======================================================================
C
                 IF (NBTKNO.EQ.1) THEN
C
                     DO LAMBDA=0,NMURED
                        DO MIU=-LAMBDA,LAMBDA
C
                        CMUL_P(LPROAC,KPROAC,IND_LM(LAMBDA,MIU))=
     *                  CMUL_P(LPROAC,KPROAC,IND_LM(LAMBDA,MIU))
     *                      +FACINT*ZMUL_P(I,KPROAC,IND_LM(LAMBDA,MIU))
C
                        END DO
                     END DO
C
C=======================================================================
C                    INTEGRATING KERNELS OF THE MAGNETIC MOMENTS
C=======================================================================
C
                     DO LAMBDA=1,NMARED
                        DO MIU=-LAMBDA,LAMBDA
C
                           CMAG_T(LPROAC,KPROAC,IND_LM(LAMBDA,MIU),:)=
     *                     CMAG_T(LPROAC,KPROAC,IND_LM(LAMBDA,MIU),:)
     *                  +FACINT*ZMAG_T(I,KPROAC,IND_LM(LAMBDA,MIU),:)
C
                        END DO
                     END DO
C
C=======================================================================
C                    INTEGRATING KERNELS OF THE SPIN-ASYMMETRY MOMENTS
C=======================================================================
C
                     IF (NASORD.GE.0) THEN
C
                       DO LAMBDA=1,NASRED
                          DO MIU=-LAMBDA,LAMBDA
C
                             CASM_T(LPROAC,KPROAC,IND_LM(LAMBDA,MIU),:)=
     *                       CASM_T(LPROAC,KPROAC,IND_LM(LAMBDA,MIU),:)
     *                    +FACINT*ZASM_T(I,KPROAC,IND_LM(LAMBDA,MIU),:)
C
                          END DO
                       END DO
C
                     END IF
C
C=======================================================================
C                    INTEGRATING KERNELS OF THE SURFACE OR SCHIFF
C                    MOMENTS
C=======================================================================
C
                     DO LAMBDA=NSIMIN,NSIRED
                        DO MIU=-LAMBDA,LAMBDA
C
                        CSIF_P(LPROAC,KPROAC,IND_LM(LAMBDA,MIU))=
     *                  CSIF_P(LPROAC,KPROAC,IND_LM(LAMBDA,MIU))
     *                      +FACINT*ZSIF_P(I,KPROAC,IND_LM(LAMBDA,MIU))
C
                        END DO
                     END DO
C
                 END IF
C
C=======================================================================
C         HERE ENDS THE LOOP OVER THE ALPHA GAUSS KNOTS (I), THE
C         LOOPS OVER THE L AND K PROJECTIONS ON THE INTRINSIC AXIS
C=======================================================================
C
              END DO
C
           END DO
        END DO
C
C=======================================================================
C              HERE STARTS THE LOOP OVER THE ANGULAR MOMENTA
C                 AND FINAL INTEGRATION OVER BETA (J)
C=======================================================================
C
        DO INDPRO=1,NUPROM
C
           IPROAC=IROMAT(INDPRO)
           LPROAC=LROMAT(INDPRO)
           KPROAC=KROMAT(INDPRO)
C
           FACINT=XB_WGT(J)*DSMALH(IPROAC,LPROAC,KPROAC,
     *                                   XB_PNT(J),NEWWIG,ISWIND,NUANGU)
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER      TTE_TT(INDPRO,INDISO,NUCOUT)=TTE_TT(INDPRO,INDISO,NUCOUT)
C TER*                   +FACINT*CTER_T(LPROAC,KPROAC,INDISO,NUCOUT)
C TER        END DO
           TKE_TT(INDPRO,INDISO)=TKE_TT(INDPRO,INDISO)
     *            +FACINT*CKER_T(LPROAC,KPROAC,INDISO)
C
           TSK_TT(INDPRO,INDISO)=TSK_TT(INDPRO,INDISO)
     *            +FACINT*CSKY_T(LPROAC,KPROAC,INDISO)
           TKI_NT(INDPRO,INDISO)=TKI_NT(INDPRO,INDISO)
     *            +FACINT*CKIN_N(LPROAC,KPROAC,INDISO)
           TKI_PT(INDPRO,INDISO)=TKI_PT(INDPRO,INDISO)
     *            +FACINT*CKIN_P(LPROAC,KPROAC,INDISO)
C
           TPA_NT(INDPRO,INDISO)=TPA_NT(INDPRO,INDISO)
     *            +FACINT*CPAI_N(LPROAC,KPROAC,INDISO)
           TPA_PT(INDPRO,INDISO)=TPA_PT(INDPRO,INDISO)
     *            +FACINT*CPAI_P(LPROAC,KPROAC,INDISO)
C
           TCO_DT(INDPRO,INDISO)=TCO_DT(INDPRO,INDISO)
     *            +FACINT*CCOU_D(LPROAC,KPROAC,INDISO)
           TC1_D0(INDPRO,INDISO)=TC1_D0(INDPRO,INDISO)
     *            +FACINT*CC10_D(LPROAC,KPROAC,INDISO)
           TC1_DP(INDPRO,INDISO)=TC1_DP(INDPRO,INDISO)
     *            +FACINT*CC1P_D(LPROAC,KPROAC,INDISO)
           TC1_DM(INDPRO,INDISO)=TC1_DM(INDPRO,INDISO)
     *            +FACINT*CC1M_D(LPROAC,KPROAC,INDISO)
           TC2_D0(INDPRO,INDISO)=TC2_D0(INDPRO,INDISO)
     *            +FACINT*CC20_D(LPROAC,KPROAC,INDISO)
           TC21DP(INDPRO,INDISO)=TC21DP(INDPRO,INDISO)
     *            +FACINT*CC21PD(LPROAC,KPROAC,INDISO)
           TC21DM(INDPRO,INDISO)=TC21DM(INDPRO,INDISO)
     *            +FACINT*CC21MD(LPROAC,KPROAC,INDISO)
           TC22DP(INDPRO,INDISO)=TC22DP(INDPRO,INDISO)
     *            +FACINT*CC22PD(LPROAC,KPROAC,INDISO)
           TC22DM(INDPRO,INDISO)=TC22DM(INDPRO,INDISO)
     *            +FACINT*CC22MD(LPROAC,KPROAC,INDISO)
C
           TCO_XT(INDPRO,INDISO)=TCO_XT(INDPRO,INDISO)
     *            +FACINT*CCOU_X(LPROAC,KPROAC,INDISO)
           TC1_X0(INDPRO,INDISO)=TC1_X0(INDPRO,INDISO)
     *            +FACINT*CC10_X(LPROAC,KPROAC,INDISO)
           TC1_XP(INDPRO,INDISO)=TC1_XP(INDPRO,INDISO)
     *            +FACINT*CC1P_X(LPROAC,KPROAC,INDISO)
           TC1_XM(INDPRO,INDISO)=TC1_XM(INDPRO,INDISO)
     *            +FACINT*CC1M_X(LPROAC,KPROAC,INDISO)
           TC2_X0(INDPRO,INDISO)=TC2_X0(INDPRO,INDISO)
     *            +FACINT*CC20_X(LPROAC,KPROAC,INDISO)
           TC21XP(INDPRO,INDISO)=TC21XP(INDPRO,INDISO)
     *            +FACINT*CC21PX(LPROAC,KPROAC,INDISO)
           TC21XM(INDPRO,INDISO)=TC21XM(INDPRO,INDISO)
     *            +FACINT*CC21MX(LPROAC,KPROAC,INDISO)
           TC22XP(INDPRO,INDISO)=TC22XP(INDPRO,INDISO)
     *            +FACINT*CC22PX(LPROAC,KPROAC,INDISO)
           TC22XM(INDPRO,INDISO)=TC22XM(INDPRO,INDISO)
     *            +FACINT*CC22MX(LPROAC,KPROAC,INDISO)
C
           TPN_00(INDPRO,INDISO)=TPN_00(INDPRO,INDISO)
     *            +FACINT*CPNU00(LPROAC,KPROAC,INDISO)
           TPN_10(INDPRO,INDISO)=TPN_10(INDPRO,INDISO)
     *            +FACINT*CPNU10(LPROAC,KPROAC,INDISO)
           TPN_1P(INDPRO,INDISO)=TPN_1P(INDPRO,INDISO)
     *            +FACINT*CPNU1P(LPROAC,KPROAC,INDISO)
           TPN_1M(INDPRO,INDISO)=TPN_1M(INDPRO,INDISO)
     *            +FACINT*CPNU1M(LPROAC,KPROAC,INDISO)
C
           TTZ_IS(INDPRO,INDISO)=TTZ_IS(INDPRO,INDISO)
     *            +FACINT*CTZISO(LPROAC,KPROAC,INDISO)
           TT2_IS(INDPRO,INDISO)=TT2_IS(INDPRO,INDISO)
     *            +FACINT*CT2ISO(LPROAC,KPROAC,INDISO)
C
           TBZ_RO(INDPRO,INDISO)=TBZ_RO(INDPRO,INDISO)
     *            +FACINT*CBZROT(LPROAC,KPROAC,INDISO)
           TB2_RO(INDPRO,INDISO)=TB2_RO(INDPRO,INDISO)
     *            +FACINT*CB2ROT(LPROAC,KPROAC,INDISO)
C
C=======================================================================
C    HERE END THE FIRST LOOPS OVER THE ANGULAR MOMENTA AND PROJECTIONS
C=======================================================================
C
        END DO
C
C=======================================================================
C                    INTEGRATING KERNELS OF THE MULTIPOLE MOMENTS
C=======================================================================
C
        IF (NBTKNO.EQ.1.AND.(IKEPRI.EQ.1.OR.IRMPRI.EQ.1)) THEN
C
            DO IREPRO=1,NUPREM
C
               IPROAC=IREMAT(IREPRO)
               LPROAC=LREMAT(IREPRO)
               KPROAC=KREMAT(IREPRO)
C
               FACINT=XB_WGT(J)*DSMALH(IPROAC,LPROAC,KPROAC,
     *                                   XB_PNT(J),NEWWIG,ISWIND,NUANGU)
C
               DO LAMBDA=0,NMURED
                  DO MIU=-LAMBDA,LAMBDA
C
                     TMUL_P(IND_LM(LAMBDA,MIU),IREPRO)=
     *               TMUL_P(IND_LM(LAMBDA,MIU),IREPRO)
     *                  +FACINT*CMUL_P(LPROAC,KPROAC,IND_LM(LAMBDA,MIU))
C
                  END DO
               END DO
C
C=======================================================================
C                    INTEGRATING KERNELS OF THE MAGNETIC MOMENTS
C=======================================================================
C
               DO LAMBDA=1,NMARED
                  DO MIU=-LAMBDA,LAMBDA
C
                     TMAG_T(IND_LM(LAMBDA,MIU),IREPRO,:)=
     *               TMAG_T(IND_LM(LAMBDA,MIU),IREPRO,:)
     *                +FACINT*CMAG_T(LPROAC,KPROAC,IND_LM(LAMBDA,MIU),:)
C
                  END DO
               END DO
C
C=======================================================================
C                    INTEGRATING KERNELS OF THE SPIN-ASYMMETRY MOMENTS
C=======================================================================
C
               IF (NASORD.GE.0) THEN
C
                   DO LAMBDA=1,NASRED
                      DO MIU=-LAMBDA,LAMBDA
C
                         TASM_T(IND_LM(LAMBDA,MIU),IREPRO,:)=
     *                   TASM_T(IND_LM(LAMBDA,MIU),IREPRO,:)
     *                +FACINT*CASM_T(LPROAC,KPROAC,IND_LM(LAMBDA,MIU),:)
C
                      END DO
                   END DO
C
               END IF
C
C=======================================================================
C                    INTEGRATING KERNELS OF THE SURFACE OR SCHIFF
C                    MOMENTS
C=======================================================================
C
               DO LAMBDA=NSIMIN,NSIRED
                  DO MIU=-LAMBDA,LAMBDA
C
                     TSIF_P(IND_LM(LAMBDA,MIU),IREPRO)=
     *               TSIF_P(IND_LM(LAMBDA,MIU),IREPRO)
     *                  +FACINT*CSIF_P(LPROAC,KPROAC,IND_LM(LAMBDA,MIU))
C
                  END DO
               END DO
C
C=======================================================================
C    HERE END THE SECOND LOOPS OVER THE ANGULAR MOMENTA AND PROJECTIONS
C=======================================================================
C
           END DO
C
        END IF
C
C=======================================================================
C                  HERE ENDS THE INTERNAL LOOP OVER THE ISOSPIN
C=======================================================================
C
      END DO
C
C=======================================================================
C             HERE ENDS THE LOOP OVER THE BETA GAUSS KNOTS
C=======================================================================
C
      END DO
C
C=======================================================================
C         MULTIPLYING THE INTEGRATED KERNELS BY OVERALL FACTORS
C=======================================================================
C
      DO INDPRO=1,NUPROM
C
         IPROAC=IROMAT(INDPRO)
         LPROAC=LROMAT(INDPRO)
         KPROAC=KROMAT(INDPRO)
C
         IF (NUBKNO.EQ.1) THEN
             FACNOI=             1/( 4.0D0*PI*PI)
         ELSE
             FACNOI=(IPROAC+1.0D0)/( 8.0D0*PI*PI)
         END IF
C
C==================================================================
C                  INTERNAL LOOP OVER THE ISOSPIN
C==================================================================
C
         DO INDISO=1,NUISOM
C
            ISOSAC=ISOMAT(INDISO)
            LSOSAC=LSOMAT(INDISO)
            KSOSAC=KSOMAT(INDISO)
C
            IF (NBTKNO.EQ.1) THEN
                FACNOR=FACNOI               /(4.0D0*PI*PI)
            ELSE
                FACNOR=FACNOI*(ISOSAC+1.0D0)/(8.0D0*PI*PI)
            END IF
C
C TER        DO NUCOUT=1,2*NDCOUT
C TER       TTE_TT(INDPRO,INDISO,NUCOUT)=TTE_TT(INDPRO,INDISO,NUCOUT)
C TER*                           *FACNOR
C TER        END DO
            TKE_TT(INDPRO,INDISO)=
     *      TKE_TT(INDPRO,INDISO)*FACNOR
C
            TSK_TT(INDPRO,INDISO)=
     *      TSK_TT(INDPRO,INDISO)*FACNOR
            TKI_NT(INDPRO,INDISO)=
     *      TKI_NT(INDPRO,INDISO)*FACNOR
            TKI_PT(INDPRO,INDISO)=
     *      TKI_PT(INDPRO,INDISO)*FACNOR
C
            TPA_NT(INDPRO,INDISO)=
     *      TPA_NT(INDPRO,INDISO)*FACNOR
            TPA_PT(INDPRO,INDISO)=
     *      TPA_PT(INDPRO,INDISO)*FACNOR
C
            TCO_DT(INDPRO,INDISO)=
     *      TCO_DT(INDPRO,INDISO)*FACNOR
            TC1_D0(INDPRO,INDISO)=
     *      TC1_D0(INDPRO,INDISO)*FACNOR
            TC1_DP(INDPRO,INDISO)=
     *      TC1_DP(INDPRO,INDISO)*FACNOR
            TC1_DM(INDPRO,INDISO)=
     *      TC1_DM(INDPRO,INDISO)*FACNOR
            TC2_D0(INDPRO,INDISO)=
     *      TC2_D0(INDPRO,INDISO)*FACNOR
            TC21DP(INDPRO,INDISO)=
     *      TC21DP(INDPRO,INDISO)*FACNOR
            TC21DM(INDPRO,INDISO)=
     *      TC21DM(INDPRO,INDISO)*FACNOR
            TC22DP(INDPRO,INDISO)=
     *      TC22DP(INDPRO,INDISO)*FACNOR
            TC22DM(INDPRO,INDISO)=
     *      TC22DM(INDPRO,INDISO)*FACNOR
C
            TCO_XT(INDPRO,INDISO)=
     *      TCO_XT(INDPRO,INDISO)*FACNOR
            TC1_X0(INDPRO,INDISO)=
     *      TC1_X0(INDPRO,INDISO)*FACNOR
            TC1_XP(INDPRO,INDISO)=
     *      TC1_XP(INDPRO,INDISO)*FACNOR
            TC1_XM(INDPRO,INDISO)=
     *      TC1_XM(INDPRO,INDISO)*FACNOR
            TC2_X0(INDPRO,INDISO)=
     *      TC2_X0(INDPRO,INDISO)*FACNOR
            TC21XP(INDPRO,INDISO)=
     *      TC21XP(INDPRO,INDISO)*FACNOR
            TC21XM(INDPRO,INDISO)=
     *      TC21XM(INDPRO,INDISO)*FACNOR
            TC22XP(INDPRO,INDISO)=
     *      TC22XP(INDPRO,INDISO)*FACNOR
            TC22XM(INDPRO,INDISO)=
     *      TC22XM(INDPRO,INDISO)*FACNOR
C
            TPN_00(INDPRO,INDISO)=
     *      TPN_00(INDPRO,INDISO)*FACNOR
            TPN_10(INDPRO,INDISO)=
     *      TPN_10(INDPRO,INDISO)*FACNOR
            TPN_1P(INDPRO,INDISO)=
     *      TPN_1P(INDPRO,INDISO)*FACNOR
            TPN_1M(INDPRO,INDISO)=
     *      TPN_1M(INDPRO,INDISO)*FACNOR
C
            TTZ_IS(INDPRO,INDISO)=
     *      TTZ_IS(INDPRO,INDISO)*FACNOR
            TT2_IS(INDPRO,INDISO)=
     *      TT2_IS(INDPRO,INDISO)*FACNOR
C
            TBZ_RO(INDPRO,INDISO)=
     *      TBZ_RO(INDPRO,INDISO)*FACNOR
            TB2_RO(INDPRO,INDISO)=
     *      TB2_RO(INDPRO,INDISO)*FACNOR
C
            OPROJE(INDPRO,INDISO)=
     *      TKE_TT(INDPRO,INDISO)
C
C=======================================================================
C           MATRIX ELEMENTS OF THE SCALAR-ISOSCALAR PART
C                         OF THE HAMILTONIAN
C=======================================================================
C
            EPROJE(INDPRO,INDISO)=
     *      TSK_TT(INDPRO,INDISO)
     *     +TKI_NT(INDPRO,INDISO)
     *     +TKI_PT(INDPRO,INDISO)
     *     +TCO_DT(INDPRO,INDISO)
     *     +TCO_XT(INDPRO,INDISO)
C
            EPROJE(INDPRO,INDISO)=EPROJE(INDPRO,INDISO)
     *     +TPA_NT(INDPRO,INDISO)+TPA_PT(INDPRO,INDISO)
C
         END DO
C
      END DO
C
      IF (NBTKNO.EQ.1.AND.(IKEPRI.EQ.1.OR.IRMPRI.EQ.1)) THEN
C
C=======================================================================
C           MATRIX ELEMENTS OF MULTIPOLE OPERATORS
C=======================================================================
C
          DO IREPRO=1,NUPREM
C
             IPROAC=IREMAT(IREPRO)
             LPROAC=LREMAT(IREPRO)
             KPROAC=KREMAT(IREPRO)
C
             IF (NUBKNO.EQ.1) THEN
                 FACNOI=             1/( 4.0D0*PI*PI)
             ELSE
                 FACNOI=(IPROAC+1.0D0)/( 8.0D0*PI*PI)
             END IF
C
             FACNOR=FACNOI               /(4.0D0*PI*PI)
C
             DO LAMBDA=0,NMURED
                DO MIU=-LAMBDA,LAMBDA
C
                   TMUL_P(IND_LM(LAMBDA,MIU),IREPRO)=
     *             TMUL_P(IND_LM(LAMBDA,MIU),IREPRO)*FACNOR
C
C=======================================================================
C           ATTENTION: THE SUM RULES BELOW ARE  EVALUATED  FOR  DIAGONAL
C                      MAGNETIC COMPONENTS LPROAC=KPROAC.  IN  ADDITION,
C                      FOR AXIAL CALCULATIONS (IAXIAL=1), WHEN  K  IS  A
C                      GOOD QUANTUM  NUMBER,  WE  MANUALLY  ENFORCE  THE
C                      CORRECT SELECTION RULE OF  MIU = 0.  THIS  IS  SO
C                      BECAUSE ONLY THOSE MARIX ELEMENTS  THAT  DO  OBEY
C                      THE SELECTION RULE ARE THEN REAL,  WHEREAS  THOSE
C                      THAT DO NOT ARE FICTITIOUS.
C=======================================================================
C
                   IF (LPROAC.EQ.KPROAC.AND.(IAXIAL.NE.1.OR.MIU.EQ.0))
     *                 RMUL_P(LAMBDA,MIU)=RMUL_P(LAMBDA,MIU)
     *                            +TMUL_P(IND_LM(LAMBDA,MIU),IREPRO)
C
                END DO
             END DO
C
C     IF (LPROAC.EQ.KPROAC) WRITE (*,'(3I4,2(4X,2D17.8))')
C    *                                 IPROAC,LPROAC,KPROAC,
C    *                                 TMUL_P(IND_LM(0,0),IREPRO),
C    *                                        RMUL_P(0,0)
C
             DO LAMBDA=1,NMARED
                DO MIU=-LAMBDA,LAMBDA
C
                   TMAG_T(IND_LM(LAMBDA,MIU),IREPRO,:)=
     *             TMAG_T(IND_LM(LAMBDA,MIU),IREPRO,:)*FACNOR
C
                   IF (LPROAC.EQ.KPROAC.AND.(IAXIAL.NE.1.OR.MIU.EQ.0))
     *                 RMAG_T(LAMBDA,MIU)=RMAG_T(LAMBDA,MIU)
     *                            +TMAG_T(IND_LM(LAMBDA,MIU),IREPRO,0)
C
C     WRITE (*,'(3I4,I7,3X,2I3,2(4X,2D17.8))')
C    *           IPROAC,LPROAC,KPROAC,IREPRO,LAMBDA,MIU,
C    *           TMAG_T(IND_LM(LAMBDA,MIU),IREPRO,0),
C    *                  RMAG_T(LAMBDA,MIU)
C
                END DO
             END DO
C
             IF (NASORD.GE.0) THEN
C
                 DO LAMBDA=1,NASRED
                    DO MIU=-LAMBDA,LAMBDA
C
                       TASM_T(IND_LM(LAMBDA,MIU),IREPRO,:)=
     *                 TASM_T(IND_LM(LAMBDA,MIU),IREPRO,:)*FACNOR
C
                     IF (LPROAC.EQ.KPROAC.AND.(IAXIAL.NE.1.OR.MIU.EQ.0))
     *                   RASM_T(LAMBDA,MIU)=RASM_T(LAMBDA,MIU)
     *                              +TASM_T(IND_LM(LAMBDA,MIU),IREPRO,0)
C
                    END DO
                 END DO
C
             END IF
C
             DO LAMBDA=NSIMIN,NSIRED
                DO MIU=-LAMBDA,LAMBDA
C
                   TSIF_P(IND_LM(LAMBDA,MIU),IREPRO)=
     *             TSIF_P(IND_LM(LAMBDA,MIU),IREPRO)*FACNOR
C
                   IF (LPROAC.EQ.KPROAC.AND.(IAXIAL.NE.1.OR.MIU.EQ.0))
     *                 RSIF_P(LAMBDA,MIU)=RSIF_P(LAMBDA,MIU)
     *                            +TSIF_P(IND_LM(LAMBDA,MIU),IREPRO)
C
                END DO
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C        CALCULATING DIAGONAL MATRX ELEMENTS <IMK,TM_TK_T|H|IMK,TM_TK_T>
C        LSOSAC CORRESPONDS TO M_T
C        KSOSAC CORRESPONDS TO K_T
C=======================================================================
C
      I_HEAD=0
C
      DO INDPRO=1,NUPROM
C
         IPROAC=IROMAT(INDPRO)
         LPROAC=LROMAT(INDPRO)
         KPROAC=KROMAT(INDPRO)
C
         DO INDISO=1,NUISOM
C
            ISOSAC=ISOMAT(INDISO)
            LSOSAC=LSOMAT(INDISO)
            KSOSAC=KSOMAT(INDISO)
C
            E10L=CGCOEF(ISOSAC,LSOSAC  ,2, 0,ISOSAC,LSOSAC)
            E20L=CGCOEF(ISOSAC,LSOSAC  ,4, 0,ISOSAC,LSOSAC)
C
            E10K=CGCOEF(ISOSAC,KSOSAC  ,2, 0,ISOSAC,KSOSAC)
            E11P=CGCOEF(ISOSAC,KSOSAC-2,2, 2,ISOSAC,KSOSAC)
            E11M=CGCOEF(ISOSAC,KSOSAC+2,2,-2,ISOSAC,KSOSAC)
            E20K=CGCOEF(ISOSAC,KSOSAC  ,4, 0,ISOSAC,KSOSAC)
            E21P=CGCOEF(ISOSAC,KSOSAC-2,4, 2,ISOSAC,KSOSAC)
            E21M=CGCOEF(ISOSAC,KSOSAC+2,4,-2,ISOSAC,KSOSAC)
            E22P=CGCOEF(ISOSAC,KSOSAC-4,4, 4,ISOSAC,KSOSAC)
            E22M=CGCOEF(ISOSAC,KSOSAC+4,4,-4,ISOSAC,KSOSAC)
C
            E211P=E10L*E11P
            E211M=E10L*E11M
C
            E221P=E20L*E21P
            E221M=E20L*E21M
            E222P=E20L*E22P
            E222M=E20L*E22M
C
            E2_10=E10L*E10K
            E2_20=E20L*E20K
C
            IF(NBTKNO.GT.1.AND.NATKNO.EQ.1) THEN
C
C=======================================================================
C         CALCULATING MATRIX ELEMENTS FOR 1D ISOSPIN PROJECTION
C=======================================================================
C
               EPROJE(INDPRO,INDISO)=
     *         EPROJE(INDPRO,INDISO)
     *        +TC1_D0(INDPRO,INDISO)*E2_10
     *        +TC1_DP(INDPRO,INDISO)*E211P
     *        +TC1_DM(INDPRO,INDISO)*E211M
     *        +TC2_D0(INDPRO,INDISO)*E2_20
     *        +TC21DP(INDPRO,INDISO)*E221P
     *        +TC21DM(INDPRO,INDISO)*E221M
     *        +TC22DP(INDPRO,INDISO)*E222P
     *        +TC22DM(INDPRO,INDISO)*E222M
     *        +TC1_X0(INDPRO,INDISO)*E2_10
     *        +TC1_XP(INDPRO,INDISO)*E211P
     *        +TC1_XM(INDPRO,INDISO)*E211M
     *        +TC2_X0(INDPRO,INDISO)*E2_20
     *        +TC21XP(INDPRO,INDISO)*E221P
     *        +TC21XM(INDPRO,INDISO)*E221M
     *        +TC22XP(INDPRO,INDISO)*E222P
     *        +TC22XM(INDPRO,INDISO)*E222M
C
               INDI1M=INDISO
               INDI1P=INDISO
               INDI2M=INDISO
               INDI2P=INDISO
C
            END IF
C
            IF (NBTKNO.GT.1.AND.NATKNO.GT.1) THEN
C
C=======================================================================
C         CALCULATING MATRIX ELEMENTS FOR 3D ISOSPIN PROJECTION
C=======================================================================
C         ATTENTION:  THE  INDICES   OF   THE   ISOSPIN  PROJECTION  ARE
C                     APPROPRIATELY SHIFTED  ACCORDING  TO  THE  ISOSPIN
C                     COUPLING, SEE NOTES.
C                     WHENEVER THE ISOSPIN PROJECTION  OF  THE  OPERATOR
C                     EQUALS +1/-1 OR  +2/-2,  THE  LEFT  INDEX  OF  THE
C                     MATRIX ELEMENT  IS  SHIFTED  BY  -2/+2  OR  -4/+4.
C                     WHENEVER SUCH SHIFT LEADS TO AN ISOSPIN PROJECTION
C                     NOT  ALLOWED   BY   THE   RANGE   OF   PROJECTIONS
C                     CORRESPONDING TO  THE  GIVEN  TOTAL  ISOSPIN,  THE
C                     INDEX IS SET TO ZERO. THEREFORE, ALL MATRICES  ARE
C                     DIMENSIONNED STARTING FROM ZERO, AND SET TO ZERO.
C=======================================================================
C
                EPROJE(INDPRO,INDISO)=
     *          EPROJE(INDPRO,INDISO)
     *         +TC1_D0(INDPRO,INDISO)*E2_10
     *         +TC2_D0(INDPRO,INDISO)*E2_20
     *         +TC1_X0(INDPRO,INDISO)*E2_10
     *         +TC2_X0(INDPRO,INDISO)*E2_20
C
                INDI1M=0
                KSOS1M=KSOSAC+2
                IF (IABS(KSOS1M).LE.ISOSAC)
     *              INDI1M=INDTMK(ISOSAC,KSOS1M,KSOSAC)
C
                   EPROJE(INDPRO,INDISO)=
     *             EPROJE(INDPRO,INDISO)
     *            +TC1_DM(INDPRO,INDI1M)*E211M
     *            +TC1_XM(INDPRO,INDI1M)*E211M
     *            +TC21DM(INDPRO,INDI1M)*E221M
     *            +TC21XM(INDPRO,INDI1M)*E221M
C
                INDI1P=0
                KSOS1P=KSOSAC-2
                IF (IABS(KSOS1P).LE.ISOSAC)
     *              INDI1P=INDTMK(ISOSAC,KSOS1P,KSOSAC)
C
                   EPROJE(INDPRO,INDISO)=
     *             EPROJE(INDPRO,INDISO)
     *            +TC1_DP(INDPRO,INDI1P)*E211P
     *            +TC1_XP(INDPRO,INDI1P)*E211P
     *            +TC21DP(INDPRO,INDI1P)*E221P
     *            +TC21XP(INDPRO,INDI1P)*E221P
C
                INDI2M=0
                KSOS2M=KSOSAC+4
                IF (IABS(KSOS2M).LE.ISOSAC)
     *              INDI2M=INDTMK(ISOSAC,KSOS2M,KSOSAC)
C
                   EPROJE(INDPRO,INDISO)=
     *             EPROJE(INDPRO,INDISO)
     *            +TC22DM(INDPRO,INDI2M)*E222M
     *            +TC22XM(INDPRO,INDI2M)*E222M
C
                INDI2P=0
                KSOS2P=KSOSAC-4
                IF (IABS(KSOS2P).LE.ISOSAC)
     *              INDI2P=INDTMK(ISOSAC,KSOS2P,KSOSAC)
C
                   EPROJE(INDPRO,INDISO)=
     *             EPROJE(INDPRO,INDISO)
     *            +TC22DP(INDPRO,INDI2P)*E222P
     *            +TC22XP(INDPRO,INDI2P)*E222P
C
            END IF
C
            IPRNDI=0
C
            IF ((LPROAC.EQ.KPROAC.AND.
     *           LSOSAC.EQ.KSOSAC).OR.IPRNDI.EQ.1) THEN
C
C=======================================================================
C                  PRINTING KERNELS AND AVERAGE VALUES
C=======================================================================
C
                IF (I_HEAD.EQ.0.AND.IENPRI.GT.0.AND.IDIAGO.EQ.1) THEN
C
                    IF (LPROJJ.EQ.0)
     *                 WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,4X,'' KERNELS AND AVERAGE VALUES'',
     *                              '' OBTAINED FOR ISOSPIN'',
     *                              '' PROJECTED STATES'',  5X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                                       79(1H*),/,1H*,77X,1H*)')
C
                    IF (LPROJJ.NE.0)
     *                 WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                  1H*,1X,'' KERNELS AND AVERAGE VALUES'',
     *                  '' OBTAINED FOR ANGULAR-MOMENTUM'',
     *                  '' PROJECTED STATES'',  2X,1H*,/,
     *                                     1H*,77X,1H*,/,
     *                           79(1H*),/,1H*,77X,1H*)')
C
                    IF (IPRNDI.EQ.1) THEN
C
                        WRITE(NFIPRI,'(
     *           1H*,1X,'' NON-DIAGONAL KERNELS ARE '',
     *                  '' PRINTED FOR TESTING; TO SWITCH'',
     *                  '' OFF SET IPRNDI=0'',     2X,1H*,/,
     *                                      1H*,77X,1H*)')
C
                    END IF
C
                    IF (IENPRI.EQ.1) THEN
C
                        WRITE(NFIPRI,'(
     *           1H*,1X,''                            '',
     *                  '' REAL(KERNEL)       IMAG(KERNEL)'',
     *                  '' AVERAGE ENERGY'',     1X,1H*,/,
     *                                      1H*,77X,1H*)')
                    ELSE
                        WRITE(NFIPRI,'(
     *           1H*,1X,''                            '',
     *                  '' REAL(KERNEL)       IMAG(KERNEL) '',
     *                  '' AVERAGE VALUE'',      1X,1H*,/,
     *                                      1H*,77X,1H*)')
C
                    END IF
C
                    I_HEAD=1
C
                END IF
C
                IF (IENPRI.EQ.1.AND.IPROAC.GE.ISLPRI
     *                         .AND.IPROAC.LE.ISUPRI
     *                         .AND.LPROJT.EQ.0.AND.IDIAGO.EQ.1)
     *
     *                 WRITE(NFIPRI,'(
     *                   1H*, 1X,'' I,K= '',2(I4,A2),
     *                     ''  NORM = '',F15.12,F16.12,F16.6,
     *                                                   2X,1H*)')
     *
     *             IPROAC/IEVEN_,CHALF_,
     *             LPROAC/IEVEN_,CHALF_,
     *                   TKE_TT(INDPRO,INDISO),
     *              REAL(EPROJE(INDPRO,INDISO))
     *             /REAL(TKE_TT(INDPRO,INDISO))
C
                IF (IENPRI.EQ.1.AND.IPROAC.GE.ISLPRI
     *                         .AND.IPROAC.LE.ISUPRI
     *                         .AND.LPROJT.EQ.1
     *                         .AND.LPROJJ.EQ.1)
     *
     *                 WRITE(NFIPRI,'(
     *                   1H*, 1X,''I,K,T='',3(I3,A2),
     *                     '' NORM= '',F15.12,F16.12,F16.6,
     *                                                   1X,1H*)')
     *
     *             IPROAC/IEVEN_,CHALF_,
     *             LPROAC/IEVEN_,CHALF_,
     *             ISOSAC/IEVEN_,CHALF_,
     *                   TKE_TT(INDPRO,INDISO),
     *              REAL(EPROJE(INDPRO,INDISO))
     *             /REAL(TKE_TT(INDPRO,INDISO))
C
                IF (IENPRI.EQ.1
     *                   .AND.LPROJT.EQ.1
     *                   .AND.LPROJJ.EQ.0)
     *
     *                 WRITE(NFIPRI,'(
     *                   1H*, 3X,''T=    '',I3,A2,5X,
     *                     '' NORM = '',F15.12,F16.12,F16.6,
     *                                                   3X,1H*)')
     *
     *             ISOSAC/IEVEN_,CHALF_,
     *                   TKE_TT(INDPRO,INDISO),
     *              REAL(EPROJE(INDPRO,INDISO))
     *             /REAL(TKE_TT(INDPRO,INDISO))
C
                IF (IENPRI.EQ.2.AND.IPROAC.GE.ISLPRI
     *                         .AND.IPROAC.LE.ISUPRI
     *                         .AND.LPROJT.EQ.0)
     *
     *              WRITE(NFIPRI,'(
     *             1H*, 1X,''I,K='',2(I4,A2),
     *                        '' NORM='',2F19.12,16X,1H*,/,
     *             1H*,14X,''SKYRME  ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''EKIN_N  ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''EKIN_P  ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''COU_DIR ='',2F19.12,16X,1H*,/,
     *             1H*,14X,''COU_EXC ='',2F19.12,16X,1H*,/,
     *             1H*,14X,''COU_TOT ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''E_TOTAL ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''      A ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''    N-Z ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''     TZ ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''     T2 ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''     JZ ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''     J2 ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''EPAIRN  ='',2F19.12,F15.6,1X,1H*,/,
     *             1H*,14X,''EPAIRP  ='',2F19.12,F15.6,1X,1H*,/,
     *                                            1H*,77X,1H*)')
     *
     *             IPROAC/IEVEN_,CHALF_,
     *             LPROAC/IEVEN_,CHALF_,
     *                 TKE_TT(INDPRO,INDISO),
     *                 TSK_TT(INDPRO,INDISO),
     *            REAL(TSK_TT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TKI_NT(INDPRO,INDISO),
     *            REAL(TKI_NT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TKI_PT(INDPRO,INDISO),
     *            REAL(TKI_PT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TCO_DT(INDPRO,INDISO),
     *                 TCO_XT(INDPRO,INDISO),
     *                 TCO_DT(INDPRO,INDISO)+
     *                 TCO_XT(INDPRO,INDISO),
     *            REAL(TCO_DT(INDPRO,INDISO)+
     *                 TCO_XT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 EPROJE(INDPRO,INDISO),
     *            REAL(EPROJE(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TPN_00(INDPRO,INDISO),
     *            REAL(TPN_00(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TPN_10(INDPRO,INDISO),
     *            REAL(TPN_10(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TTZ_IS(INDPRO,INDISO),
     *            REAL(TTZ_IS(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TT2_IS(INDPRO,INDISO),
     *            REAL(TT2_IS(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TBZ_RO(INDPRO,INDISO),
     *            REAL(TBZ_RO(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TB2_RO(INDPRO,INDISO),
     *            REAL(TB2_RO(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TPA_NT(INDPRO,INDISO),
     *            REAL(TPA_NT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TPA_PT(INDPRO,INDISO),
     *            REAL(TPA_PT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO))
C
C                ATTENTION: BETWEEN VERSIONS 2.98J AND 2.99K, IN CASE OF
C                           OF IPAHFB=0, ARRAYS  "TPA_NT"  AND  "TPA_PT"
C                           WERE ABOVE PRINTED WITHOUT BEING  ALLOCATED,
C                           WHICH WAS RESULTING THE SEGMENTATION  FAULT.
C                           THIS BUG  WAS  CORRECTED  ON  31/08/2020  IN
C                           VERSION 2.99L.
C
                IF (IENPRI.EQ.2.AND.IPROAC.GE.ISLPRI
     *                         .AND.IPROAC.LE.ISUPRI
     *                         .AND.LPROJT.NE.0)
     *             WRITE(NFIPRI,'(
     *             1H*, 1X,''T,KL,KP,I,KL,KP='',6(I4,A2) ,24X,1H*,/,
     *             1H*,22X,''NORM    ='',F15.6,E15.6,E15.6,1X,1H*,/,
     *             1H*,22X,''SKYRME  ='',F15.6,E15.6,F15.6,1X,1H*,/,
C TER*             1H*,22X,I3,''TERM ='',51F15.6,           1H*,/,
     *             1H*,22X,''EKIN_N  ='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''EKIN_P  ='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_00 ='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_00 ='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_00 ='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_10 ='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_10 ='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_10 ='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_1+1='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_1+1='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_1+1='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_1-1='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_1-1='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_1-1='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_20 ='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_20 ='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_20 ='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_2+1='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_2+1='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_2+1='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_2-1='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_2-1='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_2-1='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_2+2='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_2+2='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_2+2='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''COUD_2-2='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUE_2-2='',F15.6,E15.6,     16X,1H*,/,
     *             1H*,22X,''COUT_2-2='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''E_TOTAL ='',30X,        F15.6,1X,1H*,/,
     *             1H*,22X,''PNUMB_00='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''PNUMB_10='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''PNUMB_1P='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''PNUMB_1M='',F15.6,E15.6,F15.6,1X,1H*,/,
     *             1H*,22X,''    N-Z ='',30X,        F15.6,1X,1H*,/,
     *             1H*,22X,''     TZ ='',F15.6,E15.6,F15.6,1X,1H*,
     *                                                 E15.6,/,
     *             1H*,22X,''     T2 ='',F15.6,E15.6,F15.6,1X,1H*,
     *                                                 E15.6,/,
     *             1H*,22X,''     JZ ='',F15.6,E15.6,F15.6,1X,1H*,
     *                                                 E15.6,/,
     *             1H*,22X,''     J2 ='',F15.6,E15.6,F15.6,1X,1H*,
     *                                                          E15.6,/,
     *                                                1H*,77X,1H*)')
     *             ISOSAC/IEVEN_,CHALF_,
     *             LSOSAC/IEVEN_,CHALF_,
     *             KSOSAC/IEVEN_,CHALF_,
     *             IPROAC/IEVEN_,CHALF_,
     *             LPROAC/IEVEN_,CHALF_,
     *             KPROAC/IEVEN_,CHALF_,
     *                 TKE_TT(INDPRO,INDISO),
     *             ABS(TKE_TT(INDPRO,INDISO)),
     *                 TSK_TT(INDPRO,INDISO),
     *            REAL(TSK_TT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
C TER*            REAL(TKI_NT(INDPRO,INDISO))
C TER*           /REAL(TKE_TT(INDPRO,INDISO)),
C TER*            REAL(TKI_PT(INDPRO,INDISO))
C TER*           /REAL(TKE_TT(INDPRO,INDISO)),
C TER*            REAL(EPROJE(INDPRO,INDISO))
C TER*           /REAL(TKE_TT(INDPRO,INDISO)),
C TER*           (REAL(TTE_TT(INDPRO,INDISO,NUCOUT))
C TER*           /REAL(TKE_TT(INDPRO,INDISO)),NUCOUT=1,2*NDCOUT),
     *                 TKI_NT(INDPRO,INDISO),
     *            REAL(TKI_NT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TKI_PT(INDPRO,INDISO),
     *            REAL(TKI_PT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TCO_DT(INDPRO,INDISO),
     *                 TCO_XT(INDPRO,INDISO),
     *                 TCO_DT(INDPRO,INDISO)+
     *                 TCO_XT(INDPRO,INDISO),
     *            REAL(TCO_DT(INDPRO,INDISO)+
     *                 TCO_XT(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TC1_D0(INDPRO,INDISO),
     *                 TC1_X0(INDPRO,INDISO),
     *                 TC1_D0(INDPRO,INDISO)+
     *                 TC1_X0(INDPRO,INDISO),
     *      E2_10*REAL(TC1_D0(INDPRO,INDISO)+
     *                 TC1_X0(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TC1_DP(INDPRO,INDI1P),
     *                 TC1_XP(INDPRO,INDI1P),
     *                 TC1_DP(INDPRO,INDI1P)+
     *                 TC1_XP(INDPRO,INDI1P),
     *      E211P*REAL(TC1_DP(INDPRO,INDI1P)+
     *                 TC1_XP(INDPRO,INDI1P))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TC1_DM(INDPRO,INDI1M),
     *                 TC1_XM(INDPRO,INDI1M),
     *                 TC1_DM(INDPRO,INDI1M)+
     *                 TC1_XM(INDPRO,INDI1M),
     *      E211M*REAL(TC1_DM(INDPRO,INDI1M)+
     *                 TC1_XM(INDPRO,INDI1M))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TC2_D0(INDPRO,INDISO),
     *                 TC2_X0(INDPRO,INDISO),
     *                 TC2_D0(INDPRO,INDISO)+
     *                 TC2_X0(INDPRO,INDISO),
     *      E2_20*REAL(TC2_D0(INDPRO,INDISO)+
     *                 TC2_X0(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TC21DP(INDPRO,INDI1P),
     *                 TC21XP(INDPRO,INDI1P),
     *                 TC21DP(INDPRO,INDI1P)+
     *                 TC21XP(INDPRO,INDI1P),
     *      E221P*REAL(TC21DP(INDPRO,INDI1P)+
     *                 TC21XP(INDPRO,INDI1P))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TC21DM(INDPRO,INDI1M),
     *                 TC21XM(INDPRO,INDI1M),
     *                 TC21DM(INDPRO,INDI1M)+
     *                 TC21XM(INDPRO,INDI1M),
     *      E221M*REAL(TC21DM(INDPRO,INDI1M)+
     *                 TC21XM(INDPRO,INDI1M))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TC22DP(INDPRO,INDI2P),
     *                 TC22XP(INDPRO,INDI2P),
     *                 TC22DP(INDPRO,INDI2P)+
     *                 TC22XP(INDPRO,INDI2P),
     *      E222P*REAL(TC22DP(INDPRO,INDI2P)+
     *                 TC22XP(INDPRO,INDI2P))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TC22DM(INDPRO,INDI2M),
     *                 TC22XM(INDPRO,INDI2M),
     *                 TC22DM(INDPRO,INDI2M)+
     *                 TC22XM(INDPRO,INDI2M),
     *      E222M*REAL(TC22DM(INDPRO,INDI2M)+
     *                 TC22XM(INDPRO,INDI2M))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *            REAL(EPROJE(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TPN_00(INDPRO,INDISO),
     *            REAL(TPN_00(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TPN_10(INDPRO,INDISO),
     *      E2_10*REAL(TPN_10(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TPN_1P(INDPRO,INDI1P),
     *      E211P*REAL(TPN_1P(INDPRO,INDI1P))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TPN_1M(INDPRO,INDI1M),
     *      E211M*REAL(TPN_1M(INDPRO,INDI1M))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *     (E2_10*REAL(TPN_10(INDPRO,INDISO))
     *     +E211P*REAL(TPN_1P(INDPRO,INDI1P))
     *     +E211M*REAL(TPN_1M(INDPRO,INDI1M)))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *                 TTZ_IS(INDPRO,INDISO),
     *            REAL(TTZ_IS(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *            REAL(TTZ_IS(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO))-LSOSAC/2.0D0,
     *                 TT2_IS(INDPRO,INDISO),
     *            REAL(TT2_IS(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *            REAL(TT2_IS(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO))-ISOSAC/2.0D0
     *                                      *(ISOSAC/2.0D0+1),
     *                 TBZ_RO(INDPRO,INDISO),
     *            REAL(TBZ_RO(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *            REAL(TBZ_RO(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO))-KPROJE/2.0D0,
     *                 TB2_RO(INDPRO,INDISO),
     *            REAL(TB2_RO(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO)),
     *            REAL(TB2_RO(INDPRO,INDISO))
     *           /REAL(TKE_TT(INDPRO,INDISO))-IPROAC/2.0D0
     *                                      *(IPROAC/2.0D0+1)
C
C=======================================================================
C         CALCULATING THE SUM RULES FOR DIAGONAL TERMS LPROAC=KPROAC
C=======================================================================
C
                IF (LPROAC.EQ.KPROAC.AND.
     *              LSOSAC.EQ.KSOSAC) THEN
C
                    RKER_T=RKER_T+TKE_TT(INDPRO,INDISO)
C
                    RSKY_T=RSKY_T+TSK_TT(INDPRO,INDISO)
                    RKIN_T=RKIN_T+TKI_NT(INDPRO,INDISO)
     *                           +TKI_PT(INDPRO,INDISO)
C
                    RPAI_T=RPAI_T+TPA_NT(INDPRO,INDISO)
     *                           +TPA_PT(INDPRO,INDISO)
C
                    RCOU_D=RCOU_D
     *                    +TCO_DT(INDPRO,INDISO)
     *                    +TC1_D0(INDPRO,INDISO)
     *                    +TC2_D0(INDPRO,INDISO)
C
                    RCOU_X=RCOU_X
     *                    +TCO_XT(INDPRO,INDISO)
     *                    +TC1_X0(INDPRO,INDISO)
     *                    +TC2_X0(INDPRO,INDISO)
C
                    RPARTN=RPARTN
     *                    +TPN_00(INDPRO,INDISO)
                    RISOSP=RISOSP
     *                    +TPN_10(INDPRO,INDISO)
C
                    RTZISO=RTZISO
     *                    +TTZ_IS(INDPRO,INDISO)
                    RT2ISO=RT2ISO
     *                    +TT2_IS(INDPRO,INDISO)
C
                    RBZROT=RBZROT
     *                    +TBZ_RO(INDPRO,INDISO)
                    RB2ROT=RB2ROT
     *                    +TB2_RO(INDPRO,INDISO)
C
                END IF
C
            END IF
C
C=======================================================================
C              HERE ENDS THE INTERNAL LOOP OVER THE ISOSPIN
C=======================================================================
C
         END DO
C
         IF (LPROJJ.EQ.0.AND.NATKNO.EQ.1) THEN
C
C=======================================================================
C                 REDIAGONALIZATION OF THE COULOMB FIELD
C                    IN A RUN WITHOUT SPIN PROJECTION
C=======================================================================
C
             ALLOCATE (CELMTS(1:((NDPROT+1)*NDPROT)/2),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('CELMTS','PROANG')
             ALLOCATE (HAMWAV(1:NDPROT,1:NDPROT),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('HAMWAV','PROANG')
             ALLOCATE (HAMMAT(1:NDPROT,1:NDPROT),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('HAMMAT','PROANG')
C
             DO INDISO=1,NUISOM
C
                ISOSAC=ISOMAT(INDISO)
C
                IF (ABS(OPROJE(INDPRO,INDISO)).GT.EPSISO) THEN
                    ITTDIM=ISOSAC
                END IF
C
             END DO
C
             ITTD=(ITTDIM-JSOSMI)/2+1
             IF (IENPRI.EQ.3)
     *       WRITE(*,233) EPSISO,ITTD
 233         FORMAT(1H*,77X,1H*,/,1H*,
     *              6X,'CUT-OFF "EPSISO" =  ',F16.14,
     *              1X,'==> GOOD-T BASIS OF DIM = ',I2,6X,1H*,/,
     *              1H*,77X,1H*)
C
             DO IBRA=1,ITTD
C
                ISOBRA=ISOMAT(IBRA)
C
                DO IKET=1,ITTD
C
                   ISOKET=ISOMAT(IKET)
C
                   E_10=CGCOEF(ISOKET,ISOSTZ  ,2, 0,ISOBRA,ISOSTZ)
                   E11P=CGCOEF(ISOKET,ISOSTZ-2,2, 2,ISOBRA,ISOSTZ)
                   E11M=CGCOEF(ISOKET,ISOSTZ+2,2,-2,ISOBRA,ISOSTZ)
                   E_20=CGCOEF(ISOKET,ISOSTZ  ,4, 0,ISOBRA,ISOSTZ)
                   E21P=CGCOEF(ISOKET,ISOSTZ-2,4, 2,ISOBRA,ISOSTZ)
                   E21M=CGCOEF(ISOKET,ISOSTZ+2,4,-2,ISOBRA,ISOSTZ)
                   E22P=CGCOEF(ISOKET,ISOSTZ-4,4, 4,ISOBRA,ISOSTZ)
                   E22M=CGCOEF(ISOKET,ISOSTZ+4,4,-4,ISOBRA,ISOSTZ)
C
                   E211P=E_10*E11P
                   E211M=E_10*E11M
C
                   E221P=E_20*E21P
                   E221M=E_20*E21M
                   E222P=E_20*E22P
                   E222M=E_20*E22M
C
                   E2_10=E_10*E_10
                   E2_20=E_20*E_20
C
                   IF (IBRA.EQ.IKET) THEN
                   HAMMAT(IBRA,IKET)=
     *                      EPROJE(INDPRO,IBRA)
     *                /REAL(OPROJE(INDPRO,IBRA))
C
                   IF (IENPRI.EQ.3)
     *             WRITE(*,234) ISOBRA/IEVEN_,CHALF_,ISOKET/IEVEN_,
     *                  CHALF_,HAMMAT(IBRA,IKET),
     *             REAL(OPROJE(INDPRO,IBRA)),
     *                  EPROJE(INDPRO,IBRA)
C
                   END IF
C
                   IF (IBRA.NE.IKET) THEN
                       HAMMAT(IBRA,IKET)=
     *                 (E2_10*(TC1_D0(INDPRO,IKET)+
     *                         TC1_X0(INDPRO,IKET))
     *                 +E211P*(TC1_DP(INDPRO,IKET)+
     *                         TC1_XP(INDPRO,IKET))
     *                 +E211M*(TC1_DM(INDPRO,IKET)+
     *                         TC1_XM(INDPRO,IKET))
     *                 +E2_20*(TC2_D0(INDPRO,IKET)+
     *                         TC2_X0(INDPRO,IKET))
     *                 +E221P*(TC21DP(INDPRO,IKET)+
     *                         TC21XP(INDPRO,IKET))
     *                 +E221M*(TC21DM(INDPRO,IKET)+
     *                         TC21XM(INDPRO,IKET))
     *                 +E222P*(TC22DP(INDPRO,IKET)+
     *                         TC22XP(INDPRO,IKET))
     *                 +E222M*(TC22DM(INDPRO,IKET)+
     *                         TC22XM(INDPRO,IKET)))
     *              /SQRT(REAL(OPROJE(INDPRO,IBRA)))
     *              /SQRT(REAL(OPROJE(INDPRO,IKET)))
C
                       IF (IENPRI.EQ.3)
     *                 WRITE(*,234) ISOBRA/IEVEN_,CHALF_,ISOKET/IEVEN_,
     *                              CHALF_,HAMMAT(IBRA,IKET),
     *                  SQRT(REAL(OPROJE(INDPRO,IBRA)))
     *                 *SQRT(REAL(OPROJE(INDPRO,IKET))),
     *                     E2_10*(TC1_D0(INDPRO,IKET)+
     *                            TC1_X0(INDPRO,IKET))
     *                    +E211P*(TC1_DP(INDPRO,IKET)+
     *                            TC1_XP(INDPRO,IKET))
     *                    +E211M*(TC1_DM(INDPRO,IKET)+
     *                            TC1_XM(INDPRO,IKET))
     *                    +E2_20*(TC2_D0(INDPRO,IKET)+
     *                            TC2_X0(INDPRO,IKET))
     *                    +E221P*(TC21DP(INDPRO,IKET)+
     *                            TC21XP(INDPRO,IKET))
     *                    +E221M*(TC21DM(INDPRO,IKET)+
     *                            TC21XM(INDPRO,IKET))
     *                    +E222P*(TC22DP(INDPRO,IKET)+
     *                            TC22XP(INDPRO,IKET))
     *                    +E222M*(TC22DM(INDPRO,IKET)+
     *                            TC22XM(INDPRO,IKET))
 234                   FORMAT(1H*,1X,2(I4,A2),(F12.6,F10.6),3X,F12.10,
     *                                          3X,(F12.6,F10.6),2X,1H*)
                   END IF
C
                   IF (IBRA.GE.IKET) THEN
C
                       NCOUNT=IBRA+((2*ITTD-IKET)*(IKET-1))/2
C
                       CELMTS(NCOUNT)=HAMMAT(IBRA,IKET)
C
                   END IF
C
                END DO
             END DO
C
             CALL DIAMAT(CELMTS,HAMEIG,HAMWAV,ITTD,NDPROT,ITTD)
C
             IF (IENPRI.EQ.3) THEN
                 WRITE(*,665)
 665             FORMAT(1H*,77X,1H*)
                 DO II=1,ITTD
                 WRITE(*,666) II, HAMEIG(II)
 666             FORMAT(1H*,2X,I2,'  EIGENENERGY IS:',F16.6,40X,1H*)
                 WRITE(*,667)(  ABS(HAMWAV(JJ,II))**2,JJ=1,
     *                         MIN(5,ITTD))
                 WRITE(*,667)( REAL(HAMWAV(JJ,II))   ,JJ=1,
     *                         MIN(5,ITTD))
                 WRITE(*,667)(AIMAG(HAMWAV(JJ,II))   ,JJ=1,
     *                         MIN(5,ITTD))
 667             FORMAT(1H*,5(4X,F10.6))
                 END DO
                 WRITE(*,665)
             END IF
C
             DEALLOCATE (CELMTS,HAMWAV,HAMMAT)

         END IF
C
         IF (LPROJJ.NE.0.AND.LPROAC.EQ.KPROAC.AND.ICOMIX.EQ.0
     *                                       .AND.IENPRI.EQ.4) THEN
         WRITE(*,991) IPROAC/IEVEN_,CHALF_,KPROAC/IEVEN_,CHALF_,
     *                RKER_T,RSKY_T,RKIN_T,
     *                RCOU_D+RCOU_X,RPARTN,RISOSP,
     *                RTZISO,RT2ISO,RBZROT,RB2ROT
         END IF
C
 991  FORMAT(
     *    1H*,77X,1H*,/,1H*,77('-'),1H*,/,
     *    1H*,1X,'PARTIAL SUM RULES FOR I<=',I3,A2,
     *                                 ' K=',I3,A2,38X,1H*,/,
     *    1H*,1X,'FOR OVERLAP          ',6X,2F16.12,17X,1H*,/,
     *    1H*,1X,'FOR SKYRME ENERGY    ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR KINETIC ENERGY   ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR PAIRING ENERGY   ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR COULOMB ENERGY   ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR PARTICLE NUMBER  ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR Tz               ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR Tz-NEW           ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR T2               ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR Jz               ',6X,2F16.6,17X,1H*,/,
     *    1H*,1X,'FOR J2               ',6X,2F16.6,17X,1H*,/,
     *    1H*,77('-'),1H*,/,1H*,77X,1H*)
C
C=======================================================================
C              HERE ENDS THE LOOP OVER THE "INDPRO" INDEX
C=======================================================================
C
      END DO
C
      IF (IENPRI.EQ.1.AND.ICOMIX.EQ.0) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C                    PRINTING THE ENERGY SUM RULES
C=======================================================================
C
      IF (ISRPRI.GE.0.AND.ICOMIX.EQ.0)
     *    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *      1H*,1X,'' SUM RULES OBTAINED FOR THE PROJECTED'',
     *             '' STATES AS COMPARED WITH THE HF VALUES'',1X,1H*,/,
     *                                1H*,77X,1H*,/,
     *                      79(1H*),/,1H*,77X,1H*)')
C
      IF (ISRPRI.GE.0.AND.ICOMIX.EQ.0)
     *    WRITE(NFIPRI,'(
     *      1H*,1X,''                           '',
     *             '' REAL(SUM RULE)  IMAG(SUM RULE)  '',
     *             ''      HF VALUE'',      2X,1H*,/,
     *                                 1H*,77X,1H*)')
C
      IF (ISRPRI.GE.0.AND.ICOMIX.EQ.0)
     *    WRITE(NFIPRI,'(
     *      1H*,19X,''    NORM='',F15.12, F16.12,18X,1H*,/,
     *      1H*,19X,''  SKYRME='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''  EKIN_T='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''  EPAI_T='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''  COUL_D='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''  COUL_E='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''  COUL_T='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''      TZ='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''      T2='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''      JZ='',F15.6 ,2F16.6 , 2X,1H*,/,
     *      1H*,19X,''      J2='',F15.6 ,2F16.6 , 2X,1H*,/,
     *                                       1H*,77X,1H*)')
     *
     *      RKER_T,RSKY_T,ENESKY,RKIN_T,EKIN_T,RPAI_T,EPAI_T,
     *             RCOU_D,ECOULD,RCOU_X,ECOULE,
     *             RCOU_D+RCOU_X,ECOULD+ECOULE,
     *             RTZISO,TOTISO(3),RT2ISO,TOTIS2(0),
     *             RBZROT,00000.000,RB2ROT,00000.000
C
C=======================================================================
C         PRINTING THE MULTIPOLE-MOMENT SUM RULES
C=======================================================================
C
      IF (NMURED.GT.0.AND.NMUMAX.GT.0.AND.ISRPRI.GE.0.AND.NBTKNO.EQ.1
     *                               .AND.ICOMIX.EQ.0) THEN
C
          NAMWRK='MULTIPOLE'
C
          DO LAMBDA=0,MIN(NMURED,NMUMAX)
C
                              MAXMIU=LAMBDA
C            IF (IAXIAL.EQ.1) MAXMIU=0
C
             DO MIU=-MAXMIU,MAXMIU
C
                NIU=IABS(MIU)
C
                WRITE(NFIPRI,'(
     *                1H*,1X,A9,'' L='',I2,'' M='',I2,
     *                    '' QMUL_P='',F15.6 ,2F16.6 , 2X,1H*)')
     *
     *                NAMWRK,LAMBDA,MIU,
     *                RMUL_P(LAMBDA,MIU),
     *                QMUL_P(LAMBDA,MIU)
C
                NAMWRK='         '
C
             END DO
          END DO
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C         PRINTING THE MAGNETIC-MOMENT SUM RULES
C=======================================================================
C
      IF (NMARED.GT.0.AND.NMAMAX.GT.0.AND.ISRPRI.GE.0.AND.NBTKNO.EQ.1
     *                               .AND.ICOMIX.EQ.0) THEN
C
          NAMWRK='MAGNETIC '
C
          DO LAMBDA=1,MIN(NMARED,NMAMAX)
C
                              MAXMIU=LAMBDA
C            IF (IAXIAL.EQ.1) MAXMIU=0
C
             DO MIU=-MAXMIU,MAXMIU
C
                NIU=IABS(MIU)
C
                WRITE(NFIPRI,'(
     *                1H*,1X,A9,'' L='',I2,'' M='',I2,
     *                    '' AMUL_T='',F15.6 ,2F16.6 , 2X,1H*)')
     *
     *                NAMWRK,LAMBDA,MIU,
     *                RMAG_T(LAMBDA,MIU),
     *                AMUL_T(LAMBDA,MIU,0)
C
                NAMWRK='         '
C
             END DO
          END DO
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C         PRINTING THE SPIN-ASYMMETRY-MOMENT SUM RULES
C=======================================================================
C
      IF (NASRED.GT.0.AND.NASMAX.GT.0.AND.ISRPRI.GE.0.AND.NBTKNO.EQ.1
     *               .AND.ICOMIX.EQ.0.AND.NASORD.GE.0) THEN
C
          NAMWRK='SPIN-ASYM'
C
          DO LAMBDA=1,MIN(NASRED,NASMAX)
C
                              MAXMIU=LAMBDA
C            IF (IAXIAL.EQ.1) MAXMIU=0
C
             DO MIU=-MAXMIU,MAXMIU
C
                NIU=IABS(MIU)
C
                WRITE(NFIPRI,'(
     *                1H*,1X,A9,'' L='',I2,'' M='',I2,
     *                    '' WMUL_T='',F15.6 ,2F16.6 , 2X,1H*)')
     *
     *                NAMWRK,LAMBDA,MIU,
     *                RASM_T(LAMBDA,MIU),
     *                WMUL_T(LAMBDA,MIU,0)
C
                NAMWRK='         '
C
             END DO
          END DO
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C         PRINTING THE SURFACE OR SCHIFF MOMENT SUM RULES
C=======================================================================
C
      IF (NSIRED.GE.0.AND.NSIMAX.GE.0.AND.ISRPRI.GE.0.AND.NBTKNO.EQ.1
     *                               .AND.ICOMIX.EQ.0) THEN
C
                           NAMWRK='SURFACE  '
          IF (ISCHIF.EQ.1) NAMWRK='SCHIFF   '
C
          DO LAMBDA=NSIMIN,MIN(NSIRED,NSIMAX)
C
                              MAXMIU=LAMBDA
C            IF (IAXIAL.EQ.1) MAXMIU=0
C
             DO MIU=-MAXMIU,MAXMIU
C
                NIU=IABS(MIU)
C
                WRITE(NFIPRI,'(
     *                1H*,1X,A9,'' L='',I2,'' M='',I2,
     *                    '' SMUL_P='',F15.6 ,2F16.6 , 2X,1H*)')
     *
     *                NAMWRK,LAMBDA,MIU,
     *                RSIF_P(LAMBDA,MIU),
     *                SMUL_P(LAMBDA,MIU)
C
                NAMWRK='         '
C
             END DO
          END DO
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
      IF (ISRPRI.GE.0.AND.ICOMIX.EQ.0) WRITE(NFIPRI,'(79(1H*))')
C
   10 CONTINUE
C
C=======================================================================
C        HERE WE BEGIN CALCULATION OF THE REDUCED KERNELS OF
C        THE MULTIPOLE  (IN "REDQ_P"), MAGNETIC (IN "REDM_P"),
C        SPIN-ASYMMETRY (IN "REDA_T", ONLY FOR NASORD>-1) , AND
C        SURFACE OR SCHIFF (IN "REDS_P") MOMENTS, AS WELL AS OF
C        COULOMB DIRECT AND EXCHANGE KERNELS, IF REQUESTED
C=======================================================================
C
C=======================================================================
C        ZEROING THE ARRAY  "INDRED" CONTAINING THE INDICES OF ARRAYS
C        "REDQ_P", "REDM_P", "REDA_T", AND "REDS_P"
C=======================================================================
C
      DO NPRLEF=1,NDPROK
         DO LAMBDA=0,MAX(NMURED,NMARED,NASRED,NSIRED)
            DO NPRRIG=1,NDPROK
C
               INDRED(NPRLEF,LAMBDA,NPRRIG)=0
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        INITIALIZING THE ARRAYS "REDQ_P", "REDM_P", "REDA_T",
C        AND "REDS_P"
C=======================================================================
C
      NUREDU=0
C
      REDQ_P(NUREDU)  =C_ZERO
      REDM_P(NUREDU,:)=C_ZERO
      REDS_P(NUREDU)  =C_ZERO
      IF (NASORD.GE.0) REDA_T(NUREDU,:)=C_ZERO
      IF (ICOUMD.GE.1) COUD_P(NUREDU)=C_ZERO
      IF (ICOUMX.GE.1) COUX_P(NUREDU)=C_ZERO
C
C=======================================================================
C         THIS JUMP SUSPENDS CALCULATION OF RESULTS FOR A PARALLEL RUN
C=======================================================================
C
      IF (IPAKER.EQ.1) GO TO 11
C
C=======================================================================
C         CALCULATING THE REDUCED  K E R N E L S  OF MULTIPOLE OPERATORS
C=======================================================================
C         ATTENTION!
C         WE CALCULATE THE REDUCED  K E R N E L S  OF COMPLEX-CONJUGATED
C         MULTIPOLE AND MAGNETIC MOMENTS, WHICH ARE  TRUE  CONTRAVARIANT
C         SPHERICAL TENSORS. THIS IS SO BECAUSE ALL MOMENTS USED IN  THE
C         CODE ARE DEFINED IN TERMS OF THE COMPLEX CONJUGATED  SPHERICAL
C         HARMONICS, SEE COMMENTS IN SUBROUTINES "MOMETS" AND  "MAGMOM".
C         AS A RESULT, BELOW WE HAVE THE PHASE FACTOR (-1)**MIU AND  THE
C         NEGATIVE INDEX "-MIU".
C=======================================================================
C         ATTENTION!
C         THE REDUCED  K E R N E L S  FOR INDICES THAT  DO  NOT  FULFILL
C         THE ANGULAR-MOMENTUM SELECTION RULES ARE PUT INTO THE LOCATION
C         NUREDU=0 OF ARRAYS "REDQ_P", "REDM_P", "REDA_T", AND "REDS_P".
C=======================================================================
C         ATTENTION!
C         --> FOR DIAGONAL KERNELS (IDIAGO=1):
C         ONLY THE REDUCED  K E R N E L S  FOR THE "LEFT" (FINAL) SPIN
C         NOT LARGER THAN THE "RIGHT" (INITIAL) SPIN ARE CALCULATED.
C         --> FOR NONDIAGONAL KERNELS (IDIAGO=0) OR BY SETTING IALLAM=1
C         ALL  THE REDUCED  K E R N E L S  ARE CALCULATED.
C=======================================================================
C         FOR ILIMAM=1, THE LOOP BELOW CALCULATES ONLY THOSE  ANGULAR
C                       MOMENTA THAT ARE LATER REQUIRED FOR PRINTING.
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.83M AND 2.95S, THE MAXIMUM INDEX
C                    "MINDIK" BELOW  WAS  CALCULATED  USING  PROJECTIONS
C                    "KPRSTA" AND "KPRSTO" AND  NOT  USING  THE  MAXIMUM
C                    PROJECTION KPRRIG=JPROMA. AS RESULT, IN CASE OF THE
C                    AXIAL PROJECTION, SOME SECURITY  STOPS  BELOW  WERE
C                    UNNECESSARILY ACTIVATED. THIS BUG WAS CORRECTED  ON
C                    05/06/2020 IN VERSION 2.95T.
C=======================================================================
C
      MINDIK=IND_IK(JPROMA,JPROMA)
C
C=======================================================================
C
      DO IPRRIG=JPROMI,JPROMA,2
C
         DO KPRRIG=KPRSTA(IPRRIG),KPRSTO(IPRRIG),2
C
            DO LAMBDA=0,MAX(NMURED,NMARED,NASRED,NSIRED)
C
               MAXMIU=LAMBDA
C
                                      IMXLEF=IPRRIG
               IF (IDIAGO.NE.1.OR.IALLAM.EQ.1)
     *                                IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
               DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C
                  DO KPRLEF=LPRSTA(IPRLEF),LPRSTO(IPRLEF),2
C
                     IF (ILIMAM.NE.1.OR.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
C=======================================================================
C                    CHECKING IF THE LIST OF THE REDUCED KERNELS
C                    IS NOT TOO LONG
C=======================================================================
C
                         IF (NUREDU.LT.NDREDU) THEN
C
                             NUREDU=NUREDU+1
                         ELSE
                             STOP ' INCREASE NDREDU IN PROANG'
C
                         END IF
C
C=======================================================================
C
                         REDQ_P(NUREDU)  =C_ZERO
                         REDM_P(NUREDU,:)=C_ZERO
                         REDS_P(NUREDU)  =C_ZERO
                         IF (NASORD.GE.0)
     *                   REDA_T(NUREDU,:)=C_ZERO
                         IF (ICOUMD.GE.1)
     *                   COUD_P(NUREDU)  =C_ZERO
                         IF (ICOUMX.GE.1)
     *                   COUX_P(NUREDU)  =C_ZERO
C
                         INDRED(IND_IK(IPRLEF,KPRLEF),LAMBDA,
     *                          IND_IK(IPRRIG,KPRRIG))=NUREDU
C
                         DO MIU=-MAXMIU,MAXMIU
C
                            NIU=IABS(MIU)
C
                            MPRRIG=KPRLEF-2*MIU
C
                            IF (ABS(MPRRIG).LE.IPRRIG) THEN
C
C=======================================================================
C         ATTENTION: UP TO VERSION (3.10B), FOR PARITY  PROJECTION,  THE
C                    REDUCED MATRIX ELEMENTS OF THE PARITY-ODD MULTIPOLE
C                    OPERATORS (THOSE FOR THE ODD VALUES OF LAMBDA) WERE
C                    INCORRECTLY CALCULATED  INSTEAD  OF  BEING  SET  TO
C                    ZERO. THIS  BUG  WAS  CORRECTED  ON  25/01/2022  IN
C                    VERSION (3.10C).
C=======================================================================
C
                                IF (NPAKNO.EQ.1.OR.MOD(LAMBDA,2).EQ.0)
     *
     *                              REDQ_P(NUREDU)=REDQ_P(NUREDU)
     *                             +SQRT(IPRLEF+1.0D0)*(-1)**MIU
     *                             *CGCOEF(IPRRIG,MPRRIG,2*LAMBDA,2*MIU,
     *                                     IPRLEF,KPRLEF)
     *                             *TMUL_P(IND_LM(LAMBDA,-MIU),
     *                                     IREIMK(IPRRIG,MPRRIG,KPRRIG))
     *                             *QUNITS(LAMBDA,0)/QUNITS(LAMBDA,NIU)
C
C!!!!!!!!!!!!!!!!!!   printing for even spins
C     write (*,'(7I4,E12.4,2(3X,2E12.4))')
C    *          IPRLEF/2,KPRLEF/2,LAMBDA,MIU,IPRRIG/2,MPRRIG/2,KPRRIG/2,
C    *                              CGCOEF(IPRRIG,MPRRIG,2*LAMBDA,2*MIU,
C    *                                     IPRLEF,KPRLEF),
C    *                              TMUL_P(IND_LM(LAMBDA,-MIU),
C    *                                    INDIMK(IPRRIG,MPRRIG,KPRRIG)),
C    *                              REDQ_P(NUREDU)
C!!!!!!!!!!!!!!!!!!
                                IF (LAMBDA.GT.0.AND.LAMBDA.LE.NMARED)
     *                                                              THEN
                                    DO NUMORD=0,NMAORD
C
C=======================================================================
C         ATTENTION: UP TO VERSION (3.10B), FOR PARITY  PROJECTION,  THE
C                    REDUCED MATRIX ELEMENTS OF THE PARITY-EVEN MAGNETIC
C                    OPERATORS (THOSE FOR THE  EVEN  VALUES  OF  LAMBDA)
C                    WERE INCORRECTLY CALCULATED INSTEAD  OF  BEING  SET
C                    TO ZERO. THIS BUG WAS CORRECTED  ON  25/01/2022  IN
C                    VERSION  (3.10C).
C=======================================================================
C
                                       IF (NPAKNO.EQ.1.OR.
     *                                     MOD(LAMBDA,2).EQ.1)
     *
     *                                     REDM_P(NUREDU,NUMORD)=
     *                                     REDM_P(NUREDU,NUMORD)
     *                             +SQRT(IPRLEF+1.0D0)*(-1)**MIU
     *                             *CGCOEF(IPRRIG,MPRRIG,2*LAMBDA,2*MIU,
     *                                     IPRLEF,KPRLEF)
     *                             *TMAG_T(IND_LM(LAMBDA,-MIU),
     *                              IREIMK(IPRRIG,MPRRIG,KPRRIG),NUMORD)
     *                             *AUNITS(LAMBDA,0)/AUNITS(LAMBDA,NIU)
C
                                    END DO
C
                                END IF
C
                                IF (LAMBDA.GT.0.AND.LAMBDA.LE.NASRED)
     *                                                              THEN
                                    DO NUMORD=0,NASORD
C
                                           REDA_T(NUREDU,NUMORD)=
     *                                     REDA_T(NUREDU,NUMORD)
     *                             +SQRT(IPRLEF+1.0D0)*(-1)**MIU
     *                             *CGCOEF(IPRRIG,MPRRIG,2*LAMBDA,2*MIU,
     *                                     IPRLEF,KPRLEF)
     *                             *TASM_T(IND_LM(LAMBDA,-MIU),
     *                              IREIMK(IPRRIG,MPRRIG,KPRRIG),NUMORD)
     *                             *BUNITS(LAMBDA,0)/BUNITS(LAMBDA,NIU)
C
                                    END DO
C
                                END IF
C
                                IF (LAMBDA.GE.NSIMIN.AND.
     *                              LAMBDA.LE.NSIRED) THEN
C
C=======================================================================
C         ATTENTION: UP TO VERSION (3.10B), FOR PARITY  PROJECTION,  THE
C                    REDUCED MATRIX ELEMENTS OF THE  PARITY-ODD  SURFACE
C                    OPERATORS (THOSE FOR THE ODD VALUES OF LAMBDA) WERE
C                    INCORRECTLY CALCULATED  INSTEAD  OF  BEING  SET  TO
C                    ZERO. THIS  BUG  WAS  CORRECTED  ON  25/01/2022  IN
C                    VERSION (3.10C).
C=======================================================================
C
                                    IF (NPAKNO.EQ.1.OR.
     *                                  MOD(LAMBDA,2).EQ.0)
     *
     *                                  REDS_P(NUREDU)=REDS_P(NUREDU)
     *                             +SQRT(IPRLEF+1.0D0)*(-1)**MIU
     *                             *CGCOEF(IPRRIG,MPRRIG,2*LAMBDA,2*MIU,
     *                                     IPRLEF,KPRLEF)
     *                             *TSIF_P(IND_LM(LAMBDA,-MIU),
     *                                     IREIMK(IPRRIG,MPRRIG,KPRRIG))
     *                             *SUNITS(LAMBDA,0)/SUNITS(LAMBDA,NIU)
C
                                END IF
C
                                IF (ICOUMD.GE.1.AND.LAMBDA.EQ.0) THEN
C
                                    COUD_P(NUREDU)=COUD_P(NUREDU)
     *                             +TCO_DT(IND_LM(LAMBDA,-MIU),
     *                                     IREIMK(IPRRIG,MPRRIG,KPRRIG))
C
                                END IF
C
                                IF (ICOUMX.GE.1.AND.LAMBDA.EQ.0) THEN
C
                                    COUX_P(NUREDU)=COUX_P(NUREDU)
     *                             +TCO_XT(IND_LM(LAMBDA,-MIU),
     *                                     IREIMK(IPRRIG,MPRRIG,KPRRIG))
C
                                END IF
C
                            END IF
C
                         END DO
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
      END DO
C
      IF (MINDIK.GT.NDPROK) STOP ' INCREASE NDPROK TO RUN PROANG'
C
C=======================================================================
C         PRINTING THE REDUCED KERNELS OF MULTIPOLE OPERATORS
C=======================================================================
C
      NAMWRK=NAMMUL
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=0,NMURED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
                                   IMXLEF=IPRRIG
            IF (IDIAGO.NE.1.OR.IALLAM.EQ.1)
     *                             IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
            DO KPRRIG=KPRSTA(IPRRIG),KPRSTO(IPRRIG),2
C
               DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C
                  DO KPRLEF=LPRSTA(IPRLEF),LPRSTO(IPRLEF),2
C
                     IF (I_HEAD.EQ.0.AND.IKEPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IEVEN_.EQ.1) THEN
C
                     HAFLIN(1)='    IL    KL  L    IR    KR  <||Q||>  '
C
                         ELSE
C
                     HAFLIN(1)='  IL    KL    L  IR    KR    <||Q||>  '
C
                         END IF
C
                         WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                      1H*,1X,'' REDUCED  K E R N E L S  OF  '',
     *                                                 A45,2X,1H*,/,
     *                      1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                             '' VALUES LARGER THAN'',1PE10.3,
     *                             '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                      1H*,1X,'' THE TOTAL NUMBER OF  KERNELS '',
     *                             '' CALCULATED IS ='',I7,
     *                             '' AND NDREDU ='',I8,   2X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                              79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                        1H*,A38,1H*,A38,1H*,/,
     *                                        1H*,38X,1H*,38X,1H*)')
     *                      NAMWRK,QMUCUT,NUREDU,NDREDU,
     *                      HAFLIN(1),HAFLIN(1)
C
                         I_HEAD=1
C
                     END IF
C
                     NUREDU=INDRED(IND_IK(IPRLEF,KPRLEF),LAMBDA,
     *                             IND_IK(IPRRIG,KPRRIG))
C
                     IF (IKEPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REAL(REDQ_P(NUREDU))).GT.QMUCUT) THEN
C
                         I_HALF=I_HALF+1
C
                         REEFIX=REAL(REDQ_P(NUREDU))
C
                         IF (ABS(REEFIX).GE.1E-3.AND.
     *                       ABS(REEFIX).LT.1E+2) THEN
C
                             WRITE(REEFIC,'(F9.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE9.1))') REEFIX
C
                         END IF
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(2(I4,A2),I3,2(I4,A2),A9,2X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KPRLEF/IEVEN_,CHALF_,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KPRRIG/IEVEN_,CHALF_,
     *                      REEFIC
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NMURED) THEN
C
             IF (I_HALF.EQ.1) WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)')
     *                                                         HAFLIN(1)
C
             IF (IKEPRI.GT.0) WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
         END IF
C
      END DO
C
C=======================================================================
C         PRINTING THE REDUCED KERNELS OF MAGNETIC OPERATORS
C=======================================================================
C
      NAMWRK=NAMMAG
C
C=======================================================================
C         LOOP OVER RADIAL MOMENTS NOT INDENTED
C=======================================================================
C
      DO NUMORD=0,NMAORD
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=1,NMARED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
                                   IMXLEF=IPRRIG
            IF (IDIAGO.NE.1.OR.IALLAM.EQ.1)
     *                             IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
            DO KPRRIG=KPRSTA(IPRRIG),KPRSTO(IPRRIG),2
C
               DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C
                  DO KPRLEF=LPRSTA(IPRLEF),LPRSTO(IPRLEF),2
C
                     IF (I_HEAD.EQ.0.AND.IKEPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IEVEN_.EQ.1) THEN
C
                     HAFLIN(1)='    IL    KL  L    IR    KR  <||M||>  '
C
                         ELSE
C
                     HAFLIN(1)='  IL    KL    L  IR    KR    <||M||>  '
C
                         END IF
C
                         IF (NUMORD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' REDUCED  K E R N E L S  OF  ''
     *                                                    ,A45,2X,1H*,/,
     *                          1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                                 '' VALUES LARGER THAN'',1PE10.3,
     *                                 '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          NAMWRK,QMACUT,HAFLIN(1),HAFLIN(1)
C
                         ELSE
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' RADIAL MOMENTS ORDER N='',I1,
     *                                            '' OF '',A45,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          2*NUMORD,NAMMAR,HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         I_HEAD=1
C
                     END IF
C
                     NUREDU=INDRED(IND_IK(IPRLEF,KPRLEF),LAMBDA,
     *                             IND_IK(IPRRIG,KPRRIG))
C
                     IF (IKEPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REAL(REDM_P(NUREDU,NUMORD))).GT.QMACUT)THEN
C
                         I_HALF=I_HALF+1
C
                         REEFIX=REAL(REDM_P(NUREDU,NUMORD))
C
                         IF (ABS(REEFIX).GE.1E-3.AND.
     *                       ABS(REEFIX).LT.1E+2) THEN
C
                             WRITE(REEFIC,'(F9.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE9.1))') REEFIX
C
                         END IF
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(2(I4,A2),I3,2(I4,A2),A9,2X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KPRLEF/IEVEN_,CHALF_,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KPRRIG/IEVEN_,CHALF_,
     *                      REEFIC
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NMARED) THEN
C
             IF (I_HALF.EQ.1) WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)')
     *                                                         HAFLIN(1)
C
             IF (IKEPRI.GT.0) WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
         END IF
C
      END DO
C
      END DO
C
C=======================================================================
C         PRINTING THE REDUCED KERNELS OF SPIN-ASYMMETRY OPERATORS
C=======================================================================
C
      NAMWRK=NAMASM
C
C=======================================================================
C         LOOP OVER RADIAL MOMENTS NOT INDENTED
C=======================================================================
C
      DO NUMORD=0,NASORD
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=1,NASRED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
                                   IMXLEF=IPRRIG
            IF (IDIAGO.NE.1.OR.IALLAM.EQ.1)
     *                             IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
            DO KPRRIG=KPRSTA(IPRRIG),KPRSTO(IPRRIG),2
C
               DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C
                  DO KPRLEF=LPRSTA(IPRLEF),LPRSTO(IPRLEF),2
C
                     IF (I_HEAD.EQ.0.AND.IKEPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IEVEN_.EQ.1) THEN
C
                     HAFLIN(1)='    IL    KL  L    IR    KR  <||M||>  '
C
                         ELSE
C
                     HAFLIN(1)='  IL    KL    L  IR    KR    <||M||>  '
C
                         END IF
C
                         IF (NUMORD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' REDUCED  K E R N E L S  OF  ''
     *                                                    ,A45,2X,1H*,/,
     *                          1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                                 '' VALUES LARGER THAN'',1PE10.3,
     *                                 '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          NAMWRK,QASCUT,HAFLIN(1),HAFLIN(1)
C
                         ELSE
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' RADIAL MOMENTS ORDER N='',I1,
     *                                            '' OF '',A45,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          2*NUMORD,NAMASR,HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         I_HEAD=1
C
                     END IF
C
                     NUREDU=INDRED(IND_IK(IPRLEF,KPRLEF),LAMBDA,
     *                             IND_IK(IPRRIG,KPRRIG))
C
                     IF (IKEPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REAL(REDA_T(NUREDU,NUMORD))).GT.QASCUT)THEN
C
                         I_HALF=I_HALF+1
C
                         REEFIX=REAL(REDA_T(NUREDU,NUMORD))
C
                         IF (ABS(REEFIX).GE.1E-3.AND.
     *                       ABS(REEFIX).LT.1E+2) THEN
C
                             WRITE(REEFIC,'(F9.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE9.1))') REEFIX
C
                         END IF
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(2(I4,A2),I3,2(I4,A2),A9,2X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KPRLEF/IEVEN_,CHALF_,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KPRRIG/IEVEN_,CHALF_,
     *                      REEFIC
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NASRED) THEN
C
             IF (I_HALF.EQ.1) WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)')
     *                                                         HAFLIN(1)
C
             IF (IKEPRI.GT.0) WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
         END IF
C
      END DO
C
      END DO
C
C=======================================================================
C         PRINTING THE REDUCED KERNELS OF SURFACE OPERATORS
C=======================================================================
C
                       NAMWRK=NAMSUR
      IF (ISCHIF.EQ.1) STOP ' ISCHIF=1 NOT ALLOWED IN PROANG'
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=NSIMIN,NSIRED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
                                   IMXLEF=IPRRIG
            IF (IDIAGO.NE.1.OR.IALLAM.EQ.1)
     *                             IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
            DO KPRRIG=KPRSTA(IPRRIG),KPRSTO(IPRRIG),2
C
               DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C
                  DO KPRLEF=LPRSTA(IPRLEF),LPRSTO(IPRLEF),2
C
                     IF (I_HEAD.EQ.0.AND.IKEPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IEVEN_.EQ.1) THEN
C
                     HAFLIN(1)='    IL    KL  L    IR    KR  <||S||>  '
C
                         ELSE
C
                     HAFLIN(1)='  IL    KL    L  IR    KR    <||S||>  '
C
                         END IF
C
                         WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                      1H*,1X,'' REDUCED  K E R N E L S  OF  '',
     *                                                 A45,2X,1H*,/,
     *                      1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                             '' VALUES LARGER THAN'',1PE10.3,
     *                             '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                              79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                        1H*,A38,1H*,A38,1H*,/,
     *                                        1H*,38X,1H*,38X,1H*)')
     *                      NAMWRK,QSICUT,HAFLIN(1),HAFLIN(1)
C
                         I_HEAD=1
C
                     END IF
C
                     NUREDU=INDRED(IND_IK(IPRLEF,KPRLEF),LAMBDA,
     *                             IND_IK(IPRRIG,KPRRIG))
C
                     IF (IKEPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REAL(REDS_P(NUREDU))).GT.QSICUT) THEN
C
                         I_HALF=I_HALF+1
C
                         REEFIX=REAL(REDS_P(NUREDU))
C
                         IF (ABS(REEFIX).GE.1E-3.AND.
     *                       ABS(REEFIX).LT.1E+2) THEN
C
                             WRITE(REEFIC,'(F9.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE9.1))') REEFIX
C
                         END IF
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(2(I4,A2),I3,2(I4,A2),A9,2X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KPRLEF/IEVEN_,CHALF_,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KPRRIG/IEVEN_,CHALF_,
     *                      REEFIC
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NSIRED) THEN
C
             IF (I_HALF.EQ.1) WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)')
     *                                                         HAFLIN(1)
C
             IF (IKEPRI.GT.0) WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
         END IF
C
      END DO
C
C=======================================================================
C                    PRINTING THE SUM RULES
C=======================================================================
C
      IF (MOD(IPRKER/10,10).EQ.1) THEN
C
          WRITE(NFIPRI,892) RKER_T,RSKY_T,RKIN_T,RCOU_D,RCOU_X
 892      FORMAT(/,
     *    'ORTHOGONALITY FOR OVERLAP DECOMPOSITION:',2F16.12,/,
     *    'ORTHOGONALITY FOR SKYRME  DECOMPOSITION:',2F16.6,/,
     *    'ORTHOGONALITY FOR EKINET  DECOMPOSITION:',2F16.6,/,
     *    'ORTHOGONALITY FOR COUL_D  DECOMPOSITION:',2F16.6,/,
     *    'ORTHOGONALITY FOR COUL_X  DECOMPOSITION:',2F16.6,/,
     *       2X,'----------------------------------')
C
          DO LAMBDA=0,NMURED
             DO MIU=-LAMBDA,LAMBDA
C
                NIU=IABS(MIU)
C
                WRITE(NFIPRI,'(2I4,2E22.14,2X,2E22.14)') LAMBDA,MIU,
     *                         RMUL_P(LAMBDA,MIU)*QUNITS(LAMBDA,NIU),
     *                         RMAG_T(LAMBDA,MIU)*AUNITS(LAMBDA,NIU)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
C         ATTENTION: UP TO VERSION 2.91, STATEMENTS BELOW WERE MODIFYING
C                    THE INPUT VARIABLES "CUTOVE"  AND  "CUTOVF",  WHICH
C                    WAS VIOLATING THE INPUT-VARIABLE RULES.THIS BUG WAS
C                    CORRECTED ON 10/07/2019 IN VERSION (2.90A).
C=======================================================================
C
      IF (LPROJJ.EQ.0) THEN
          CUTOWE=EPSISO
          CUTOWF=0
      ELSE
          CUTOWE=CUTOVE
          CUTOWF=CUTOVF
      END IF
C
C=======================================================================
C                     CALCULATING THE MIXING
C=======================================================================
C
      IF (IPROAN.EQ.1.OR.IPROAN.EQ.2) THEN
C
C=======================================================================
C         HERE WE DO THE K-MIXING
C=======================================================================
C
          IF (IDIAGO.EQ.1) THEN
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.75M AND 3.04N,  CONDITION  BELOW
C                    WAS INCORRECTLY CODED. AS A RESULT, FOR THE ISOSPIN
C                    PROJECTION, RESULTS  OF  THE  K-MIXING  CALCULATION
C                    WERE INCORRECT. THIS BUG WAS CORRECTED ON 19/4/2021
C                    IN VERSION 3.04O.
C=======================================================================
C
              IF (NATKNO.EQ.1) THEN
C
                  CALL DIAPRO(JPROMI,JPROMA,KPROJE,IAXIAL,IHALF_,
     *                        JSOSMI,JSOSMA,ISOSTZ,LPROJJ,LPROJT,
     *                                      ICUTOV,CUTOWE,CUTOWF,
     *                                      IMIPRI,ISLPRI,ISUPRI,
     *                                             NUISOM,IENPRI,
     *                                             MINDIK,IBETME)
C
                  IF (IWRWAV.EQ.1) THEN
C
                      IWRBLO=2
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.11A) AND  (3.15H), THE ARGUMENT
C                    "ISIMPY" WAS NOT TRANSFERRED TO SUBROUTINE "SAVEWF"
C                    THIS  BUG  WAS  CORRECTED  IN  VERSION  (3.15I)  ON
C                    05/11/2022.
C=======================================================================
C
                      CALL SAVEWF(NFIWAV,ILFWAV,FILWAV,IWRBLO,
     *                                          MINDIK,NUISOM,
     *                                   KPROJE,ISIQTY,ISIMPY,
     *                            IDSIQN,IDSIQP,IDSIZN,IDSIZP)
C
                  END IF
C
              ELSE
C
C=======================================================================
C      IN DIAP3D EPROJE CONTAINS ONLY ISOSCALAR PART OF THE TOTAL ENERGY
C      THE ISOVECTOR AND ISOTENSOR PARTS OF COULOMB ARE ADDED IN DIAP3D
C=======================================================================
C
                  DO INDPRO=1,NUPROM
                     DO INDISO=1,NUISOM
C
                        EPROJE(INDPRO,INDISO)=
     *                  TSK_TT(INDPRO,INDISO)
     *                 +TKI_NT(INDPRO,INDISO)
     *                 +TKI_PT(INDPRO,INDISO)
     *                 +TCO_DT(INDPRO,INDISO)
     *                 +TCO_XT(INDPRO,INDISO)
C
                        ISOSAC=ISOMAT(INDISO)
                        LSOSAC=LSOMAT(INDISO)
                        KSOSAC=KSOMAT(INDISO)
C
                     END DO
                  END DO
C
                  CALL DIAP3D(JPROMI,JPROMA,KPROJE,KPLEFT,IAXIAL,LPROJJ,
     *                        JSOSMI,JSOSMA,ISOSTZ,IAXIAT,LPROJT,
     *                               IHALF_,ICUTOV,CUTOWE,CUTOWF,
     *                                      IMIPRI,ISLPRI,ISUPRI,
     *                                                    IENPRI,
     *                                             MINDIK,IBETME)
C
              END IF
C
          END IF
C
C=======================================================================
C         CALCULATING THE REDUCED MATRIX ELEMENTS FOR THE K-MIXED STATES
C=======================================================================
C
          IF (LPROJJ.EQ.1.AND.LPROJT.EQ.0.AND.IRMPRI.EQ.1) THEN
C
              CALL REDPRO(JPROMI,JPROMA,KPROJE,KPLEFT,IAXIAL,IHALF_,
     *                    ISCHIF,NMURED,NMARED,NASRED,NSIRED,NSIMIN,
     *                           ILFWAV,IRGWAV,NFIWAV,FILWAV,
     *                    IDIAGO,IRMPRI,IELPRI,ISLPRI,ISUPRI,
     *                    LPROJJ,IWRIRM,NFIRED,NMAORD,NASORD,
     *                    MINDIK,NUISOM,QMUCUT,QMACUT,QASCUT,QSICUT)
C
          END IF
C
C=======================================================================
C         HERE WE DO THE CONFIGURATION MIXING
C=======================================================================
C
      ELSE IF (IPROAN.EQ.3) THEN
C
          IF (IDIAGO.EQ.0) THEN
C
C=======================================================================
C             PRINT/STORE MATRIX ELEMENTS FOR FURTHER CONFIGURATION
C             MIXING CALCULATIONS:
C=======================================================================
C
C             IT=0
C             DO ISOSAC=ISOSMI,ISOSMA,2
C             IT=IT+1
C
              DO INDISO=1,NUISOM
C
                 ISOSAC=ISOMAT(INDISO)
C
                 LPROIN=0
C
                 DO LPROAC=LPRSTA(IIFERR),LPRSTO(IIFERR),2
C
                    LPROIN=LPROIN+1
                    KPROIN=0
C
                    DO KPROAC=KPRSTA(IIFERR),KPRSTO(IIFERR),2
C
                       KPROIN=KPROIN+1
C
                       IF (ICMPRI.GE.3)
     *                     WRITE(*,631)
     *                     ISOSAC/IEVEN_,CHALF_,IIFERR/IEVEN_,CHALF_,
     *                     LPROAC/IEVEN_,CHALF_,KPROAC/IEVEN_,CHALF_,
     *                     TKE_TT(INDIMK(IIFERR,LPROAC,KPROAC),INDISO),
     *                     EPROJE(INDIMK(IIFERR,LPROAC,KPROAC),INDISO)
C
 631                   FORMAT(1H*,4(I3,A2),4F14.6,1X,1H*)
C
                       IF (ICOMIX.EQ.1) THEN
                           OVEMIX(INLWAV,INRWAV,LPROIN,KPROIN,INDISO)=
     *                      TKE_TT(INDIMK(IIFERR,LPROAC,KPROAC),INDISO)
                           ESKMIX(INLWAV,INRWAV,LPROIN,KPROIN,INDISO)=
     *                      TSK_TT(INDIMK(IIFERR,LPROAC,KPROAC),INDISO)
                           IF (INLWAV.NE.INRWAV)
     *                     OVEMIX(INRWAV,INLWAV,KPROIN,LPROIN,INDISO)=
     *                 CONJG(OVEMIX(INLWAV,INRWAV,LPROIN,KPROIN,INDISO))
                           IF (INLWAV.NE.INRWAV)
     *                     ESKMIX(INRWAV,INLWAV,KPROIN,LPROIN,INDISO)=
     *                 CONJG(ESKMIX(INLWAV,INRWAV,LPROIN,KPROIN,INDISO))
                       END IF
C
                    END DO
                 END DO
              END DO
C
              OCNMIX(INDBRA,INDKET)=C_ZERO
              HCNMIX(INDBRA,INDKET)=C_ZERO
              CODMIX(INDBRA,INDKET)=C_ZERO
              COXMIX(INDBRA,INDKET)=C_ZERO
C
C             ITL=0
C             DO ISOSAL=ISOSMI,ISOSMA,2
C             ITL=ITL+1
C
C                ITR=0
C                DO ISOSAR=ISOSMI,ISOSMA,2
C                ITR=ITR+1
C
              DO INDISL=1,NUISOM
C
                 ISOSAL=ISOMAT(INDISL)
C
                 DO INDISR=1,NUISOM
C
                    ISOSAR=ISOMAT(INDISR)
C
                    DO LPROAC=LPRSTA(IIFERR),LPRSTO(IIFERR),2
                       DO KPROAC=KPRSTA(IIFERR),KPRSTO(IIFERR),2
C
                          IF (INDISL.EQ.INDISR) THEN
                              OCNMIX(INDBRA,INDKET)=
     *                        OCNMIX(INDBRA,INDKET)+
     *                        CONJG(F_KT_L(LPROAC,INDISL,0))*
     *                        F_KT_R(KPROAC,INDISR,0)*
     *                      TKE_TT(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)
C
                              HCNMIX(INDBRA,INDKET)=
     *                        HCNMIX(INDBRA,INDKET)+
     *                        CONJG(F_KT_L(LPROAC,INDISL,0))*
     *                        F_KT_R(KPROAC,INDISR,0)*
     *                     (TSK_TT(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)
     *                     +TKI_NT(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)
     *                     +TKI_PT(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)
     *                     +TCO_DT(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)
     *                     +TCO_XT(INDIMK(IIFERR,LPROAC,KPROAC),INDISR))
C
                              CODMIX(INDBRA,INDKET)=
     *                        CODMIX(INDBRA,INDKET)+
     *                        CONJG(F_KT_L(LPROAC,INDISL,0))*
     *                        F_KT_R(KPROAC,INDISR,0)*
     *                      TCO_DT(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)
C
                              COXMIX(INDBRA,INDKET)=
     *                        COXMIX(INDBRA,INDKET)+
     *                        CONJG(F_KT_L(LPROAC,INDISL,0))*
     *                        F_KT_R(KPROAC,INDISR,0)*
     *                      TCO_XT(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)
C
                          END IF
C
                         E_10=CGCOEF(ISOSAR,ISOSTZ  ,2, 0,ISOSAL,ISOSTZ)
                         E11P=CGCOEF(ISOSAR,ISOSTZ-2,2, 2,ISOSAL,ISOSTZ)
                         E11M=CGCOEF(ISOSAR,ISOSTZ+2,2,-2,ISOSAL,ISOSTZ)
                         E_20=CGCOEF(ISOSAR,ISOSTZ  ,4, 0,ISOSAL,ISOSTZ)
                         E21P=CGCOEF(ISOSAR,ISOSTZ-2,4, 2,ISOSAL,ISOSTZ)
                         E21M=CGCOEF(ISOSAR,ISOSTZ+2,4,-2,ISOSAL,ISOSTZ)
                         E22P=CGCOEF(ISOSAR,ISOSTZ-4,4, 4,ISOSAL,ISOSTZ)
                         E22M=CGCOEF(ISOSAR,ISOSTZ+4,4,-4,ISOSAL,ISOSTZ)
C
                          E211P=E_10*E11P
                          E211M=E_10*E11M
C
                          E221P=E_20*E21P
                          E221M=E_20*E21M
                          E222P=E_20*E22P
                          E222M=E_20*E22M
C
                          E2_10=E_10*E_10
                          E2_20=E_20*E_20
C
                          HCNMIX(INDBRA,INDKET)=HCNMIX(INDBRA,INDKET)+
     *                    CONJG(F_KT_L(LPROAC,INDISL,0))*
     *                    F_KT_R(KPROAC,INDISR,0)*
     *               (TC1_D0(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E2_10
     *               +TC1_DP(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E211P
     *               +TC1_DM(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E211M
     *               +TC2_D0(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E2_20
     *               +TC21DP(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E221P
     *               +TC21DM(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E221M
     *               +TC22DP(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E222P
     *               +TC22DM(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E222M
     *               +TC1_X0(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E2_10
     *               +TC1_XP(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E211P
     *               +TC1_XM(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E211M
     *               +TC2_X0(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E2_20
     *               +TC21XP(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E221P
     *               +TC21XM(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E221M
     *               +TC22XP(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E222P
     *               +TC22XM(INDIMK(IIFERR,LPROAC,KPROAC),INDISR)*E222M)
C
                       END DO
                    END DO
                 END DO
              END DO
C
              OCNMIX(INDKET,INDBRA)=CONJG(OCNMIX(INDBRA,INDKET))
              HCNMIX(INDKET,INDBRA)=CONJG(HCNMIX(INDBRA,INDKET))
              CODMIX(INDKET,INDBRA)=CONJG(CODMIX(INDBRA,INDKET))
              COXMIX(INDKET,INDBRA)=CONJG(COXMIX(INDBRA,INDKET))
C
              IF (ICMPRI.GE.2)
     *            WRITE(*,632) INDBRA,INDKET,OCNMIX(INDBRA,INDKET),
     *                                       HCNMIX(INDBRA,INDKET)
 632              FORMAT(1H*,5X,2(I3),2F16.10,2F14.6,6X,1H*)
C
              IF (KONMIX.EQ.1) CALL CONMIX(INDKET,ICMPRI,NFIFER,FILFER,
     *                                            IEVEN_,CHALF_,JSOSMI,
     *                                     JSOSMA,ISOSTZ,IIFERR,EPSMIX)
C
          END IF
C
C=======================================================================
C         MULTI-REFERENCE DIAGONALIZATION
C=======================================================================
C
      ELSE IF (IPROAN.EQ.4.OR.IPROAN.EQ.5) THEN
C
C=======================================================================
C         FOR IPROAN=4, SUBROUTINE "PROANG" IS CALLED IN THE DOUBLE LOOP
C         OVER THE LEFT AND RIGHT SINGLE-REFERENCE STATES, FOR WHICH ALL
C         KERNELS ARE SUPPOSED TO HAVE ALREADY BEEN CALCULATED.
C         IN THE FIRST CALL  TO  "PROANG",  THE  SIZES  OF  ARRAYS  THAT
C         COLLECT THE DIAGONAL (NMRMIX) OR OFF-DIAGONAL (LMRMIX)  MATRIX
C         ELEMENTS ARE SET EITHER TO:
C         THE PREDEFINED VALUES OF ...... (FOR I_PASS=1) OR TO
C         THE CALCULATED VALUES OF ...... (FOR I_PASS=2).
C         THE LATTER VALUES ARE CALCULATED ONLY IF THE FORMER ONES  TURN
C         OUT TO BE INSUFFICIENT.
C=======================================================================
C         FOR IPROAN=5, SUBROUTINE "PROANG" WILL BE CALLED FOR MULTI
C         MULTI-REFERENCE STATES (NOT IMPLEMENTED YET).
C=======================================================================
C
          IF (IPROAN.EQ.5) STOP 'IPROAN=5 NOT IMPLEMENTED YET'
C
          IF (N_CALL.EQ.1) THEN
              IF (I_PASS.EQ.1) THEN
C
C                 THE PREDEFINED VALUES OF SIZES:
C
                  NMRMIX=3000
                  LMRMIX=10000
C
              ELSE
                  DEALLOCATE (OMRMIX,EMRMIX,QMRMIX,AMRMIX,WMRMIX,SMRMIX)
                  IF (ICOUMD.GE.1)
     *            DEALLOCATE (DMRMIX)
                  IF (ICOUMX.GE.1)
     *            DEALLOCATE (XMRMIX)
                  DEALLOCATE (NMATMI,LMATMI)
C
C                 THE CALCULATED VALUES OF SIZES:
C
                  NMRMIX=NMURMI
                  LMRMIX=LMURMI
C
              END IF
C
              NMURMI=0
C
          END IF
C
          IF (.NOT.ALLOCATED(OMRMIX)) THEN
              ALLOCATE (OMRMIX(0:NMRMIX)
     *                                                     ,STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('OMRMIX','PROANG')
          END IF
C
          IF (.NOT.ALLOCATED(EMRMIX)) THEN
              ALLOCATE (EMRMIX(0:NMRMIX)
     *                                                     ,STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('EMRMIX','PROANG')
          END IF
C
          IF (ICOUMD.GE.1.AND..NOT.ALLOCATED(DMRMIX)) THEN
              ALLOCATE (DMRMIX(0:NMRMIX)
     *                                                     ,STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('DMRMIX','PROANG')
          END IF
C
          IF (ICOUMX.GE.1.AND..NOT.ALLOCATED(XMRMIX)) THEN
              ALLOCATE (XMRMIX(0:NMRMIX)
     *                                                     ,STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('XMRMIX','PROANG')
          END IF
C
          IF (.NOT.ALLOCATED(NMATMI)) THEN
              ALLOCATE (NMATMI(0:NDPROI,0:NDISOM,
     *                         1:NDCONF,1:NDCONF,
     *                         1:NDCOLE,1:NDCOLE),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('NMATMI','PROANG')
              NMATMI=0
          END IF
C
          IF (.NOT.ALLOCATED(QMRMIX)) THEN
              ALLOCATE (QMRMIX(0:LMRMIX),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('QMRMIX','PROANG')
          END IF
C
          IF (.NOT.ALLOCATED(AMRMIX)) THEN
              ALLOCATE (AMRMIX(0:LMRMIX),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('AMRMIX','PROANG')
          END IF
C
          IF (.NOT.ALLOCATED(WMRMIX)) THEN
              ALLOCATE (WMRMIX(0:LMRMIX),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('WMRMIX','PROANG')
          END IF
C
          IF (.NOT.ALLOCATED(SMRMIX)) THEN
              ALLOCATE (SMRMIX(0:LMRMIX),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('SMRMIX','PROANG')
          END IF
C
          IF (.NOT.ALLOCATED(LMATMI)) THEN
              ALLOCATE (LMATMI(0:NDPROI,0:NDLAMB,0:NDPROI,
     *                         1:NDCONF,1:NDCONF,
     *                         1:NDCOLE,1:NDCOLE),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('LMATMI','PROANG')
              LMATMI=0
          END IF
C
C=======================================================================
C         READING THE K-MIXING COEFFICIENTS. THE WAVE-FUNCTION FILES
C         WITH NUMBERS "INLWAV" AND "INRWAV" MUST CONTAIN PREVIOUSLY
C         SAVED BLOCKS 2.
C=======================================================================
C
          IWRBLO=2
C
          CALL READWF(NFIWAV,INRWAV,FILWAV,IWRBLO,MINDIK,1,KPLEFT)
C
          WAVPRO=WAVLEF
          NUMPRO=NUMLEF
          KPRIGH=KPLEFT
C
          MIXCOL(:,:,INRWAV)=NUMPRO(:,:)
C
          CALL READWF(NFIWAV,INLWAV,FILWAV,IWRBLO,MINDIK,1,KPLEFT)
C
C=======================================================================
C         FILLING ARRAYS "OMRMIX" AND "EMRMIX" WITH OVERLAPS AND  ENERGY
C         MATRIX ELEMENTS, RESPECTIVELY, THAT CORRESPOND TO  THE  MULTI-
C         REFERENCE DIAGONALIZATION.
C         FILLING ARRAYS "DMRMIX" AND "XMRMIX" WITH THE DIRECT AND
C         EXCHANGE COULOMB MATRIX ELEMENTS, IF REQUESTED.
C=======================================================================
C
          OMRMIX(0)=C_ZERO
          EMRMIX(0)=C_ZERO
          IF (ICOUMD.GE.1) DMRMIX(0)=C_ZERO
          IF (ICOUMX.GE.1) XMRMIX(0)=C_ZERO
C
          DO INDISO=1,NUISOM
C
             DO IPROAC=JPROMI,JPROMA,2
C
C=======================================================================
C              HERE WE COUNT THE TOTAL NUMBER OF SINGLE-REFERENCE  RIGHT
C              STATES THAT WILL CONTRIBUTE TO THE MIXING  IN  ALL  SPINS
C=======================================================================
C
                DO INRCOL=1,NUMPRO(IPROAC,INDISO)
C
                   DO INLCOL=1,NUMLEF(IPROAC,INDISO)
C
                      IF (NMURMI.LT.NMRMIX) THEN
C
C                         HERE THE SIZES OF ARRAYS "OMRMIX" AND "EMRMIX"
C                         ARE  STILL  SUFFICIENT  AND  THE  SECOND  PASS
C                         THROUGH THE SINGLE-REFERENCE LOOPS WILL NOT BE
C                         REQUIRED.
C
                          NMURMI=NMURMI+1
                          NINDMI=NMURMI
                          I_PASS=1
C
                      ELSE
C
C                         HERE THE SIZES ABOVE ARE INSUFFICIENT AND  THE
C                         SECOND PASS THROUGH THE SINGLE-REFERENCE LOOPS
C                         WILL BE REQUIRED.
C
                          NMURMI=NMURMI+1
                          NINDMI=0
                          I_PASS=2
C
                      END IF
C
                      IF (IPROAC.GT.NDPROI)
     *                               STOP 'INCRESE NDPROI (1) IN PROANG'
                      IF (INDISO.GT.NDISOM)
     *                               STOP 'INCRESE NDISOM (1) IN PROANG'
                      IF (INLWAV.GT.NDCONF)
     *                               STOP 'INCRESE NDCONF (1) IN PROANG'
                      IF (INRWAV.GT.NDCONF)
     *                               STOP 'INCRESE NDCONF (1) IN PROANG'
                      IF (INLCOL.GT.NDCOLE)
     *                               STOP 'INCRESE NDCOLE (1) IN PROANG'
                      IF (INRCOL.GT.NDCOLE)
     *                               STOP 'INCRESE NDCOLE (1) IN PROANG'
C
                      NMATMI(IPROAC,INDISO,INLWAV,INRWAV,INLCOL,INRCOL)=
     *                                                            NMURMI
                      OMRMIX(NINDMI)=C_ZERO
                      EMRMIX(NINDMI)=C_ZERO
                      IF (ICOUMD.GE.1) DMRMIX(NINDMI)=C_ZERO
                      IF (ICOUMX.GE.1) XMRMIX(NINDMI)=C_ZERO
C
                      DO LPROAC=LPRSTA(IPROAC),LPRSTO(IPROAC),2
                         DO KPROAC=KPRSTA(IPROAC),KPRSTO(IPROAC),2
C
                            OMRMIX(NINDMI)=OMRMIX(NINDMI)+
     *                      OPROJE(INDIMK(IPROAC,LPROAC,KPROAC),INDISO)
     *               *CONJG(WAVLEF(IND_IK(IPROAC,LPROAC),INLCOL,INDISO))
     *                     *WAVPRO(IND_IK(IPROAC,KPROAC),INRCOL,INDISO)
C
                            EMRMIX(NINDMI)=EMRMIX(NINDMI)+
     *                      EPROJE(INDIMK(IPROAC,LPROAC,KPROAC),INDISO)
     *               *CONJG(WAVLEF(IND_IK(IPROAC,LPROAC),INLCOL,INDISO))
     *                     *WAVPRO(IND_IK(IPROAC,KPROAC),INRCOL,INDISO)
C
                            IF (ICOUMD.GE.1)
     *                      DMRMIX(NINDMI)=DMRMIX(NINDMI)+
     *                      TCO_DT(INDIMK(IPROAC,LPROAC,KPROAC),INDISO)
     *               *CONJG(WAVLEF(IND_IK(IPROAC,LPROAC),INLCOL,INDISO))
     *                     *WAVPRO(IND_IK(IPROAC,KPROAC),INRCOL,INDISO)
C
                            IF (ICOUMX.GE.1)
     *                      XMRMIX(NINDMI)=XMRMIX(NINDMI)+
     *                      TCO_XT(INDIMK(IPROAC,LPROAC,KPROAC),INDISO)
     *               *CONJG(WAVLEF(IND_IK(IPROAC,LPROAC),INLCOL,INDISO))
     *                     *WAVPRO(IND_IK(IPROAC,KPROAC),INRCOL,INDISO)
C
                         END DO
                      END DO
C
                   END DO
                END DO
C
             END DO
C
          END DO
C
C=======================================================================
C         FILLING ARRAYS "QMRMIX", "AMRMIX", "WMRMIX", AND "SMRMIX" WITH
C         REDUCED MATRIX ELEMENTS OF THE ELECTRIC, MAGNETIC, SPIN-ASYMM,
C         AND SURFACE MOMENTS,  RESPECTIVELY,  THAT  CORRESPOND  TO  THE
C         MULTI-REFERENCE STATES.
C=======================================================================
C
          QMRMIX(0)=C_ZERO
          AMRMIX(0)=C_ZERO
          WMRMIX(0)=C_ZERO
          SMRMIX(0)=C_ZERO
C
          INDISO=1
C
          DO IPRRIG=JPROMI,JPROMA,2
C320j WRITE (*,'(''IPRRIG,JPROMI,JPROMA P='',3I3)') IPRRIG,JPROMI,JPROMA
C
             DO LAMBDA=0,MAX(NMURED,NMARED,NASRED,NSIRED)
C320j WRITE (*,'(''LAMBDA,MAX(NMURED,NMARED,NASRED,NSIRED) P='',3I3)')
C320j*             LAMBDA,MAX(NMURED,NMARED,NASRED,NSIRED)
C
                MAXMIU=LAMBDA
C
                IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
                DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C320j WRITE (*,'(''IPRLEF,MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF P='',3I3)')
C320j*             IPRLEF,MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF
C
                   IF (ILIMAM.NE.1.OR.
     *                 IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                 IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                       DO INRCOL=1,NUMPRO(IPRRIG,INDISO)
C320j WRITE (*,'(''INRCOL,NUMPRO(IPRRIG,INDISO) P='',3I3)')
C320j*             INRCOL,NUMPRO(IPRRIG,INDISO)
                          DO INLCOL=1,NUMLEF(IPRLEF,INDISO)
C320j WRITE (*,'(''INLCOL,NUMLEF(IPRLEF,INDISO) P='',3I3)')
C320j*             INLCOL,NUMLEF(IPRLEF,INDISO)
C
                             IF (LMURMI.LT.LMRMIX) THEN
C
C=======================================================================
C                         HERE THE SIZES OF ARRAYS  "QMRMIX",  "AMRMIX",
C                         "WMRMIX", AND "SMRMIX" ARE  STILL  SUFFICIENT;
C                         THE SECOND PASS THROUGH  THE  SINGLE-REFERENCE
C                         LOOPS WILL NOT BE REQUIRED.
C=======================================================================
C
                                 LMURMI=LMURMI+1
                                 LINDMI=LMURMI
                                 I_PASS=1
C
                             ELSE
C
C=======================================================================
C                         HERE THE SIZES ABOVE ARE INSUFFICIENT AND  THE
C                         SECOND PASS THROUGH THE SINGLE-REFERENCE LOOPS
C                         WILL BE REQUIRED.
C=======================================================================
C
                                 LMURMI=LMURMI+1
                                 LINDMI=0
                                 I_PASS=2
C
                             END IF
C
                             IF (IPRLEF.GT.NDPROI)
     *                               STOP 'INCRESE NDPROI (2) IN PROANG'
                             IF (LAMBDA.GT.NDLAMB)
     *                               STOP 'INCRESE NDLAMB (2) IN PROANG'
                             IF (IPRRIG.GT.NDPROI)
     *                               STOP 'INCRESE NDPROI (2) IN PROANG'
                             IF (INLWAV.GT.NDCONF)
     *                               STOP 'INCRESE NDCONF (2) IN PROANG'
                             IF (INRWAV.GT.NDCONF)
     *                               STOP 'INCRESE NDCONF (2) IN PROANG'
                             IF (INLCOL.GT.NDCOLE)
     *                               STOP 'INCRESE NDCOLE (2) IN PROANG'
                             IF (INRCOL.GT.NDCOLE)
     *                               STOP 'INCRESE NDCOLE (2) IN PROANG'
C
                             LMATMI(IPRLEF,LAMBDA,IPRRIG,INLWAV,INRWAV,
     *                                            INLCOL,INRCOL)=LMURMI
C
                             QMRMIX(LINDMI)=C_ZERO
                             AMRMIX(LINDMI)=C_ZERO
                             WMRMIX(LINDMI)=C_ZERO
                             SMRMIX(LINDMI)=C_ZERO
C
                             DO KPRLEF=LPRSTA(IPRLEF),
     *                                 LPRSTO(IPRLEF),2
C320j WRITE (*,'(''KPRLEF,LPRSTA(IPRLEF),LPRSTO(IPRLEF) P='',3I3)')
C320j*             KPRLEF,LPRSTA(IPRLEF),LPRSTO(IPRLEF)
                                DO KPRRIG=KPRSTA(IPRRIG),
     *                                    KPRSTO(IPRRIG),2
C320j WRITE (*,'(''KPRRIG,KPRSTA(IPRRIG),KPRSTO(IPRRIG) P='',3I3)')
C320j*             KPRRIG,KPRSTA(IPRRIG),KPRSTO(IPRRIG)
C
                                   NUREDU=INDRED(IND_IK(IPRLEF,KPRLEF),
     *                                    LAMBDA,IND_IK(IPRRIG,KPRRIG))
C
                                   QMRMIX(LINDMI)=QMRMIX(LINDMI)+
     *                             REDQ_P(NUREDU)
     *                            *CONJG(WAVLEF(IND_IK(IPRLEF,KPRLEF),
     *                                                 INLCOL,INDISO))
     *                                  *WAVPRO(IND_IK(IPRRIG,KPRRIG),
     *                                                 INRCOL,INDISO)
C
                                   AMRMIX(LINDMI)=AMRMIX(LINDMI)+
     *                             REDM_P(NUREDU,0)
     *                            *CONJG(WAVLEF(IND_IK(IPRLEF,KPRLEF),
     *                                                 INLCOL,INDISO))
     *                                  *WAVPRO(IND_IK(IPRRIG,KPRRIG),
     *                                                 INRCOL,INDISO)
C
                                   IF (NASORD.GE.0)
     *                             WMRMIX(LINDMI)=WMRMIX(LINDMI)+
     *                             REDA_T(NUREDU,0)
     *                            *CONJG(WAVLEF(IND_IK(IPRLEF,KPRLEF),
     *                                                 INLCOL,INDISO))
     *                                  *WAVPRO(IND_IK(IPRRIG,KPRRIG),
     *                                                 INRCOL,INDISO)
C
                                   SMRMIX(LINDMI)=SMRMIX(LINDMI)+
     *                             REDS_P(NUREDU)
     *                            *CONJG(WAVLEF(IND_IK(IPRLEF,KPRLEF),
     *                                                 INLCOL,INDISO))
     *                                  *WAVPRO(IND_IK(IPRRIG,KPRRIG),
     *                                                 INRCOL,INDISO)
C
C320j WRITE (*,
C320j*'(''I_PASS,IPRRIG,LAMBDA,IPRLEF,INLWAV,INRWAV,INLCOL,INRCOL,'',
C320j*  ''KPRLEF,KPRRIG,NUREDU,LINDMI,LMURMI'',13I4,/,
C320j*    7X,4(''('',2E10.3,'')''))')
C320j*    I_PASS,IPRRIG,LAMBDA,IPRLEF,INLWAV,INRWAV,INLCOL,INRCOL,
C320j*    KPRLEF,KPRRIG,NUREDU,LINDMI,LMURMI,
C320j*    QMRMIX(LINDMI),AMRMIX(LINDMI),WMRMIX(LINDMI),SMRMIX(LINDMI)
C
                                END DO
                             END DO
C
C=======================================================================
C                            HERE WE SYMMETRIZE ARRAYS  OF  THE  REDUCED
C                            MATRIX ELEMENTS FOR SINGLE-REFERENCE STATES
C=======================================================================
C
                             IF (INRWAV.NE.INLWAV) THEN !IF NOT INDENTED
C
                             QMRMIY=QMRMIX(LINDMI)
                             AMRMIY=AMRMIX(LINDMI)
                             WMRMIY=WMRMIX(LINDMI)
                             SMRMIY=SMRMIX(LINDMI)
C
                             IF (LMURMI.LT.LMRMIX) THEN
C
C=======================================================================
C                         HERE THE SIZES OF ARRAYS  "QMRMIX",  "AMRMIX",
C                         "WMRMIX", AND "SMRMIX" ARE  STILL  SUFFICIENT;
C                         THE SECOND PASS THROUGH  THE  SINGLE-REFERENCE
C                         LOOPS WILL NOT BE REQUIRED.
C=======================================================================
C
                                 LMURMI=LMURMI+1
                                 LINDMI=LMURMI
                                 I_PASS=1
C
                             ELSE
C
C=======================================================================
C                         HERE THE SIZES ABOVE ARE INSUFFICIENT AND  THE
C                         SECOND PASS THROUGH THE SINGLE-REFERENCE LOOPS
C                         WILL BE REQUIRED.
C=======================================================================
C
                                 LMURMI=LMURMI+1
                                 LINDMI=0
                                 I_PASS=2
C
                             END IF
C
                             LMATMI(IPRRIG,LAMBDA,IPRLEF,INRWAV,INLWAV,
     *                                            INRCOL,INLCOL)=LMURMI
C
                             QMRMIX(LINDMI)=CONJG(QMRMIY)
                             AMRMIX(LINDMI)=CONJG(AMRMIY)
                             WMRMIX(LINDMI)=CONJG(WMRMIY)
                             SMRMIX(LINDMI)=CONJG(SMRMIY)
C
                             END IF ! IF NOT INDENTED
C
C=======================================================================
C                            END OF SYMMETRIZATION
C=======================================================================
C
                          END DO
                       END DO
C
                   END IF
C
                END DO
C
             END DO
C
          END DO
C
C=======================================================================
C         PERFORMING THE MULTI-REFERENCE DIAGONALIZATION
C=======================================================================
C
          IF (KONMIX.EQ.1.AND.I_PASS.EQ.1) THEN
C
              IF (NATKNO.EQ.1) THEN
C
                  CALL DIAMUR(JPROMI,JPROMA,IHALF_,
     *                        LPROJJ,LPROJT,
     *                        ICUTOV,CUTOWE,CUTOWF,
     *                        IMIPRI,ISLPRI,ISUPRI,
     *                                      NUISOM)
C
              ELSE
                  STOP' DIAMUR NOT READY FOR THE ISOSPIN PROJECTION YET'
              END IF
C
C=======================================================================
C        CALCULATING THE REDUCED MATRIX ELEMENTS FOR THE MULTI-REFERENCE
C        STATES
C=======================================================================
C
              IF (LPROJJ.EQ.1.AND.LPROJT.EQ.0.AND.IRMPRI.EQ.1) THEN
C
                  CALL REDMUR(JPROMI,JPROMA,KPROJE,IAXIAL,IHALF_,
     *                        ISCHIF,NMURED,NMARED,NASRED,NSIRED,NSIMIN,
     *                               IDIMUR,IRMPRI,IELPRI,ISLPRI,ISUPRI,
     *                                      IWRIRM,NFIRED,NMAORD,NASORD,
     *                        MINDIK,NUISOM,QMUCUT,QMACUT,QASCUT,QSICUT)
C
              END IF
C
              IF (LPROJJ.EQ.1.AND.LPROJT.EQ.0.AND.
     *           (ICOUMD.GE.1.OR.ICOUMX.GE.1)) THEN
C
                  CALL COUMUR(JPROMI,JPROMA,KPROJE,IAXIAL,IHALF_,
     *                                             ICOUMD,ICOUMX,
     *                        IDIMUR,IRMPRI,IELPRI,ISLPRI,ISUPRI,
     *                                             MINDIK,NUISOM)
C
              END IF
C
          END IF
C
      END IF ! IPROAN.EQ.4
C
C=======================================================================
C            SAVE WAVE FUNCTION FOR FURTHER CALCULATION OF
C            THE FERMI AND/OR GAMOW-TELLER MATRIX ELEMENTS
C                        GENERAL  CASE OF
C                < I,T_i,Tz | T(-/+)/GT(-/+) | I,T_f,Tz+/-1>
C=======================================================================
C
      IF (IBETME.EQ.-1) THEN
C
          CALL SAV_WF(NFIWAV,   998,     1,FILWAV,JSOSMI,JSOSMA,ISOSTZ)
C
      ENDIF
C
      IF (IBETME.GE.1) THEN
C
          CALL BETAME(ISIMPY,IROTAT,MREVER,
     *                              IPAHFB,
     *                ISOSTZ,JSOSMI,JSOSMA,
     *                       NFIWAV,FILWAV,
     *                NUBKNO,NUAKNO,NBTKNO,
     *                       IEVEN_,CHALF_,
     *                       ISOADD,NBTKNT)
      ENDIF
C
   11 CONTINUE
C
C=======================================================================
      DEALLOCATE (OVRLAP)
      DEALLOCATE (WARAUX)
      DEALLOCATE (TARIGH)
      DEALLOCATE (TALEFT)
      DEALLOCATE (OVKERN,SKKERN,EKKERN,EPKERN,QPKERN,ATKERN)
      IF (NASORD.GE.0)
     *    DEALLOCATE (WTKERN)
      DEALLOCATE (CDKERN,CXKERN)
      DEALLOCATE (CDKE10,CDKE1P,CDKE1M)
      DEALLOCATE (CDKE20,CDK21P,CDK21M,CDK22P,CDK22M)
      DEALLOCATE (BNN_PP,BNP_PP,BPP_PP,BPN_PP)
      IF (ISIMPY.NE.1)
     *    DEALLOCATE (BNN_PM,BNP_PM,BPP_PM,BPN_PM)
C
      DEALLOCATE (ZMUL_P,ZMAG_T,ZSIF_P,CMUL_P,CMAG_T,CSIF_P)
C
      IF(IPAHFB.EQ.1.AND.IONISH.NE.1)
     *   DEALLOCATE (TBTALF,TBTARG)
      IF(IPAHFB.EQ.1)
     *   DEALLOCATE (WARITP)
C
      DEALLOCATE (OVTERN,SKTERN,EKTERN,EPTERN,CDTERN)
      DEALLOCATE (CDTE10,CDTE1P,CDTE1M,CDTE20,CDT21P,CDT21M,CDT22P)
      DEALLOCATE (CDT22M,CXTERN,CXTE10,CXTE1P,CXTE1M,CXTE20,CXT21P)
      DEALLOCATE (CXT21M,CXT22P,CXT22M)
      DEALLOCATE (PNTE00,PNTE10,PNTE1P,PNTE1M)
      DEALLOCATE (TZTERN,T2TERN,BZTERN,B2TERN)
C
      IF (IPAKER.EQ.1) GO TO 1021
C
      DEALLOCATE (CKER_T,CSKY_T,CKIN_N,CKIN_P,CCOU_D,CC10_D,CC1P_D)
      DEALLOCATE (CC1M_D,CC20_D,CC21PD,CC21MD,CC22PD,CC22MD,CCOU_X)
      DEALLOCATE (CC10_X,CC1P_X,CC1M_X,CC20_X,CC21PX,CC21MX,CC22PX)
      DEALLOCATE (CC22MX,CPNU00,CPNU10,CPNU1P,CPNU1M)
      DEALLOCATE (CTZISO,CT2ISO,CBZROT,CB2ROT)
      DEALLOCATE (CPAI_N,CPAI_P)
C
      DEALLOCATE (ZKER_T,ZSKY_T,ZKIN_N,ZKIN_P,ZCOU_D,ZC10_D,ZC1P_D)
      DEALLOCATE (ZC1M_D,ZC20_D,ZC21PD,ZC21MD,ZC22PD,ZC22MD,ZCOU_X)
      DEALLOCATE (ZC10_X,ZC1P_X,ZC1M_X,ZC20_X,ZC21PX,ZC21MX,ZC22PX)
      DEALLOCATE (ZC22MX,ZPNU00,ZPNU10,ZPNU1P,ZPNU1M)
      DEALLOCATE (ZTZISO,ZT2ISO,ZBZROT,ZB2ROT)
      DEALLOCATE (ZPAI_N,ZPAI_P)
C
      DEALLOCATE (TMUL_P,TMAG_T,TSIF_P)
C
      DEALLOCATE (TKE_TT,TSK_TT,TKI_NT,TKI_PT,TCO_DT,TCO_XT)
      DEALLOCATE (TPA_NT,TPA_PT)
      DEALLOCATE (TPN_00,TPN_10,TPN_1P,TPN_1M,
     *            TTZ_IS,TT2_IS,TBZ_RO,TB2_RO)
      DEALLOCATE (TC1_D0,TC1_DP,TC1_DM,TC2_D0,
     *            TC21DP,TC21DM,TC22DP,TC22DM)
      DEALLOCATE (TC1_X0,TC1_XP,TC1_XM,TC2_X0,
     *            TC21XP,TC21XM,TC22XP,TC22XM)
C
      DEALLOCATE (TKER_T,TSKY_T,TKIN_N,TKIN_P,TCOU_D,TCOU_X)
      DEALLOCATE (TPAI_N,TPAI_P)
      DEALLOCATE (TPNU00,TPNU10,TPNU1P,TPNU1M,
     *            TTZISO,TT2ISO,TBZROT,TB2ROT)
      DEALLOCATE (TC10_D,TC1P_D,TC1M_D,TC20_D,
     *            TC21PD,TC21MD,TC22PD,TC22MD)
      DEALLOCATE (TC10_X,TC1P_X,TC1M_X,TC20_X,
     *            TC21PX,TC21MX,TC22PX,TC22MX)
C=======================================================================
C
 1021 CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('PROANG',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ADBATI(IPAHFB)
      use ADBATC
C
C=======================================================================
C
      CALL CPUTIM('ADBATI',1)
C
      IF(IPAHFB.EQ.0) CALL atdhf_implementation
      IF(IPAHFB.EQ.1) CALL atdhfb_implementation
C
      CALL CPUTIM('ADBATI',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTOMO(ISIMPY,ISIGNY,ISIQTY,KMULMO,LDBASE,
     *                                IN_FIX,IZ_FIX,NAMHAR)
C
C=======================================================================
      USE hfodd_sizes
      USE MAD_PP
      USE MAD_PM
      USE MAT_PP
      USE MAT_PM
C
C     THIS SUBROUTINE CALCULATES THE MULTIPOLE TOMOGRAPHY WITH RESPECT
C     TO THE POINT SPECIFIED WITH THE KEYWORD 'TOMOGRAPHY'
C
      COMMON
     *       /TOMOPI/ ITOMOZ,IOBSCH,IDESCH,INDENS
C
      COMMON
     *       /TOMOPH/ PTOMOX,PTOMOY,PTOMOZ
C
      COMMON
     *       /TOMSIC/ ITOMSC
      COMMON
     *       /TOMSLC/ P0VECX,P0VECY,P0VECZ,
     *                P1VECX,P1VECY,P1VECZ,
     *                P2VECX,P2VECY,P2VECZ
C
      COMMON
     *       /TOMMEN/ NCMESH
      COMMON
     *       /TOMMES/ PINTSC, PWIDTH, PHEIGH
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
C
      COMMON
     *       /TOMMUL/ TMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                TMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                TMUL_T(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /TOMMUT/ TMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                TMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                TMUT_T(0:NDMULT,-NDMULT:NDMULT)
C
      COMPLEX
     *          TMUT_N,TMUT_P,TMUT_T
C
      CHARACTER
     *          NAMTOM*45,NAMHAR*17
C
      COMMON
     *       /FACHER/ HERFAC(0:ND2MAX)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
C
      DIMENSION
     *          HERX(NDOSCI+1),DHERX(NDOSCI+1),
     *          HERY(NDOSCI+1),DHERY(NDOSCI+1),
     *          HERZ(NDOSCI+1),DHERZ(NDOSCI+1)
C
      COMPLEX RESUPP, RESUPM, RESUMP, RESUMM, RTRACE, PVALUE
C
      REAL DTOMOX, DTOMOY, DTOMOZ, RESU
C
      COMPLEX, ALLOCATABLE :: PHIQPP(:,:,:), PHIQPM(:,:,:)
C
      CHARACTER NAMEPN*8
C
      REAL I2BTCE
C
      REAL, ALLOCATABLE :: PMESHT(:,:)
C
      REAL VTEMP(3), VECTD1(3), VECTD2(3), VECTDN(3), VECTP0(3)
C
      DATA
     *       NAMTOM /'MULTIPOLE TOMOGRAPHY  [UTS:(10 FERMI)^LAMBDA]'/
C
      CALL CPUTIM('INTOMO',1)
C
      ALLOCATE(PHIQPP(1:LDBASE,1:LDBASE,0:1),
     *         PHIQPM(1:LDBASE,1:LDBASE,0:1))
C
      DO ICHARG=0,NDISOS
C
         IF(ITOMOZ.EQ.-1) GOTO 123
C
         DTOMOX=PTOMOX*HOMSCA(1,1)
         DTOMOY=PTOMOY*HOMSCA(2,1)
         DTOMOZ=PTOMOZ*HOMSCA(3,1)
C
C
         ! --- PREPARE PHIQPP/PM ---
         CALL D_HERM(DTOMOX,NDOSCI,HERX,DHERX,NDOSCI+1)
         CALL D_HERM(DTOMOY,NDOSCI,HERY,DHERY,NDOSCI+1)
         CALL D_HERM(DTOMOZ,NDOSCI,HERZ,DHERZ,NDOSCI+1)
C
         DO IL=1,LDBASE
            DO IQ=1,LDBASE
C
               NX_L=NXVECT(IL,1)
               NY_L=NYVECT(IL,1)
               NZ_L=NZVECT(IL,1)
C
               NX_Q=NXVECT(IQ,1)
               NY_Q=NYVECT(IQ,1)
               NZ_Q=NZVECT(IQ,1)
C
               RESU =
     *         HERX(NX_L+1)*HERY(NY_L+1)*HERZ(NZ_L+1) *
     *         HERX(NX_Q+1)*HERY(NY_Q+1)*HERZ(NZ_Q+1) /
     *         HERFAC(NX_L)/HERFAC(NY_L)/HERFAC(NZ_L) /
     *         HERFAC(NX_Q)/HERFAC(NY_Q)/HERFAC(NZ_Q) *
     *         EXP(-DTOMOX**2)*EXP(-DTOMOY**2)*EXP(-DTOMOZ**2) *
     *         HOMSCA(1,1)*HOMSCA(2,1)*HOMSCA(3,1)
C
               PHIQPP(IQ,IL,0)=RESU*IPHAPP(NY_Q,NY_L,0)
               PHIQPP(IQ,IL,1)=RESU*IPHAMM(NY_Q,NY_L,0)
               PHIQPM(IQ,IL,0)=RESU*IPHAPM(NY_Q,NY_L,0)
               PHIQPM(IQ,IL,1)=RESU*IPHAMP(NY_Q,NY_L,0)
C
            ENDDO
         ENDDO
C
         ! --- CONDITIONAL DENSITY MTS ---
         DO IK=1,LDBASE
            DO IP=IK,LDBASE
C
               RESUPP=0.D0
               RESUPM=0.D0
               RESUMP=0.D0
               RESUMM=0.D0
C
               IF (ISIMPY.NE.1) THEN
C
                  DO IL=1,LDBASE
                  DO IQ=1,LDBASE
C
                     RESUPP = RESUPP
C                    ! KPLQ ++++
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ +++-
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,0,ICHARG)
     *                  -DEN_PM(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ ++-+
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PM(IL,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ ++--
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PM(IK,IQ,0,ICHARG)*DEN_PM(IL,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUPM = RESUPM
C                    ! KPLQ +-++
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PM(IL,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ +-+-
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,0,ICHARG)
     *                  -DEN_PM(IK,IQ,0,ICHARG)*DEN_PM(IL,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ +--+
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ +---
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PM(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUMP = RESUMP
C                    ! KPLQ -+++
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PM(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ -++-
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ -+-+
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,1,ICHARG)
     *                  -DEN_PM(IK,IQ,1,ICHARG)*DEN_PM(IL,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ -+--
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PM(IL,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUMM = RESUMM
C                    ! KPLQ --++
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PM(IK,IQ,1,ICHARG)*DEN_PM(IL,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ --+-
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PM(IL,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ ---+
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,1,ICHARG)
     *                  -DEN_PM(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ ----
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                  ENDDO
                  ENDDO
C
               ENDIF
C
               IF (ISIMPY.EQ.1) THEN
C
                  DO IL=1,LDBASE
                  DO IQ=1,LDBASE
C
                     RESUPP = RESUPP
C                    ! KPLQ ++++
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ ++--
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUPM = RESUPM
C                    ! KPLQ +--+
     *               + (-DEN_PP(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C
                     RESUMP = RESUMP
C                    ! KPLQ -++-
     *               + (-DEN_PP(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C
                     RESUMM = RESUMM
C                    ! KPLQ --++
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ ----
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                  ENDDO
                  ENDDO
C
               ENDIF
C
               BIG_PP(IK,IP,0) = RESUPP*2.D0
               BIG_PP(IK,IP,1) = RESUMM*2.D0
               BIG_PP(IP,IK,0) = CONJG(RESUPP)*2.D0
               BIG_PP(IP,IK,1) = CONJG(RESUMM)*2.D0
C
               IF (ISIMPY.NE.1) THEN
                  BIG_PM(IK,IP,0) = RESUPM*2.D0
                  BIG_PM(IK,IP,1) = RESUMP*2.D0
                  BIG_PM(IP,IK,0) = CONJG(RESUMP)*2.D0
                  BIG_PM(IP,IK,1) = CONJG(RESUPM)*2.D0
               ENDIF
C
            ENDDO
         ENDDO
C
         RTRACE=0.D0
C
         DO IK=1,LDBASE
C
            RTRACE = RTRACE + BIG_PP(IK,IK,0)
     *                      + BIG_PP(IK,IK,1)
C
         ENDDO
C
C
         IF (ICHARG.EQ.0) I2BTCE=IN_FIX-1
         IF (ICHARG.EQ.1) I2BTCE=IZ_FIX-1
C
         BIG_PP=BIG_PP/ABS(RTRACE)*I2BTCE
         IF (ISIMPY.NE.1) BIG_PM=BIG_PM/ABS(RTRACE)*I2BTCE
C
         ! --- VISUALIZATION OF CONDITIONAL DENSITY ---
 123     IF (NCMESH.GT.0) THEN
C
            MCMESH=NINT(SQRT(DBLE(NCMESH)))
            DSTEPW=PWIDTH/MCMESH
            DSTEPH=PHEIGH/MCMESH
C
            ALLOCATE(PMESHT((MCMESH+1)*(MCMESH+1),5))
C
            VECTD1=(/PTOMOX,PTOMOY,PTOMOZ/)
            RNORM1=SQRT(DOT_PRODUCT(VECTD1, VECTD1))
C
            IF (RNORM1.LE.EPSILON(1.D0)) then
C
               VECTD1=(/1.D0,0.D0,0.D0/)
               RNORM1=1.D0
C
            ENDIF
C
            VECTD1=VECTD1/RNORM1
C
            VECTDN=(/0.D0,0.D0,1.D0/)
C
            IF ( ABS( ABS( DOT_PRODUCT(VECTD1, VECTDN) ) - 1.D0 )
     *          .LT. EPSILON(1.D0) ) THEN
C
                VECTDN = (/0.D0,1.D0,0.D0/)
C
            ENDIF
C
            VECTD2=CROSS_PRODUCT(VECTD1,VECTDN)
C
            IF (ITOMSC .NE. 0) THEN
C
               VECTD1 = (/P1VECX,P1VECY,P1VECZ/)
               VECTD2 = (/P2VECX,P2VECY,P2VECZ/)
C
            ENDIF
C
            VECTP0 = (/P0VECX,P0VECY,P0VECZ/)
C
            IPOS=0
C
C
            DO II = 0, MCMESH
               DO JJ = 0, MCMESH
C
                  VTEMP=(II*DSTEPW - PWIDTH/2)*VECTD1
     *                 +(JJ*DSTEPH - PHEIGH/2)*VECTD2
     *                 +VECTP0
C
                  IPOS=IPOS+1
C
                  PMESHT(IPOS,1:3)=VTEMP
C
               ENDDO
            ENDDO
C
            IF(ITOMOZ.EQ.-1) THEN
C
               BIG_PP(:,:,:)=DEN_PP(:,:,:,ICHARG)
               BIG_PM(:,:,:)=DEN_PM(:,:,:,ICHARG)
C
               WRITE(*,'(79(1H*),/,1H*,77X,1H*,/,1H*,22X,
     *               '' INTRINSIC DENSITY DISTRIBUTION '',23X,1H*,/,
     *               1H*,77X,1H*,/,79(1H*))')
C
               WRITE(*,'(1H*,77X,1H*,/,1H*,''        '',
     *               ''X (FM)        Y (FM)        Z (FM)'',
     *               ''   DENSITY  [FM^(-3)] (Re Im)      '',1H*,/,
     *               1H*,77X,1H*)')
C
            ENDIF
C
            IF(ITOMOZ.EQ.1) THEN
C
               WRITE(*,'(79(1H*),/,1H*,77X,1H*,/,1H*,22X,
     *               ''CONDITIONAL DENSITY DISTRIBUTION'',23X,1H*,/,
     *               1H*,77X,1H*,/,79(1H*),/,1H*,77X,1H*)')
C
               WRITE(*,'(1H*,77X,1H*,/,1H*,''        '',
     *               ''X (FM)        Y (FM)        Z (FM)'',
     *               ''        CPD [FM^(-3)] (Re Im)      '',1H*,/,
     *               1H*,77X,1H*)')
C
            ENDIF
C
            DO II=1,IPOS
C
               DTOMOX=PMESHT(II,1)*HOMSCA(1,1)
               DTOMOY=PMESHT(II,2)*HOMSCA(2,1)
               DTOMOZ=PMESHT(II,3)*HOMSCA(3,1)
C
               CALL D_HERM(DTOMOX,NDOSCI,HERX,DHERX,NDOSCI+1)
               CALL D_HERM(DTOMOY,NDOSCI,HERY,DHERY,NDOSCI+1)
               CALL D_HERM(DTOMOZ,NDOSCI,HERZ,DHERZ,NDOSCI+1)
C
               PVALUE=0.D0
C
               DO IL=1,LDBASE
               DO IQ=1,LDBASE
C
                  NX_L=NXVECT(IL,1)
                  NY_L=NYVECT(IL,1)
                  NZ_L=NZVECT(IL,1)
C
                  NX_Q=NXVECT(IQ,1)
                  NY_Q=NYVECT(IQ,1)
                  NZ_Q=NZVECT(IQ,1)
C
                  RESU =
     *            HERX(NX_L+1)*HERY(NY_L+1)*HERZ(NZ_L+1) *
     *            HERX(NX_Q+1)*HERY(NY_Q+1)*HERZ(NZ_Q+1) /
     *            HERFAC(NX_L)/HERFAC(NY_L)/HERFAC(NZ_L) /
     *            HERFAC(NX_Q)/HERFAC(NY_Q)/HERFAC(NZ_Q) *
     *            EXP(-DTOMOX**2)*EXP(-DTOMOY**2)*EXP(-DTOMOZ**2) *
     *            HOMSCA(1,1)*HOMSCA(2,1)*HOMSCA(3,1)
C
                  PVALUE=PVALUE+RESU*(
     *                   IPHAPP(NY_Q,NY_L,0)*BIG_PP(IL,IQ,0)
     *                  +IPHAMM(NY_Q,NY_L,0)*BIG_PP(IL,IQ,1)
     *                  +IPHAPM(NY_Q,NY_L,0)*BIG_PM(IL,IQ,0)
     *                  +IPHAMP(NY_Q,NY_L,0)*BIG_PM(IL,IQ,1))
C
               ENDDO
               ENDDO
C
               PMESHT(II,4)= REAL(PVALUE)
               PMESHT(II,5)=AIMAG(PVALUE)
C
            WRITE(*,'(1H*,3X,5E14.5,4X,1H*)') PMESHT(II,1:5)
C
            ENDDO
C
            WRITE(*,'(1H*,77X,1H*,/,79(1H*))')
C
            DEALLOCATE(PMESHT)
C
         ENDIF
C
         ! --- CALCULATE MULTIPOLE TOMOGRAPHY
C
         ISHIFY=0
C
         IF (ICHARG .EQ. 0) THEN
C
            NAMEPN='NEUTRONS'
C
            CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,TMUL_N,TMUT_N,
     *                                           COMULT,KMULMO,ISHIFY,1)
C
            CALL MOMPRI(ISIMPY,NAMTOM,NAMHAR,NAMEPN,TMUL_N,KMULMO,'T')
C
         ENDIF
C
         IF (ICHARG .EQ. 1) THEN
C
            NAMEPN=' PROTONS'
C
            CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,TMUL_P,TMUT_P,
     *                                           COMULT,KMULMO,ISHIFY,1)
C
            CALL MOMPRI(ISIMPY,NAMTOM,NAMHAR,NAMEPN,TMUL_P,KMULMO,'T')
C
         ENDIF
C
      END DO
C
      DEALLOCATE(PHIQPP,PHIQPM)
C
      CALL CPUTIM('INTOMO',0)
C
      RETURN
C
C ======================================================================
C
      CONTAINS
          FUNCTION CROSS_PRODUCT(A, B) RESULT(C)
             REAL, INTENT(IN) :: A(3), B(3)
             REAL :: C(3)
             c(1) = a(2)*b(3) - a(3)*b(2)
             c(2) = a(3)*b(1) - a(1)*b(3)
             c(3) = a(1)*b(2) - a(2)*b(1)
          END FUNCTION
      END
C
C=======================================================================
C
      SUBROUTINE PJTOMO(ISIMPY,ISIGNY,ISIQTY,KMULMO,LDBASE,
     *                  MPAHFB,IKERNE,IN_FIX,IZ_FIX,NAMHAR,
     *                  MREVER,NEWWIG,ISWIND,NUANGU)
C
C=======================================================================
      USE hfodd_sizes
      USE MAD_PP
      USE MAD_PM
      USE MAT_PP
      USE MAT_PM
      USE BLOSAV
      USE WAVR_L
      USE OVRHFB
      USE MAP_PP
      USE MAP_PM
      USE KAP_PP
      USE KAP_PM
C
C     THIS SUBROUTINE CALCULATES THE PROJECTED MULTIPOLE TOMOGRAPHY WITH
C     RESPECT TO THE POINT SPECIFIED WITH THE KEYWORD 'TOMOGRAPHY'
C
C     IT ALSO CAN BE USED TO PRINT THE PROJECTED ONE-BODY DENSITY
C
      COMMON
     *       /TOMOPI/ ITOMOZ,IOBSCH,IDESCH,INDENS
C
      COMMON
     *       /TOMOPH/ PTOMOX,PTOMOY,PTOMOZ
C
      COMMON
     *       /TOMIMK/ ITOMII,ITOMMM,ITOMKK,NTOMNB,NTOMNA
C
      COMMON /TOMSIC/ ITOMSC
C
      COMMON
     *       /TOMSLC/ P0VECX,P0VECY,P0VECZ,
     *                P1VECX,P1VECY,P1VECZ,
     *                P2VECX,P2VECY,P2VECZ
C
      COMMON
     *       /TOMMEN/ NCMESH
      COMMON
     *       /TOMMES/ PINTSC, PWIDTH, PHEIGH
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
C
      COMMON
     *       /TOMMUL/ TMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                TMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                TMUL_T(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /TOMMUT/ TMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                TMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                TMUT_T(0:NDMULT,-NDMULT:NDMULT)
C
      COMPLEX
     *          TMUT_N,TMUT_P,TMUT_T
C
      CHARACTER
     *          NAMTOM*45,NAMHAR*17
C
      COMMON
     *       /FACHER/ HERFAC(0:ND2MAX)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
C
      COMMON
     *       /RANGLE/ ALPROT,BETROT,GAMROT
C
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
C
      COMPLEX
     *        AUXDIA,C_ZERO,C_UNIT,UNIT_I
      DIMENSION
     *        AUXDIA(1:4*NDSTAT),IAUXDI(1:4*NDSTAT)
C
      DIMENSION
     *          HERX(NDOSCI+1),DHERX(NDOSCI+1),
     *          HERY(NDOSCI+1),DHERY(NDOSCI+1),
     *          HERZ(NDOSCI+1),DHERZ(NDOSCI+1)
C
      DIMENSION
     *          IBLQPL(0:1,1:NDBLOC),IBLQPR(0:1,1:NDBLOC)
C
      DIMENSION
     *          PREPFA(2),PFAWRK(2),TREPFA(2,0:NDISOS),
     *                              TLEPFA(2,0:NDISOS),
     *                              UREPFA(2,0:NDISOS)
C
      DIMENSION
     *          IDSIZN(1:NDBLOC),
     *          IDSIZP(1:NDBLOC),
     *          LDBLOR(0:NDISOS)
C
      COMPLEX
     *          PREPFA,TREPFA,PFAWRK,UREPFA,
     *          BTAPLF,BTAPRG,WARITP,TBTALF
C
      COMPLEX
     *          OVRLAP
C
      ALLOCATABLE OVRLAP(:,:)
C
      COMPLEX     CHJ_PP,CHJ_PM
      ALLOCATABLE CHJ_PP(:,:,:,:),CHJ_PM(:,:,:,:)
C
      COMPLEX     BJG_PP,BJG_PM
      ALLOCATABLE BJG_PP(:,:,:),BJG_PM(:,:,:)
C
      DIMENSION
     *          NTAB(1:NDBKNO,1:NDBKNO), WIGNER(1:NDBKNO),
     *          XA_PNT(1:NDBKNO),XA_WGT(1:NDBKNO),
     *          XB_PNT(1:NDBKNO),XB_WGT(1:NDBKNO),
     *          YG_PNT(1:NDBKNO),YG_WGT(1:NDBKNO),
     *          GAPHAS(1:NDBKNO)
C
      COMPLEX NTAB, CFAC, DFAC, GAPHAS, NTABVAL, DETWRK(2), NTABCH(0:1)
C
      COMPLEX CFACSUM
C
      REAL    WIGNER, FACIMK
C
      COMPLEX RESUPP, RESUPM, RESUMP, RESUMM, RTRACE, PVALUE, PVALP0
C
      REAL DTOMOX, DTOMOY, DTOMOZ, RESU, PI,
     *     DTOMPX, DTOMPY, DTOMPZ
C
      COMPLEX, ALLOCATABLE :: PHIQPP(:,:,:), PHIQPM(:,:,:)
C
      CHARACTER NAMEPN*8
C
      REAL I2BTCE
C
      REAL, ALLOCATABLE :: PMESHT(:,:)
C
      REAL VTEMP(3), VECTD1(3), VECTD2(3), VECTDN(3), VECTP0(3)
C
      ALLOCATABLE
     *          TBTALF(:,:,:),BTAPLF(:,:),BTAPRG(:,:),WARITP(:,:,:)
C
      CHARACTER
     *         NAMNUC(0:NDISOS)*8
C
      DATA
     *       NAMNUC /'NEUTRON ','PROTON  '/
C
      DATA
     *       NAMTOM /'MULTIPOLE TOMOGRAPHY  [UTS:(10 FERMI)^LAMBDA]'/
C
      CALL CPUTIM('PJTOMO',1)
C
      IDEBUG=0
      NVECTS=1
      IF(ITOMSC.LT.0) IDEBUG=1
C
      IF (ISIMPY.EQ.1) STOP 'PJTOMO IS NOT READY FOR ISIMPY = 1 '
C
      PI    =ACOS(-1.D0)
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C     --- COPY SWITCHES TO LOCAL VARIABLES ---
C
      ISOSAC = ITOMII
      LSOSAC = ITOMMM
      KSOSAC = ITOMKK
C
      ALPROT = 0.D0
      GAMROT = 0.D0
C
      IF(NTOMNB.GE.0) THEN
C
         NUBKNO = NTOMNB
         NUAKNO = NTOMNA
         NS2PTS = NUAKNO*NUBKNO
C
      ELSE
C
         NS2PTS = NTOMNA
         NUBKNO = NS2PTS
         NUAKNO = NS2PTS
C
      ENDIF
C
      NUAKNZ = 1
      MUBKNO = NUBKNO
      MUAKNO = NUAKNO
      MS2PTS = NS2PTS
C
      !FACIMK=((ISOSAC+1)/(8*PI**2))**2
      ! --- NO GAMMA INTEGRATION
      FACIMK=((ISOSAC+1)/(4*PI))**2
C
C
      ALLOCATE (WARITP(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WARITP','PJTOMO')
      ALLOCATE (CHJ_PP(1:NDBASE,1:NDBASE,0:1,0:1),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CHJ_PP','PJTOMO')
      ALLOCATE (CHJ_PM(1:NDBASE,1:NDBASE,0:1,0:1),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CHJ_PM','PJTOMO')
C
      IF (.NOT.ALLOCATED(WALEFT)) THEN
          ALLOCATE (WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WALEFT','PJTOMO')
      END IF
C
      ALLOCATE (OVRLAP(1:4*NDSTAT,1:4*NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('OVRLAP','PJTOMO')
C
      ALLOCATE(PHIQPP(1:LDBASE,1:LDBASE,0:1),
     *         PHIQPM(1:LDBASE,1:LDBASE,0:1))
C
      ALLOCATE(BJG_PP(1:LDBASE,1:LDBASE,0:1),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('BJG_PP','PJTOMO')
      ALLOCATE(BJG_PM(1:LDBASE,1:LDBASE,0:1),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('BJG_PM','PJTOMO')
C
      LMAXUR=MAXVAL(LDUPPE(:))+NDBLOC
C
      ALLOCATE (TBTALF(1:LMAXUR,1:LMAXUR,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('TBTALF','PJTOMO')
C
      DTOMOX=PTOMOX*HOMSCA(1,1)
      DTOMOY=PTOMOY*HOMSCA(2,1)
      DTOMOZ=PTOMOZ*HOMSCA(3,1)
C
      WRITE(*,'(79(1H*),/,1H*,77X,1H*,/,1H*,6X,
     *               ''THE OBSERVING PARTICLE: '',A8,
     *               '', THE OBSERVED PARTICLE: '',A8,6X,1H*,/,
     *               1H*,77X,1H*)')
     *               NAMNUC(IOBSCH),NAMNUC(IDESCH)
C
      WRITE(*,'(79(1H*),/,1H*,77X,1H*,/,1H*,11X,
     *               ''THE OBSERVING POINT LOCATES AT '',
     *               ''( '',3F7.2, '' )'',10X,1H*,/,
     *               1H*,77X,1H*)')
     *               PTOMOX, PTOMOY, PTOMOZ
C
      ! --- PREPARE PHIQPP/PM ---
      CALL D_HERM(DTOMOX,NDOSCI,HERX,DHERX,NDOSCI+1)
      CALL D_HERM(DTOMOY,NDOSCI,HERY,DHERY,NDOSCI+1)
      CALL D_HERM(DTOMOZ,NDOSCI,HERZ,DHERZ,NDOSCI+1)
C
      DO IL=1,LDBASE
         DO IQ=1,LDBASE
C
            NX_L=NXVECT(IL,1)
            NY_L=NYVECT(IL,1)
            NZ_L=NZVECT(IL,1)
C
            NX_Q=NXVECT(IQ,1)
            NY_Q=NYVECT(IQ,1)
            NZ_Q=NZVECT(IQ,1)
C
            RESU =
     *      HERX(NX_L+1)*HERY(NY_L+1)*HERZ(NZ_L+1) *
     *      HERX(NX_Q+1)*HERY(NY_Q+1)*HERZ(NZ_Q+1) /
     *      HERFAC(NX_L)/HERFAC(NY_L)/HERFAC(NZ_L) /
     *      HERFAC(NX_Q)/HERFAC(NY_Q)/HERFAC(NZ_Q) *
     *      EXP(-DTOMOX**2)*EXP(-DTOMOY**2)*EXP(-DTOMOZ**2) *
     *      HOMSCA(1,1)*HOMSCA(2,1)*HOMSCA(3,1)
C
            PHIQPP(IQ,IL,0)=RESU*IPHAPP(NY_Q,NY_L,0)
            PHIQPP(IQ,IL,1)=RESU*IPHAMM(NY_Q,NY_L,0)
            PHIQPM(IQ,IL,0)=RESU*IPHAPM(NY_Q,NY_L,0)
            PHIQPM(IQ,IL,1)=RESU*IPHAMP(NY_Q,NY_L,0)
C
         ENDDO
      ENDDO
C
C     --- GENERATE GAUSSIAN QUADRUTURES ---
C
      IF(NTOMNB.GE.0) THEN
C
         IF (NUBKNO.EQ.1) THEN
C
            XB_WGT(1)=2.0D0
            XB_PNT(1)=0.0D0
C
         ELSE
C
            CALL GAULEG(-1.D0,1.D0,XB_PNT,XB_WGT,NUBKNO)
C
            DO I=1,NUBKNO
C
               XB_PNT(I)=ACOS(XB_PNT(I))
C
            END DO
C
         END IF
C
C     --- GENERATE GAUSSIAN CHEBYSCHEV QUADRUTURES ---
C
         IF (NUAKNO.EQ.1) THEN
C
            XA_WGT(1)=2*PI
            XA_PNT(1)=0.D0
C
         ELSE
C
            DO I = 1, NUAKNO
C
               XA_WGT(I)=2*PI/NUAKNO
               XA_PNT(I)=(2*I-1)*PI/NUAKNO
C
            ENDDO
C
         ENDIF
C
      ELSE
C
         CALL LEBEDV(NS2PTS,XB_PNT,XA_PNT,XB_WGT)
         XA_WGT=1.D0
C
      ENDIF
C
C     --- PREPARE WIGNER D-FUNCTION FOR IMK ---
C
      DO I = 1, NUBKNO
         WIGNER(I) = DSMALH(ISOSAC,LSOSAC,KSOSAC,
     *                                 XB_PNT(I),NEWWIG,ISWIND,NUANGU)
      ENDDO
C
      DO I = 1, NUAKNO
          GAPHAS(I) = EXP(-UNIT_I*0.5D0*LSOSAC*XA_PNT(I))
      ENDDO
C
C
      CALL INIADD
C
C     CAUTION: FOR EVEN-EVEN NUCLEI, MANULLY SET LDBLOL TO 0
C     TO AVOID ERROR WHEN TRYING TO START FROM RECORD FILES WITH PARITY 
C
      LDBLOL=0
C
      LDBLOR(:)=LDBLOL(:)
C
      DO ICHARG=0,NDISOS
C
         LSTATE=LDTOTS(ICHARG)
         LUPPER=LDUPPE(ICHARG)
         LDDIAB=LUPPER+NDBLOC
C
         ALLOCATE (BTAPRG(1:LDDIAB,1:LDDIAB),STAT=IALLOC)
         IF (IALLOC.NE.0) CALL NOALLO('BTAPRG','PJTOMO')
         ALLOCATE (BTAPLF(1:LDDIAB,1:LDDIAB) ,STAT=IALLOC)
         IF (IALLOC.NE.0) CALL NOALLO('BTAPLF','PJTOMO')
C
C ======================================================================
C     INITIALIZATION BEFORE PROJECTION
C ======================================================================
C
         IBLOCL=LPRODL(ICHARG)
         IBLQPL(0,:)=WLABBL(ICHARG,:)
         IBLQPL(1,:)=WLABAL(ICHARG,:)
         IDBLOL=LDBLOL(ICHARG)
C
         IBLOCR=LPRODR(ICHARG)
         IBLQPR(0,:)=WLABBR(ICHARG,:)
         IBLQPR(1,:)=WLABAR(ICHARG,:)
         IDBLOR=LDBLOR(ICHARG)
C
         WARIGH(:,:,:)=SARIGH(:,:,:,ICHARG,1)
C
         CALL PRPFAF(LDBASE,LUPPER,IBLOCR,IDBLOR,IBLQPR,
     *                                           WARIGH,BTAPLF,BTAPRG)
C
         TBTALF(1:LDDIAB,1:LDDIAB,ICHARG)=BTAPLF(1:LDDIAB,1:LDDIAB)
C
         PREPFA(1)=C_UNIT
         PREPFA(2)=C_ZERO
C
         CALL OVRPFA(LDBASE,LUPPER,IBLOCR,IBLOCR,
     *                          IDBLOR,IDBLOR,IBLQPR,IBLQPR,PREPFA,
     *                          WARIGH,WARIGH,BTAPLF,PFAWRK,ICHARG)
C
         UREPFA(1,ICHARG)=CMPLX(1.0D0/ABS(PFAWRK(1)),0.0D0)
         UREPFA(2,ICHARG)=-1.D0*PFAWRK(2)
C

C
         DEALLOCATE(BTAPLF,BTAPRG)
C
      ENDDO ! ICHARG
C
C ======================================================================
C     SET DENSITY MATRIX ELEMENTS TO ZEROS
C ======================================================================
C
      CFACSUM=0.D0
C
      BJG_PP = 0.D0
      BJG_PM = 0.D0
C
C ======================================================================
C     STARTS PROJECTION
C ======================================================================
C
      DO NJST=1,NS2PTS
      DO MIST=1,MS2PTS
C
         IF (NTOMNB.GE.0) THEN
C
            NST = MOD(NJST - 1, NUAKNO) + 1
            JST = (NJST - 1) / NUAKNO + 1
C
            MST = MOD(MIST - 1, MUAKNO) + 1
            IST = (MIST - 1) / MUAKNO + 1
C
         ELSE
C
            NST = NJST
            JST = NJST
C
            MST = MIST
            IST = MIST
C
         ENDIF
C
         DO ICHARG=0,1
C
            ALLOCATE (BTAPLF(1:LDDIAB,1:LDDIAB) ,STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('BTAPLF','PJTOMO')
C
            BETROT=XB_PNT(JST)
            !GAMROT=XA_PNT(NST)
            ALPROT=XA_PNT(NST)
C
            WARIGH(:,:,:)=SARIGH(:,:,:,ICHARG,1)
C
            IF (MPAHFB.EQ.1) THEN
C
               CALL ROTWAV(LUPPER,WARIGH)
               CALL ROTLQP(LUPPER,LSTATE,WARIGH)
C
            ELSE
C
               CALL ROTWAV(LSTATE,WARIGH)
C
            END IF
C
C
            BETROT=XB_PNT(IST)
            !GAMROT=XA_PNT(MST)
            ALPROT=XA_PNT(MST)
C
            WALEFT(:,:,:)=SARIGH(:,:,:,ICHARG,1)
C
            IF(MUBKNO.EQ.1) BETROT=0.D0
            IF(MUAKNO.EQ.1) GAMROT=0.D0
C
            IF (MPAHFB.EQ.1) THEN
C
               CALL ROTWAV(LUPPER,WALEFT)
               CALL ROTLQP(LUPPER,LSTATE,WALEFT)
C
            ELSE
C
               CALL ROTWAV(LSTATE,WALEFT)
C
            END IF
C
C
C     CALCULATE NORM OVERLAP
C
            PREPFA(:)=UREPFA(:,ICHARG)
C
            BTAPLF(1:LDDIAB,1:LDDIAB)=TBTALF(1:LDDIAB,1:LDDIAB,ICHARG)
C
            CALL OVRPFA(LDBASE,LUPPER,IBLOCL,IBLOCR,
     *                         IDBLOL,IDBLOR,IBLQPL,IBLQPR,PREPFA,
     *                         WALEFT,WARIGH,BTAPLF,PFAWRK,ICHARG)
C
C
            NTABCH(ICHARG)= PFAWRK(1)*10.0D0**REAL(PFAWRK(2))
C
C     CALCULATE TRANSITION DENSITY, WALEFT WILL BE REPLACED BY
C     (U^T)^{-1}*WALEFT, WITH U = A^+ * A' + B^+ * B'
C
            CALL RUSSOF(LUPPER,LSTATE,WALEFT)
            CALL RUSSOF(LUPPER,LSTATE,WARIGH)
C
            OVRLAP=0.D0
C
            CALL OVRMAT(LDBASE,LUPPER,WARIGH,WALEFT,OVRLAP)
C
            CALL ZGECO(OVRLAP,4*NDSTAT,LUPPER,IAUXDI,
     *                                          RICOND,AUXDIA)
            IF (ABS(RICOND).LT.1.0D-12) PRINT*,'RICOND: ',RICOND
            CALL ZGEDI(OVRLAP,4*NDSTAT,LUPPER,IAUXDI,
     *                                          DETWRK,AUXDIA,11)
C
            WARITP(:,:,:)=0.D0
C
            DO IBASE=1,LDBASE
               DO ISTATE=1,LUPPER
                  ISTALO=ISTATE+LUPPER
                  DO ISPIN=0,NDSPIN
                     DO JSTATE=1,LUPPER
                        JSTALO=JSTATE+LUPPER
C
                        WARITP(IBASE,ISTATE,ISPIN)=
     *                  WARITP(IBASE,ISTATE,ISPIN)
     *                 +WALEFT(IBASE,JSTATE,ISPIN)
     *                 *OVRLAP(JSTATE,ISTATE)
C
                        WARITP(IBASE,ISTALO,ISPIN)=
     *                  WARITP(IBASE,ISTALO,ISPIN)
     *                 +WALEFT(IBASE,JSTALO,ISPIN)
     *                 *OVRLAP(JSTATE,ISTATE)
C
                     END DO
                  END DO
               END DO
            END DO
C
            WALEFT(:,:,:)=WARITP(:,:,:)
C
            CALL RUSSON(LUPPER,LSTATE,WALEFT)
            CALL RUSSON(LUPPER,LSTATE,WARIGH)
C
            ! Transition density & pairing tensor
            CALL DENMAC(MREVER,ICHARG,ISIMPY,MPAHFB,WARIGH,WALEFT,1)
C
            DEN_PP(:,:,:,ICHARG)=BIG_PP(:,:,:)
            DEN_PM(:,:,:,ICHARG)=BIG_PM(:,:,:)
C
C
            IF (MPAHFB.EQ.1) THEN
C
               CALL PAIMAC(ICHARG,ISIMPY,WALEFT,WARIGH,IKERNE)
C
               CHI_PP(:,:,:,ICHARG)=PAI_PP(:,:,:)
               CHI_PM(:,:,:,ICHARG)=PAI_PM(:,:,:)
C
               CALL PAIMAC(ICHARG,ISIMPY,WARIGH,WALEFT,IKERNE)
C
               CHJ_PP(:,:,:,ICHARG)=PAI_PP(:,:,:)
               CHJ_PM(:,:,:,ICHARG)=PAI_PM(:,:,:)
C
            ENDIF
C
            DEALLOCATE(BTAPLF)
C
         ENDDO ! -- ICHARG
C
C ======================================================================
C     NORM OVERLAP IS PRODUCT OF NEUTRON'S AND PROTON'S FOR INDENS<>-1
C ======================================================================
C
         NTABVAL=NTABCH(0)*NTABCH(1)
         IF (INDENS.EQ.-1) NTABVAL=NTABCH(IDESCH)
C
C     ---   MULTIPLIER IN THE INTEGRAL OVER LEFT AND RIGHT EULER ANGLE
C
         CFAC    =       WIGNER(JST)*WIGNER(IST)
     *                 * XB_WGT(JST)*XB_WGT(IST)
     *                 * NTABVAL
C
         DFAC    =       XA_WGT(MST)*XA_WGT(NST)
     *                 * CONJG(GAPHAS(NST))*GAPHAS(MST)
C
C
         CFAC = CFAC*DFAC*FACIMK
C
         CFACSUM=CFACSUM+CFAC
C
C ======================================================================
C     DETERMINE THE TYPE OF DENSITY TO BE CALCULATED
C ======================================================================
C
         IF (IOBSCH.EQ.IDESCH) THEN
C
            ISAMNP=1
            ICHARG=IDESCH
C
         ELSE
C
            ISAMNP=0
            ICHARG=IDESCH
            JCHARG=IOBSCH
C
         ENDIF
C
C ======================================================================
C     CALCULATE THE MATRIX ELEMENTS
C ======================================================================
C
         DO IK=1,LDBASE
C           !DO IP=1,LDBASE
            DO IP=IK,LDBASE
C
               RESUPP=0.D0
               RESUPM=0.D0
               RESUMP=0.D0
               RESUMM=0.D0
C
C        --- CONDITIONAL DENSITY MTS: SAME ISOSPIN ---
C
               IF (ISAMNP.EQ.1 .AND. ITOMOZ.EQ.2) THEN
C
                  DO IL=1,LDBASE
                  DO IQ=1,LDBASE
C
                     RESUPP = RESUPP
C                    ! KPLQ ++++
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                  +CHI_PP(IK,IL,0,ICHARG)*CHJ_PP(IQ,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ +++-
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,0,ICHARG)
     *                  -DEN_PM(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                  +CHI_PP(IK,IL,0,ICHARG)*CHJ_PM(IQ,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ ++-+
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PM(IL,IP,1,ICHARG)
     *                  +CHI_PM(IK,IL,0,ICHARG)*CHJ_PP(IQ,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ ++--
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PM(IK,IQ,0,ICHARG)*DEN_PM(IL,IP,1,ICHARG)
     *                  +CHI_PM(IK,IL,0,ICHARG)*CHJ_PM(IQ,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUPM = RESUPM
C                    ! KPLQ +-++
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PM(IL,IP,0,ICHARG)
     *                  +CHI_PP(IK,IL,0,ICHARG)*CHJ_PM(IQ,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ +-+-
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,0,ICHARG)
     *                  -DEN_PM(IK,IQ,0,ICHARG)*DEN_PM(IL,IP,0,ICHARG)
     *                  +CHI_PP(IK,IL,0,ICHARG)*CHJ_PP(IQ,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ +--+
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                  +CHI_PM(IK,IL,0,ICHARG)*CHJ_PM(IQ,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ +---
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PM(IK,IQ,0,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                  +CHI_PM(IK,IL,0,ICHARG)*CHJ_PP(IQ,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUMP = RESUMP
C                    ! KPLQ -+++
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PM(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                  +CHI_PM(IK,IL,1,ICHARG)*CHJ_PP(IQ,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ -++-
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,0,ICHARG)
     *                  +CHI_PM(IK,IL,1,ICHARG)*CHJ_PM(IQ,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ -+-+
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,1,ICHARG)
     *                  -DEN_PM(IK,IQ,1,ICHARG)*DEN_PM(IL,IP,1,ICHARG)
     +                  +CHI_PP(IK,IL,1,ICHARG)*CHJ_PP(IQ,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ -+--
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PM(IL,IP,1,ICHARG)
     *                  +CHI_PP(IK,IL,1,ICHARG)*CHJ_PM(IQ,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUMM = RESUMM
C                    ! KPLQ --++
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,0,ICHARG)
     *                  -DEN_PM(IK,IQ,1,ICHARG)*DEN_PM(IL,IP,0,ICHARG)
     *                  +CHI_PM(IK,IL,1,ICHARG)*CHJ_PM(IQ,IP,0,ICHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ --+-
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,0,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PM(IL,IP,0,ICHARG)
     *                  +CHI_PM(IK,IL,1,ICHARG)*CHJ_PP(IQ,IP,1,ICHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ ---+
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,1,ICHARG)
     *                  -DEN_PM(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                  +CHI_PP(IK,IL,1,ICHARG)*CHJ_PM(IQ,IP,0,ICHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ ----
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,1,ICHARG)
     *                  -DEN_PP(IK,IQ,1,ICHARG)*DEN_PP(IL,IP,1,ICHARG)
     *                  +CHI_PP(IK,IL,1,ICHARG)*CHJ_PP(IQ,IP,1,ICHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                  ENDDO
                  ENDDO
C
               ENDIF
C
C        --- CONDITIONAL DENSITY MTS: DIFFERENT ISOSPIN ---
C
               IF (ISAMNP.NE.1 .AND. ITOMOZ.EQ.2) THEN
C
                  DO IL=1,LDBASE
                  DO IQ=1,LDBASE
C
                     RESUPP = RESUPP
C                    ! KPLQ ++++
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,0,JCHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ +++-
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,0,JCHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ ++-+
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,1,JCHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ ++--
     *               + ( DEN_PP(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,1,JCHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUPM = RESUPM
C                    ! KPLQ +-++
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,0,JCHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ +-+-
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,0,JCHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ +--+
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PM(IL,IQ,1,JCHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ +---
     *               + ( DEN_PM(IK,IP,0,ICHARG)*DEN_PP(IL,IQ,1,JCHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUMP = RESUMP
C                    ! KPLQ -+++
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,0,JCHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ -++-
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,0,JCHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ -+-+
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,1,JCHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ -+--
     *               + ( DEN_PM(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,1,JCHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                     RESUMM = RESUMM
C                    ! KPLQ --++
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,0,JCHARG)
     *                 ) * PHIQPP(IQ,IL,0)
C                    ! KPLQ --+-
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,0,JCHARG)
     *                 ) * PHIQPM(IQ,IL,1)
C                    ! KPLQ ---+
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PM(IL,IQ,1,JCHARG)
     *                 ) * PHIQPM(IQ,IL,0)
C                    ! KPLQ ----
     *               + ( DEN_PP(IK,IP,1,ICHARG)*DEN_PP(IL,IQ,1,JCHARG)
     *                 ) * PHIQPP(IQ,IL,1)
C
                  ENDDO
                  ENDDO
C
               ENDIF
C
C        --- ONE-BODY DENSITY MTS ---
C
               IF(ITOMOZ.EQ.-2) THEN
C
                  RESUPP=DEN_PP(IP,IK,0,ICHARG)
                  RESUMM=DEN_PP(IP,IK,1,ICHARG)
                  RESUPM=DEN_PM(IP,IK,0,ICHARG)
                  RESUMP=DEN_PM(IP,IK,1,ICHARG)
C
               ENDIF
C
               BJG_PP(IK,IP,0) = BJG_PP(IK,IP,0)+RESUPP*CFAC
               BJG_PP(IK,IP,1) = BJG_PP(IK,IP,1)+RESUMM*CFAC
C
               IF (ISIMPY.NE.1) THEN
                  BJG_PM(IK,IP,0) = BJG_PM(IK,IP,0)+RESUPM*CFAC
                  BJG_PM(IK,IP,1) = BJG_PM(IK,IP,1)+RESUMP*CFAC
               ENDIF
C
            ENDDO ! IP
         ENDDO ! IK
C
      ENDDO ! NJST
      ENDDO ! MIST
C
C        --- FILL THE LOWER TRIANGLE MATRIX
C
      DO IK=1,LDBASE
         DO IP=1,IK-1
            BJG_PP(IK,IP,0)=CONJG(BJG_PP(IP,IK,0))
            BJG_PP(IK,IP,1)=CONJG(BJG_PP(IP,IK,1))
            BJG_PM(IK,IP,0)=CONJG(BJG_PM(IP,IK,1))
            BJG_PM(IK,IP,1)=CONJG(BJG_PM(IP,IK,0))
         ENDDO
      ENDDO
C
C ======================================================================
C     ENDS PROJECTION
C ======================================================================
C
         BIG_PP(1:LDBASE,1:LDBASE,0:1)=BJG_PP(1:LDBASE,1:LDBASE,0:1)
         BIG_PM(1:LDBASE,1:LDBASE,0:1)=BJG_PM(1:LDBASE,1:LDBASE,0:1)
C
         RTRACE=0.D0
C
         DO IK=1,LDBASE
C
            RTRACE = RTRACE + BIG_PP(IK,IK,0)
     *                      + BIG_PP(IK,IK,1)
C
         ENDDO
C
C
C        --- NORMALIZATION OF THE DENSITY
C
         IMONE=0
         IF(ITOMOZ.EQ.2 .AND. ISAMNP.EQ.1) IMONE=1
C
         IF (ICHARG.EQ.0) I2BTCE=IN_FIX-IMONE
         IF (ICHARG.EQ.1) I2BTCE=IZ_FIX-IMONE
C
         IF (INDENS.EQ.0) I2BTCE=1.D0
C
         IF (INDENS.EQ.2) I2BTCE=ABS(RTRACE)
C
         IF (INDENS.EQ.3) I2BTCE=ABS(RTRACE)/CFACSUM
C
         WRITE(*,'(79(1H*),/,1H*,77X,1H*,/,1H*, 2X,
     *               ''TRACE OF DENSITY MATRIX AND '',
     *               ''THE MULTIPLIER ARE '',
     *               2E12.5,4X,1H*,/,
     *               1H*,77X,1H*)')
     *               ABS(RTRACE), 1.D0/ABS(RTRACE)*I2BTCE
C
         BIG_PP=BIG_PP/ABS(RTRACE)*I2BTCE
         IF (ISIMPY.NE.1) BIG_PM=BIG_PM/ABS(RTRACE)*I2BTCE
C
C
C ======================================================================
C     VISUALIZATION OF THE DENSITY
C ======================================================================
C
         IF (NCMESH.GT.0) THEN
C
            MCMESH=NINT(SQRT(DBLE(NCMESH)))
            DSTEPW=PWIDTH/MCMESH
            DSTEPH=PHEIGH/MCMESH
C
            ALLOCATE(PMESHT((MCMESH+1)*(MCMESH+1),5))
C
            VECTD1=(/PTOMOX,PTOMOY,PTOMOZ/)
            RNORM1=SQRT(DOT_PRODUCT(VECTD1, VECTD1))
C
            IF (RNORM1.LE.EPSILON(1.D0)) then
C
               VECTD1=(/1.D0,0.D0,0.D0/)
               RNORM1=1.D0
C
            ENDIF
C
            VECTD1=VECTD1/RNORM1
C
            VECTDN=(/0.D0,0.D0,1.D0/)
C
            IF ( ABS( ABS( DOT_PRODUCT(VECTD1, VECTDN) ) - 1.D0 )
     *          .LT. EPSILON(1.D0) ) THEN
C
                VECTDN = (/0.D0,1.D0,0.D0/)
C
            ENDIF
C
            VECTD2=CROSS_PRODUCT(VECTD1,VECTDN)
C
            IF (ITOMSC .NE. 0) THEN
C
               VECTD1 = (/P1VECX,P1VECY,P1VECZ/)
               VECTD2 = (/P2VECX,P2VECY,P2VECZ/)
C
               NVECTS = ABS(ITOMSC)
C
            ENDIF
C
            VECTP0 = (/P0VECX,P0VECY,P0VECZ/)
C
C        --- DENSITY SLICES ---
C
            DO IVECTS=1,NVECTS
C           ! --- NO INDENT ---
            IF(IVECTS.NE.1) THEN
C
               VECTDN=CROSS_PRODUCT(VECTD1,VECTD2)
               VECTD1=VECTD2
               VECTD2=VECTDN
C
            ENDIF
C
            IPOS=0
C
            WRITE(*,'(79(1H*),/,1H*,77X,1H*,/,1H*,2X,
     *               ''DENSITY DISTRIBUTION IS PRESENTED IN THE '',
     *               ''AREA OF SIZE'',F7.2,'' AND '',F7.2,3X,1H*,/,
     *               1H*,77X,1H*,/,1H*,2X,
     *               ''THE AREA IS DEFINED BY THREE VECTORS:'',
     *               38X,1H*,/,1H*,77X,1H*,/,1H*,1X,
     *               '' ('',3F7.2,'' )'','' ('',3F7.2,'' )'',
     *               '' ('',3F7.2,'' )'',1X,1H*,/,
     *               1H*,77X,1H*)')
     *               PWIDTH,PHEIGH,VECTP0,VECTD1,VECTD2
C
            DO II = 0, MCMESH
               DO JJ = 0, MCMESH
C
                  VTEMP=(II*DSTEPW - PWIDTH/2)*VECTD1
     *                 +(JJ*DSTEPH - PHEIGH/2)*VECTD2
     *                 +VECTP0
C
                  IPOS=IPOS+1
C
                  PMESHT(IPOS,1:3)=VTEMP
C
               ENDDO
            ENDDO
C
            IF(ITOMOZ.EQ.-2) THEN
C
               WRITE(*,'(79(1H*),/,1H*,77X,1H*,/,1H*,22X,
     *               ''   PROJECTED ONE-BODY DENSITY   '',23X,1H*,/,
     *               1H*,77X,1H*,/,79(1H*))')
C
               WRITE(*,'(1H*,77X,1H*,/,1H*,''        '',
     *               ''X (FM)        Y (FM)        Z (FM)'',
     *               ''      DENSITY [FM^(-3)] (Re Im)    '',1H*,/,
     *               1H*,77X,1H*)')
C
            ENDIF
C
            IF(ITOMOZ.EQ.2) THEN
C
               WRITE(*,'(79(1H*),/,1H*,77X,1H*,/,1H*,22X,
     *               ''CONDITIONAL DENSITY DISTRIBUTION'',23X,1H*,/,
     *               1H*,77X,1H*,/,79(1H*),/,1H*,77X,1H*)')
C
               WRITE(*,'(1H*,77X,1H*,/,1H*,''        '',
     *               ''X (FM)        Y (FM)        Z (FM)'',
     *               ''        CPD [FM^(-3)] (Re Im)      '',1H*,/,
     *               1H*,77X,1H*)')
C
            ENDIF
C
            IF(NUAKNZ.EQ.1) THEN
C
               YG_WGT(1)=2*PI
               YG_PNT(1)=0.D0
C
            ELSE
C
               DO I = 1, NUAKNZ
C
                  YG_WGT(I)=2*PI/NUAKNZ
                  YG_PNT(I)=(2*I-1)*PI/NUAKNZ
C
               ENDDO
C
            ENDIF
C
            DO II=1,IPOS
C
               DTOMPX=PMESHT(II,1)*HOMSCA(1,1)
               DTOMPY=PMESHT(II,2)*HOMSCA(2,1)
               DTOMPZ=PMESHT(II,3)*HOMSCA(3,1)
C
               ANGPER=ATAN2(DTOMPY, DTOMPX)
               RADPER=SQRT(DTOMPY**2+DTOMPX**2)
C
               PVALP0=0.D0
C
C     --- IF NUAKNZ<>1, THE DENSITY IS AZIMUTHALLY AVERAGED
C         THE RESULT IS DIFFERENT FROM EXACT PROJECTION
C     --- FOR EXACT PROJECTION, NO AVERAGING NEEDED, I.E., NUAKNZ=1
C
               DO IYST=1,NUAKNZ
C
               DTOMOX=DTOMPX
               DTOMOY=DTOMPY
               IF(NUAKNZ.NE.1) DTOMOX=RADPER*COS(YG_PNT(IYST)+ANGPER)
               IF(NUAKNZ.NE.1) DTOMOY=RADPER*SIN(YG_PNT(IYST)+ANGPER)
               DTOMOZ=DTOMPZ
C
               CALL D_HERM(DTOMOX,NDOSCI,HERX,DHERX,NDOSCI+1)
               CALL D_HERM(DTOMOY,NDOSCI,HERY,DHERY,NDOSCI+1)
               CALL D_HERM(DTOMOZ,NDOSCI,HERZ,DHERZ,NDOSCI+1)
C
               PVALUE=0.D0
C
               DO IL=1,LDBASE
               DO IQ=1,LDBASE
C
                  NX_L=NXVECT(IL,1)
                  NY_L=NYVECT(IL,1)
                  NZ_L=NZVECT(IL,1)
C
                  NX_Q=NXVECT(IQ,1)
                  NY_Q=NYVECT(IQ,1)
                  NZ_Q=NZVECT(IQ,1)
C
                  RESU =
     *            HERX(NX_L+1)*HERY(NY_L+1)*HERZ(NZ_L+1) *
     *            HERX(NX_Q+1)*HERY(NY_Q+1)*HERZ(NZ_Q+1) /
     *            HERFAC(NX_L)/HERFAC(NY_L)/HERFAC(NZ_L) /
     *            HERFAC(NX_Q)/HERFAC(NY_Q)/HERFAC(NZ_Q) *
     *            EXP(-DTOMOX**2)*EXP(-DTOMOY**2)*EXP(-DTOMOZ**2) *
     *            HOMSCA(1,1)*HOMSCA(2,1)*HOMSCA(3,1)
C
                  PVALUE=PVALUE+RESU*(
     *                   IPHAPP(NY_Q,NY_L,0)*BIG_PP(IL,IQ,0)
     *                  +IPHAMM(NY_Q,NY_L,0)*BIG_PP(IL,IQ,1)
     *                  +IPHAPM(NY_Q,NY_L,0)*BIG_PM(IL,IQ,0)
     *                  +IPHAMP(NY_Q,NY_L,0)*BIG_PM(IL,IQ,1))
C
               ENDDO
               ENDDO
C
               PVALP0=PVALP0+PVALUE*YG_WGT(IYST)
C
               ENDDO ! IYST
C
               PMESHT(II,4)= REAL(PVALP0)/(2*PI)
               PMESHT(II,5)=AIMAG(PVALP0)/(2*PI)
C
            WRITE(*,'(1H*,3X,5E14.5,4X,1H*)') PMESHT(II,1:5)
C
            ENDDO
C
            WRITE(*,'(1H*,77X,1H*,/,79(1H*))')
C
            ENDDO ! NVECTS
C
            DEALLOCATE(PMESHT)
C
         ENDIF
C
C ======================================================================
C     CALCULATE MULTIPOLE TOMOGRAPHY
C ======================================================================
C
         ISHIFY=0
C
         IF (ICHARG .EQ. 0) THEN
C
            NAMEPN='NEUTRONS'
C
            CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,TMUL_N,TMUT_N,
     *                                           COMULT,KMULMO,ISHIFY,1)
C
            CALL MOMPRI(ISIMPY,NAMTOM,NAMHAR,NAMEPN,TMUL_N,KMULMO,'T')
C
         ENDIF
C
         IF (ICHARG .EQ. 1) THEN
C
            NAMEPN=' PROTONS'
C
            CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,TMUL_P,TMUT_P,
     *                                           COMULT,KMULMO,ISHIFY,1)
C
            CALL MOMPRI(ISIMPY,NAMTOM,NAMHAR,NAMEPN,TMUL_P,KMULMO,'T')
C
         ENDIF
C
C
      DEALLOCATE(PHIQPP,PHIQPM)
C
      DEALLOCATE(WARITP)
C
      DEALLOCATE(OVRLAP,CHJ_PP,CHJ_PM)
      DEALLOCATE(BJG_PM,BJG_PP,TBTALF)
C
      CALL CPUTIM('PJTOMO',0)
C
      RETURN
C
C ======================================================================
C     FUNC TO CALCULATE THE CROSS PRODUCT OF TWO 3D VECTORS
C ======================================================================
C
      CONTAINS
          FUNCTION CROSS_PRODUCT(A, B) RESULT(C)
             REAL, INTENT(IN) :: A(3), B(3)
             REAL :: C(3)
             c(1) = a(2)*b(3) - a(3)*b(2)
             c(2) = a(3)*b(1) - a(1)*b(3)
             c(3) = a(1)*b(2) - a(2)*b(1)
          END FUNCTION
      END
C
C=======================================================================
C
      SUBROUTINE LEBEDV(NLEBED,TLEB,PLEB,WLEB)
C
C=======================================================================
C
C     THIS SUBROUTINE RETURNS LEBEDEV QUADRATURE FOR THE ORDER NLEBED
C
      INTEGER NLEBED
      REAL    TLEB(NLEBED),PLEB(NLEBED),WLEB(NLEBED)
C
      DIMENSION
     *          TLEB50(50),PLEB50(50),WLEB50(50),
     *          TLEB74(74),PLEB74(74),WLEB74(74)
C
      DATA TLEB50
     *
     *         /   1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             7.85398163397448279E-01,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             2.35619449019234484E+00,
     *             7.85398163397448279E-01,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             2.35619449019234484E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             9.55316618124509298E-01,
     *             9.55316618124509298E-01,
     *             9.55316618124509298E-01,
     *             9.55316618124509298E-01,
     *             2.18627603546528393E+00,
     *             2.18627603546528393E+00,
     *             2.18627603546528393E+00,
     *             2.18627603546528393E+00,
     *             4.40510663004698433E-01,
     *             4.40510663004698433E-01,
     *             4.40510663004698433E-01,
     *             4.40510663004698433E-01,
     *             2.70108199058509468E+00,
     *             2.70108199058509468E+00,
     *             2.70108199058509468E+00,
     *             2.70108199058509468E+00,
     *             1.26451895762522715E+00,
     *             1.26451895762522715E+00,
     *             1.26451895762522715E+00,
     *             1.26451895762522715E+00,
     *             1.87707369596456619E+00,
     *             1.87707369596456619E+00,
     *             1.87707369596456619E+00,
     *             1.87707369596456619E+00,
     *             1.26451895762522715E+00,
     *             1.26451895762522715E+00,
     *             1.26451895762522715E+00,
     *             1.26451895762522715E+00,
     *             1.87707369596456619E+00,
     *             1.87707369596456619E+00,
     *             1.87707369596456619E+00,
     *             1.87707369596456619E+00/
C
      DATA PLEB50
     *
     *         /   0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             0.00000000000000000E+00,
     *             0.00000000000000000E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             1.24904577239825443E+00,
     *             1.89254688119153891E+00,
     *             5.03413953478133180E+00,
     *             4.39063842598804754E+00,
     *             1.24904577239825443E+00,
     *             1.89254688119153891E+00,
     *             5.03413953478133180E+00,
     *             4.39063842598804754E+00,
     *             3.21750554396642130E-01,
     *             2.81984209919315099E+00,
     *             5.96143475278294410E+00,
     *             3.46334320798643525E+00,
     *             3.21750554396642130E-01,
     *             2.81984209919315099E+00,
     *             5.96143475278294410E+00,
     *             3.46334320798643525E+00/
C
      DATA WLEB50
     *
     *         /   1.26984126984127001E-02,
     *             1.26984126984127001E-02,
     *             1.26984126984127001E-02,
     *             1.26984126984127001E-02,
     *             1.26984126984127001E-02,
     *             1.26984126984127001E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.25749559082892397E-02,
     *             2.10937500000000014E-02,
     *             2.10937500000000014E-02,
     *             2.10937500000000014E-02,
     *             2.10937500000000014E-02,
     *             2.10937500000000014E-02,
     *             2.10937500000000014E-02,
     *             2.10937500000000014E-02,
     *             2.10937500000000014E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02,
     *             2.01733355379188697E-02/
C
      DATA TLEB74
     *
     *         /   1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             7.85398163397448279E-01,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             2.35619449019234484E+00,
     *             7.85398163397448279E-01,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             2.35619449019234484E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             9.55316618124509298E-01,
     *             9.55316618124509298E-01,
     *             9.55316618124509298E-01,
     *             9.55316618124509298E-01,
     *             2.18627603546528393E+00,
     *             2.18627603546528393E+00,
     *             2.18627603546528393E+00,
     *             2.18627603546528393E+00,
     *             7.46898593069036609E-01,
     *             7.46898593069036609E-01,
     *             7.46898593069036609E-01,
     *             7.46898593069036609E-01,
     *             2.39469406052075673E+00,
     *             2.39469406052075673E+00,
     *             2.39469406052075673E+00,
     *             2.39469406052075673E+00,
     *             1.06970331352953951E+00,
     *             1.06970331352953951E+00,
     *             1.06970331352953951E+00,
     *             1.06970331352953951E+00,
     *             2.07188934006025383E+00,
     *             2.07188934006025383E+00,
     *             2.07188934006025383E+00,
     *             2.07188934006025383E+00,
     *             1.06970331352953951E+00,
     *             1.06970331352953951E+00,
     *             1.06970331352953951E+00,
     *             1.06970331352953951E+00,
     *             2.07188934006025383E+00,
     *             2.07188934006025383E+00,
     *             2.07188934006025383E+00,
     *             2.07188934006025383E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             1.57079632679489656E+00,
     *             3.26545131375260367E-01,
     *             3.26545131375260367E-01,
     *             2.81504752221453280E+00,
     *             2.81504752221453280E+00,
     *             1.24425119541963625E+00,
     *             1.24425119541963625E+00,
     *             1.89734145817015709E+00,
     *             1.89734145817015709E+00,
     *             3.26545131375260367E-01,
     *             3.26545131375260367E-01,
     *             2.81504752221453280E+00,
     *             2.81504752221453280E+00,
     *             1.24425119541963625E+00,
     *             1.24425119541963625E+00,
     *             1.89734145817015709E+00,
     *             1.89734145817015709E+00/
C
      DATA PLEB74
     *
     *         /   0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             0.00000000000000000E+00,
     *             0.00000000000000000E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             7.85398163397448279E-01,
     *             2.35619449019234484E+00,
     *             5.49778714378213795E+00,
     *             3.92699081698724139E+00,
     *             9.91156586431192310E-01,
     *             2.15043606715860092E+00,
     *             5.29202872074839359E+00,
     *             4.13274924002098487E+00,
     *             9.91156586431192310E-01,
     *             2.15043606715860092E+00,
     *             5.29202872074839359E+00,
     *             4.13274924002098487E+00,
     *             5.79639740363704359E-01,
     *             2.56195291322608876E+00,
     *             5.70354556681588143E+00,
     *             3.72123239395349747E+00,
     *             5.79639740363704359E-01,
     *             2.56195291322608876E+00,
     *             5.70354556681588143E+00,
     *             3.72123239395349747E+00,
     *             1.24425119541963625E+00,
     *             1.89734145817015709E+00,
     *             5.03893411175994999E+00,
     *             4.38584384900942936E+00,
     *             3.26545131375260367E-01,
     *             2.81504752221453280E+00,
     *             5.95664017580432592E+00,
     *             3.46813778496505343E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             0.00000000000000000E+00,
     *             3.14159265358979312E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00,
     *             1.57079632679489656E+00,
     *             4.71238898038468967E+00/
C
      DATA WLEB74
     *
     *         /   5.13067179733846376E-04,
     *             5.13067179733846376E-04,
     *             5.13067179733846376E-04,
     *             5.13067179733846376E-04,
     *             5.13067179733846376E-04,
     *             5.13067179733846376E-04,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *             1.66040695657420391E-02,
     *            -2.95860389610389588E-02,
     *            -2.95860389610389588E-02,
     *            -2.95860389610389588E-02,
     *            -2.95860389610389588E-02,
     *            -2.95860389610389588E-02,
     *            -2.95860389610389588E-02,
     *            -2.95860389610389588E-02,
     *            -2.95860389610389588E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             2.65762070821594608E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02,
     *             1.65221709937157096E-02/
C
      IF (NLEBED.EQ.50) THEN
C
         TLEB(1:NLEBED) = TLEB50(1:NLEBED)
         PLEB(1:NLEBED) = PLEB50(1:NLEBED)
         WLEB(1:NLEBED) = WLEB50(1:NLEBED)
C
      ELSE IF (NLEBED.EQ.74) THEN
C
         TLEB(1:NLEBED) = TLEB74(1:NLEBED)
         PLEB(1:NLEBED) = PLEB74(1:NLEBED)
         WLEB(1:NLEBED) = WLEB74(1:NLEBED)
C
      ELSE
C
         STOP 'WRONG NLEBED ...'
C
      ENDIF
C
      RETURN
C
      END
C
C=======================================================================
C
      SUBROUTINE CONMIX(IPRDIM,ICMPRI,NFIFER,FILFER,
     *                         IEVEN_,CHALF_,JSOSMI,
     *                         JSOSMA,ISOTZL,IPROAC,EPSMIX)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHALF_*2
      CHARACTER FILFER*68
C
      COMPLEX CELMTS,OCNMIX,HCNMIX,OVEWAV,HAMWAV,HAMCUT,WAVFUN,FPROJE,
     *        CPROJE,
     *        C_ZERO,FERMAE,FERMTR,CMIX_R,C_KT_L,TCOEFF,OVEMIX,ESKMIX,
     *        ESKCON,GT_RED,GTRMAT
C
      DIMENSION
     *          CELMTS(1:((NDCONF+1)*NDCONF)/2)
C
      DIMENSION
     *          OVEWAV(1:NDCONF,1:NDCONF),OVEEIG(1:NDCONF),
     *          HAMWAV(1:NDCONF,1:NDCONF),HAMEIG(1:NDCONF),
     *          WAVFUN(1:NDCONF,1:NDCONF),FERMTR(1:NDCONF),
     *          FERMAE(1:NDCONF,1:NDCONF),DELTAC(1:NDCONF),
     *          TCOEFF(1:NDPROT,1:NDCONF),FRMOD2(1:NDCONF),
     *          ESKCON(1:NDPROT,1:NDCONF),CMIX_R(1:NDCONF),
     *          GTRMAT(1:NDCONF,1:NDCONF),GT_RED(1:NDCONF),
     *          CONPNC(1:NDCONF,1:NDCONF),GTPROB(1:NDCONF),
     *                                    IT_MAX(1:NDCONF),
     *                                    TT_MAX(1:NDCONF)
C
      COMMON
     *       /FERMLL/ C_KT_L(-NDPROI:NDPROI,NDPROT,NDCONF),
     *                EIGINI(NDCONF),MIXIND(NDCONF,2)
C
      COMMON /KONFIG/ OCNMIX(NDCONF,NDCONF),HCNMIX(NDCONF,NDCONF),
     *                OVEMIX(NDKERN,NDKERN,NDRZUT,NDRZUT,NDPROT)
C
      COMMON /ENEMIX/ ESKMIX(NDKERN,NDKERN,NDRZUT,NDRZUT,NDPROT)
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('CONMIX',1)
C
C=======================================================================
C
      IF (IPRDIM.GT.NDCONF) STOP
C
C     VARIABLE "IPRFRO" IS INTRODUCED TO PREVENT THE COMILER FROM
C     COMPLAINIG FOR NDCONF=1
C
      IPRFRO=2
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      GA_NEU=-1.2701
      GANEU2=GA_NEU**2
C
      IF (ICMPRI.GE.2) THEN
C
      WRITE(*,210)
 210  FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *       1H*,30X,'HAMILTONIAN MATRIX',29X,1H*,/,1H*,77X,1H*,/,
     *       79(1H*))
C
      DO KBRA=1,IPRDIM
         DO KKET=1,IPRDIM
C
             WRITE(*,212) KBRA,KKET,HCNMIX(KBRA,KKET),
     *                    KKET,KBRA,HCNMIX(KKET,KBRA)
 212         FORMAT(1H*,2(2I3,2F16.6),1X,1H*)
C
         END DO
      END DO
C
      END IF
C
      IF (ICMPRI.GE.2) WRITE(*,211)
 211  FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *       1H*,32X,'OVERLAP MATRIX',31X,1H*,/,1H*,77X,1H*,/,
     *       79(1H*))
C
      DO KBRA=1,IPRDIM
         DO KKET=1,IPRDIM
C
             IF (ICMPRI.GE.2)
     *       WRITE(*,209) KBRA,KKET,OCNMIX(KBRA,KKET),
     *                    KKET,KBRA,OCNMIX(KKET,KBRA)
 209         FORMAT(1H*,2(2I3,2F16.10),1X,1H*)
C
             IF (KBRA.GE.KKET) THEN
C
                NCOUNT=KBRA+((2*IPRDIM-KKET)*(KKET-1))/2
                CELMTS(NCOUNT)=OCNMIX(KBRA,KKET)
C
             END IF
C
         END DO
      END DO
C
      CALL DIAMAT(CELMTS,OVEEIG,OVEWAV,IPRDIM,NDCONF,IPRDIM)
C
      WRITE(*,213)
 213  FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *       1H*,20X,'DIAGONALIZATION OF THE OVERLAP MATRIX',20X,1H*,/,
     *       1H*,77X,1H*,/,79(1H*))
C
      ISTA=1
      DO KBRA=1,IPRDIM
         WRITE(*,214) KBRA,OVEEIG(KBRA),ISTA,OVEWAV(ISTA,KBRA)
 214     FORMAT(1H*,7X,I3,2X,F16.10,5X,I3,2X,2F16.10,7X,1H*)
C
         DO KKET=IPRFRO,IPRDIM
            WRITE(*,215) KKET,OVEWAV(KKET,KBRA)
 215        FORMAT(1H*,33X,I3,2X,2F16.10,7X,1H*)
         END DO
C
      END DO
C
      WRITE(*,216)
 216  FORMAT(79(1H*))
C
C=======================================================================
C                    CUTTING-OFF SMALL EIGENVALUES
C=======================================================================
C
       OVEMIN=EPSMIX
       IPRMIN=0
C
             DO ISTATE=IPRDIM,1,-1
C
                IF(OVEEIG(ISTATE).GT.OVEMIN) IPRMIN=ISTATE
C
             END DO
C
             IF (IPRMIN.EQ.0) THEN
C
                 WRITE (*,217)
  217            FORMAT(1H*,21X,'STOP: THE COLLECTIVE SPACE IS EMPTY',
     *                      21X,1H*,/,1H*,77X,1H*,/,79(1H*))
                 STOP
C
             END IF
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN SOME EIGENVECTORS WERE
C           ACCEPTED IN TO THE GCM SPACE
C=======================================================================
C
                 KPRDIM=IPRDIM-IPRMIN+1
C
                 WRITE(*,108) IPRDIM,KPRDIM,EPSMIX
 108             FORMAT(79(1H*),/,1H*,14X,'IPRDIM=',I3,5X,'KPRDIM=',I3,
     *               5X,'EPSMIX=',F12.10,14X,1H*,/,79(1H*))
C
                 DO JBRA=IPRMIN,IPRDIM
                    DO JKET=IPRMIN,IPRDIM
C
                       HAMCUT=C_ZERO
C
                       DO IBRA=1,IPRDIM
                          DO IKET=1,IPRDIM
C
                             HAMCUT=HAMCUT+CONJG(OVEWAV(IBRA,JBRA))
     *                                          *HCNMIX(IBRA,IKET)
     *                                          *OVEWAV(IKET,JKET)
CTMP: CONTROL PRINT-OUT
C           IF (JBRA.EQ.7.AND.JKET.EQ.7) THEN
C           WRITE(*,1888) JBRA,IBRA,JKET,IKET,CONJG(OVEWAV(IBRA,JBRA)),
C     *                   HCNMIX(IBRA,IKET),OVEWAV(IKET,JKET),HAMCUT
C 1888      FORMAT(1H%,4I3,1X,2(F9.5,1X),2(F11.5,1X),
C     *                       2(F9.5,1X),2(F11.5,1X),1H%)
C           END IF
CTMP
                          END DO
                       END DO
C
                       HAMCUT=HAMCUT/SQRT(OVEEIG(JBRA)*OVEEIG(JKET))
C
                       IF (ICMPRI.GE.2)
     *                 WRITE(*,109)
     *                      JBRA,JKET,OVEEIG(JBRA)*OVEEIG(JKET),
     *                      SQRT(OVEEIG(JBRA)*OVEEIG(JKET)),HAMCUT
 109                   FORMAT(1H*,3X,2I3,2X,F12.8,2X,
     *                                      F12.8,5X,2F16.6,3X,1H*)
C
                       KBRA=JBRA-IPRMIN+1
                       KKET=JKET-IPRMIN+1
C
                       IF (KBRA.GE.KKET) THEN
C
                           NCOUNT=KBRA+((2*KPRDIM-KKET)*(KKET-1))/2
C
                           CELMTS(NCOUNT)=HAMCUT
C
                       END IF
C
                    END DO
                 END DO
C
                 CALL DIAMAT(CELMTS,HAMEIG,HAMWAV,KPRDIM,NDCONF,KPRDIM)
C
                 WRITE(*,218)
 218             FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *             1H*,6X,'DIAGONALIZATION OF THE HAMILTONIAN MATRIX',
     *                    ' IN THE COLLECTIVE SPACE',6X,1H*,/,
     *             1H*,77X,1H*,/,79(1H*))
C
                 ISTA=1
                 DO KBRA=1,KPRDIM
                 WRITE(*,214) KBRA,HAMEIG(KBRA),
     *                        ISTA,HAMWAV(ISTA,KBRA)
                    DO KKET=IPRFRO,KPRDIM
                       WRITE(*,215) KKET,HAMWAV(KKET,KBRA)
                    END DO
                 END DO
C
                 WRITE(*,216)
C
C=======================================================================
C  RECALCULATING THE WAVE FUNCTIONS FROM THE COLLECTIVE TO INITIAL BASIS
C                   TOGETHER WITH CALCULATION OF
C        A CONTENT OF NCCI WAVE FUNCTION IN TERMS OF INITIAL KERNELS
C      SEE EQ 3 GAMOW-TELLER RESPONSE PAPER OF KONIECZKA ET AL. 2017
C=======================================================================
C
           DO KBRA=1,KPRDIM
C
             CCPROJ=0.0D0
C
               DO KBBR=1,IPRDIM
C
                  CPROJE=C_ZERO
C
                  DO IKET=1,IPRDIM
C
                     FPROJE=C_ZERO
C
                     DO JBAS=IPRMIN,IPRDIM
                        KBAS=JBAS-IPRMIN+1
C
                        FPROJE=FPROJE+OVEWAV(IKET,JBAS)
     *                                       /SQRT(OVEEIG(JBAS))
     *                                      *HAMWAV(KBAS,KBRA)
C
                     END DO
C
                     WAVFUN(IKET,KBRA)=FPROJE
C
                     CPROJE=CPROJE+WAVFUN(IKET,KBRA)
     *                            *OCNMIX(KBBR,IKET)
C
                  END DO
C
                  CONPNC(KBRA,KBBR)=ABS(CPROJE)**2
                  CCPROJ=CCPROJ+CONPNC(KBRA,KBBR)
C
               END DO
C
               DO KBBR=1,IPRDIM
C
                  CONPNC(KBRA,KBBR)=CONPNC(KBRA,KBBR)/CCPROJ
C
               END DO
C
           END DO
C
C=======================================================================
C            PRINTING THE WAVE FUNCTIONS IN THE INITIAL BASIS
C=======================================================================
C
                 WRITE(*,219)
 219             FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *             1H*,8X,'DIAGONALIZATION OF THE HAMILTONIAN MATRIX',
     *                    ' IN THE INITIAL SPACE',7X,1H*,/,
     *             1H*,21X,'THE BASIS STATES ARE NON-ORTHOGONAL',
     *                 21X,1H*,/,
     *             1H*,77X,1H*,/,79(1H*))
C
                 ISTA=1
                 DO KBRA=1,KPRDIM
                  WRITE(*,314) KBRA,HAMEIG(KBRA),ISTA,WAVFUN(ISTA,KBRA),
     *                        EIGINI(ISTA),CONPNC(KBRA,ISTA)
                    DO KKET=IPRFRO,IPRDIM
                       WRITE(*,315) KKET,WAVFUN(KKET,KBRA),
     *                              EIGINI(KKET),CONPNC(KBRA,KKET)
                    END DO
                 END DO
C
 314             FORMAT(1H*, 1X,I3,2X,F10.3,2X,I3,2X,2F14.8,4X,
     *                                          F10.3,3X,F6.4,3X,1H*)
 315             FORMAT(1H*,18X,I3,2X,2F14.8,4X,F10.3,3X,F6.4,3X,1H*)
                 WRITE(*,216)
C
C=======================================================================
C             CALCULATING ISOSPIN CONTENT AND SKYRME ENERGY
C                    CONTRIBUTIONS IN THE EIGENSTATES
C=======================================================================
C
                 IT=0
                 DO ISOSAC=JSOSMI,JSOSMA,2
                 IT=IT+1
                    DO KSTATE=1,KPRDIM
                    TCOEFF(IT,KSTATE)=C_ZERO
C
                       DO KBASIS=1,IPRDIM
                       KKERNE=MIXIND(KBASIS,1)
                          DO LBASIS=1,IPRDIM
                          LKERNE=MIXIND(LBASIS,1)
C
                             KINDEX=0
                             DO KPROAC=-IPROAC,IPROAC,2
                             KINDEX=KINDEX+1
                             LINDEX=0
                                DO LPROAC=-IPROAC,IPROAC,2
                                LINDEX=LINDEX+1
C
                                 TCOEFF(IT,KSTATE)=TCOEFF(IT,KSTATE)+
     *          CONJG(C_KT_L(KPROAC,IT,KBASIS)*WAVFUN(KBASIS,KSTATE))*
     *                C_KT_L(LPROAC,IT,LBASIS)*WAVFUN(LBASIS,KSTATE)*
     *                        OVEMIX(KKERNE,LKERNE,KINDEX,LINDEX,IT)
C
                                 ESKCON(IT,KSTATE)=ESKCON(IT,KSTATE)+
     *          CONJG(C_KT_L(KPROAC,IT,KBASIS)*WAVFUN(KBASIS,KSTATE))*
     *                C_KT_L(LPROAC,IT,LBASIS)*WAVFUN(LBASIS,KSTATE)*
     *                        ESKMIX(KKERNE,LKERNE,KINDEX,LINDEX,IT)
C
       IF (ICMPRI.GE.3)
     * WRITE(*,888) IT,KSTATE,KKERNE,LKERNE,KBASIS,LBASIS,
     *              KPROAC,LPROAC,
     *              OVEMIX(KKERNE,LKERNE,KINDEX,LINDEX,IT),
     *              TCOEFF(IT,KSTATE)
 888  FORMAT(1H$,4(2I3,1X),4F12.6,1X,1H$)
C
                                END DO
                             END DO
C
                          END DO
                       END DO
C
                    END DO
                 END DO
C
C=======================================================================
C             PRINTING ISOSPIN CONTENT OF THE EIGENSTATES
C=======================================================================
C
                 DO KSTATE=1,KPRDIM
                 IT=1
                 IT_MAX(KSTATE)=JSOSMI
                 TT_MAX(KSTATE)=REAL(TCOEFF(IT,KSTATE))
                    DO ISOSAC=JSOSMI+2,JSOSMA,2
                       IT=IT+1
                       IF (REAL(TCOEFF(IT,KSTATE)).GT.
     *                                     TT_MAX(KSTATE)) THEN
                         IT_MAX(KSTATE)=ISOSAC
                         TT_MAX(KSTATE)=REAL(TCOEFF(IT,KSTATE))
                       END IF
                    END DO
                 END DO
C
                 WRITE(*,413)
 413             FORMAT(1H*,77X,1H*,/,
     *                  1H*,18X,'ISOSPIN DECOMPOSITION OF',
     *                          ' THE EIGENSTATES',19X,1H*,/,
     *                  1H*,77X,1H*,/,79(1H*))
C
                 DO KSTATE=1,KPRDIM
                 IT=1
                 WRITE(*,414) KSTATE,HAMEIG(   KSTATE),
     *                        IT_MAX(KSTATE)/IEVEN_,CHALF_,
     *                        (1-TT_MAX(KSTATE))*100.,
     *                        JSOSMI/IEVEN_,CHALF_,TCOEFF(IT,KSTATE),
     *                                             ESKCON(IT,KSTATE)
                    DO ISOSAC=JSOSMI+2,JSOSMA,2
                       IT=IT+1
                       WRITE(*,415) ISOSAC/IEVEN_,CHALF_,
     *                                             TCOEFF(IT,KSTATE),
     *                                             ESKCON(IT,KSTATE)
                    END DO
                 END DO
C
 414             FORMAT(1H*,1X,I3,1X,F10.3,2X,I2,A2,1X,F6.3,'[%]',
     *                       1X,I2,A2,1X,2F9.6,1X,2F10.3,1X,1H*)
 415             FORMAT(1H*,32X,I2,A2,1X,2F9.6,1X,2F10.3,1X,1H*)
                 WRITE(*,216)
C
C=======================================================================
C         OPENING THE FILFER FILE CONTAINING MATRIX ELEMENTS OF
C         THE FERMI OPEARATOR:
C              <KKET|T_+/-|BRA> WHERE <KKET| DENOTES COMPONENTS
C              OF CONFIGURATION-MIXED SOLUTION IN INITIAL "BASIS"
C=======================================================================
C
          OPEN(NFIFER,FILE=FILFER,STATUS='OLD',ERR=7,FORM='FORMATTED')
C
          WRITE(NFIPRI,'(/,23(1H/),2X,''FERMI AND GT MATRIX ELEMENTS:'',
     *                                                  2X,23(1H/),/,
     *                      3(1H/),2X,68X,              3X, 3(1H/),/,
     *                      3(1H/),2X,A68,              3X, 3(1H/),/,
     *                      3(1H/),2X,68X,              3X, 3(1H/))')
     *                 FILFER
C
          GO TO 1007
C
    7     WRITE(NFIPRI,'(/,1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                     1X, 3(1H/),2X,68X,              2X, 3(1H/),/,
     *                     1X, 3(1H/),2X,A68,              2X, 3(1H/),/,
     *                     1X, 3(1H/),2X,68X,              2X, 3(1H/),/,
     *                     1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILFER
C
          STOP ' FILE FILFER NOT FOUND ON DISC'
C
 1007     CONTINUE
C
          READ (NFIFER,*) ICLEFT,ICRGHT,IT_KET,ITZKET,II_KET,EN_KET
C
          IF (ICLEFT.NE.IPRDIM) THEN
             WRITE (*,233) ICLEFT,IPRDIM
  233        FORMAT(1H*,16X,'NUMBER OF CONFIGURATIONS DIASGREE:',
     *              I3,'.NE.',I3,17X,1H*)
             STOP
          END IF
C
          IF (IABS(ISOTZL-ITZKET).NE.2) THEN
             WRITE (*,232) ISOTZL,ITZKET
  232        FORMAT(1H*,16X,'WRONG PARTICLE NUMBERS (OR Tz)   :',
     *              I3,' AND',I3,17X,1H*)
             STOP
          END IF
C
          DO IMATRI=1,ICLEFT
             DO JMATRI=1,ICRGHT
C
                READ (NFIFER,*) ICON_L,ICON_R,CMX_RE,CMX_IM,
     *                          FERREA,FERIMA,GTRREA,GTRIMA
C
                FERMAE(ICON_L,ICON_R)=CMPLX(FERREA,FERIMA)
                GTRMAT(ICON_L,ICON_R)=CMPLX(GTRREA,GTRIMA)
                CMIX_R(       ICON_R)=CMPLX(CMX_RE,CMX_IM)
C
                WRITE(*,220) ICON_L,ICON_R,CMIX_R(       ICON_R),
     *               FERMAE(ICON_L,ICON_R),GTRMAT(ICON_L,ICON_R)
 220            FORMAT(1H/,2X,2I4,1X,2F10.6,2X,2F10.6,2X,2F10.6,
     *              2X,1H/)
C
             END DO
          END DO
C
          WRITE(*,234)
 234      FORMAT(3(1H/),73X,3(1H/),/,
     *           3(1H/),2X,69(1H/),2X,3(1H/),/,79(1H*),/,
     *           1H*,77X,1H*,/,
     *           1H*,31X,'ISB CORRECTIONS',31X,1H*,/,
     *           1H*,77X,1H*)
C
      FE_SUM=0
      GT_SUM=0
C
      DO KBRA=1,KPRDIM
C
         FERMTR(KBRA)=C_ZERO
         GT_RED(KBRA)=C_ZERO
C
            DO ICON_L=1,ICLEFT
               DO ICON_R=1,ICRGHT
                  FERMTR(KBRA)=FERMTR(KBRA)+
     *                   CONJG(WAVFUN(ICON_L,KBRA))*
     *                   FERMAE(ICON_L,ICON_R)*CMIX_R(ICON_R)
                  GT_RED(KBRA)=GT_RED(KBRA)+
     *                   CONJG(WAVFUN(ICON_L,KBRA))*
     *                   GTRMAT(ICON_L,ICON_R)*CMIX_R(ICON_R)
CWS               IF (KBRA.EQ.1) THEN
CWS                 WRITE(*,99) ICON_L,ICON_R,FERMTR(KBRA),GT_RED(KBRA)
CWS 99              FORMAT(1H$,2X,2I3,2F16.10,2X,2F16.10,1H$)
CWS               END IF
               END DO
            END DO
C
         FRMOD2(KBRA)=ABS(FERMTR(KBRA))**2
         GTPROB(KBRA)=GANEU2*ABS(GT_RED(KBRA))**2/(II_KET+1)
C
         WRITE(*,222) KBRA,IPROAC,IT_MAX(KBRA),HAMEIG(KBRA),
     *                                II_KET,IT_KET,EN_KET
 222     FORMAT(1H*,1X,I3,' BRA:',2X,I2,2X,I2,2X,F10.3,
     *                    ' KET:',2X,I2,2X,I2,2X,F10.3,23X,1H*)
C
         IF (IT_MAX(KBRA).EQ.IT_KET) THEN
            IF(ITZKET.EQ.ISOTZL+2)
     *         FACT_T=IT_KET*(IT_KET+2)/4.D0-ITZKET*(ITZKET-2)/4.D0
            IF(ITZKET.EQ.ISOTZL-2)
     *         FACT_T=IT_KET*(IT_KET+2)/4.D0-ITZKET*(ITZKET+2)/4.D0
C
            DELTAC(KBRA)=1-FRMOD2(KBRA)/FACT_T
            WRITE(*,223) FERMTR(KBRA),FRMOD2(KBRA),DELTAC(KBRA)*100
 223        FORMAT(1H*,9X,'FERMI:',2X,2F10.6,2X,F10.6,2X,F10.6,'[%]',
     *                                                       13X,1H*)
         ELSE
            WRITE(*,224) FERMTR(KBRA),FRMOD2(KBRA)
 224        FORMAT(1H*,9X,'FERMI:',2X,2F10.6,2X,F10.6,15X,
     *                                                       13X,1H*)
         END IF
C
         WRITE(*,225) GT_RED(KBRA),ABS(GT_RED(KBRA)),GTPROB(KBRA)
 225     FORMAT(1H*,9X,'  G-T:',2X,2F10.6,2X,F10.6,2X,F10.6,
     *                                                    16X,1H*)
C
         FE_SUM=FE_SUM+FRMOD2(KBRA)
         GT_SUM=GT_SUM+GTPROB(KBRA)/GANEU2
C
      END DO
C
      WRITE(*,216)
      WRITE(*,226) FE_SUM,IABS(ITZKET),GT_SUM,3*IABS(ITZKET)
 226  FORMAT(1H*,77X,1H*,/,
     *       1H*,15X,'FERMI SUM RULE',19X,'G - T SUM RULE',15X,1H*,/,
     *       1H*,15X,F10.6,1X,I3,19X,F10.6,1X,I3,15X,1H*,/,1H*,77X,1H*)
      WRITE(*,216)
C
C=======================================================================
C
      CALL CPUTIM('CONMIX',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE BETAME(ISIMPY,IROTAT,MREVER,
     *                                IPAHFB,
     *                  ISOTZR,ISOMIR,ISOMAR,
     *                         NFIWAV,FILWAV,
     *                  NUBKNO,NUAKNO,NBTKNO,
     *                         IEVEN_,CHALF_,
     *                         ISOADD,NBTKNT)
C
C=======================================================================
      USE SAVLEF
      USE SAVRIG
      USE WAVR_L
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHALF_*2,FEROPE*2,FERMOP*4,GTOPER*4,GT_OPE*2
      CHARACTER
     *          FILWAV*68
C
      COMPLEX
     *          WARAUX,TARIGH,TALEFT,OVRLAP,OVKERN,
     *          PNKE10,PNKE1P,PNKE1M,
     *          GTKE00,GTKE0P,GTKE0M,
     *          GTKEP0,GTKEPP,GTKEPM,
     *          GTKEM0,GTKEMP,GTKEMM,
     *          CPNU10,CPNU1P,CPNU1M,
     *          CSPU00,CSPU0P,CSPU0M,
     *          CSPUP0,CSPUPP,CSPUPM,
     *          CSPUM0,CSPUMP,CSPUMM,
     *          ZPNU10,ZPNU1P,ZPNU1M,
     *          ZSPU00,ZSPU0P,ZSPU0M,
     *          ZSPUP0,ZSPUPP,ZSPUPM,
     *          ZSPUM0,ZSPUMP,ZSPUMM
      COMPLEX
     *          FACINT,FACI10,FACI1M,FACI1P,
     *          TRNN,TRPP,TRNP,TRPN
      COMPLEX
     *          FER_ME,GT_RED,
     *          F_KT_L,F_KT_R,
     *          GT_KAR
      COMPLEX
     *          TPNU10,TPNU1P,TPNU1M,
     *          TSPU00,TSPU0P,TSPU0M,
     *          TSPUP0,TSPUPP,TSPUPM,
     *          TSPUM0,TSPUMP,TSPUMM,
     *          TPN_10,TPN_1P,TPN_1M,
     *          TSP_00,TSP_0P,TSP_0M,
     *          TSP_P0,TSP_PP,TSP_PM,
     *          TSP_M0,TSP_MP,TSP_MM
      COMPLEX
     *          AUXDIA,C_ZERO,C_UNIT,UNIT_I
      COMPLEX
     *          SPININ,
     *          SPI_NN,SPI_PP,SPI_NP,SPI_PN,
     *          TAUXSP,TAUYSP,TAUZSP
      COMPLEX
     *          DETWRK
C
      DIMENSION
     *                SPININ(1:NDKART),SPI_NN(1:NDKART),
     *                SPI_PP(1:NDKART),SPI_PN(1:NDKART),
     *                SPI_NP(1:NDKART),TAUXSP(1:NDKART),
     *                TAUYSP(1:NDKART),TAUZSP(1:NDKART)
C
      DIMENSION
     *       LDSTAR(0:NDISOS),LDSTAL(0:NDISOS),GT_KAR(3)
C
      COMMON
     *       /RANGLE/ ALPROT,BETROT,GAMROT
C
      COMMON
     *       /FERMIL/ F_KT_L(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_L,IDIM_L,IIFERL,ITFERL,ISFERL
      COMMON
     *       /FERMIR/ F_KT_R(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_R,IDIM_R,IIFERR,ITFERR,ISFERR
C
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
C
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
      ALLOCATABLE OVRLAP(:,:)
      ALLOCATABLE WARAUX(:,:)
      ALLOCATABLE OVKERN(:,:,:,:)
      ALLOCATABLE TARIGH(:,:,:)
      ALLOCATABLE TALEFT(:,:,:)
      ALLOCATABLE PNKE10(:,:,:,:)
      ALLOCATABLE PNKE1P(:,:,:,:)
      ALLOCATABLE PNKE1M(:,:,:,:)
      ALLOCATABLE GTKE00(:,:,:,:)
      ALLOCATABLE GTKE0P(:,:,:,:)
      ALLOCATABLE GTKE0M(:,:,:,:)
      ALLOCATABLE GTKEP0(:,:,:,:)
      ALLOCATABLE GTKEPP(:,:,:,:)
      ALLOCATABLE GTKEPM(:,:,:,:)
      ALLOCATABLE GTKEM0(:,:,:,:)
      ALLOCATABLE GTKEMP(:,:,:,:)
      ALLOCATABLE GTKEMM(:,:,:,:)
C=======================================================================
C
      DIMENSION
     *        CPNU10(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CPNU1P(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CPNU1M(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TPNU10(NDPROT),TPNU1P(NDPROT),TPNU1M(NDPROT),
     *        TPN_10(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TPN_1P(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TPN_1M(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT)
      DIMENSION
     *        CSPU00(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CSPU0P(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CSPU0M(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CSPUP0(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CSPUPP(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CSPUPM(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CSPUM0(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CSPUMP(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        CSPUMM(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSPU00(NDPROT),TSPU0P(NDPROT),TSPU0M(NDPROT),
     *        TSPUP0(NDPROT),TSPUPP(NDPROT),TSPUPM(NDPROT),
     *        TSPUM0(NDPROT),TSPUMP(NDPROT),TSPUMM(NDPROT),
     *        TSP_00(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSP_0P(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSP_0M(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSP_P0(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSP_PP(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSP_PM(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSP_M0(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSP_MP(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT),
     *        TSP_MM(-NDPROI:NDPROI,-NDPROI:NDPROI,NDPROT)
      DIMENSION
     *        ZPNU10(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZPNU1P(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZPNU1M(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPU00(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPU0P(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPU0M(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPUP0(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPUPP(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPUPM(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPUM0(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPUMP(NDAKNO,-NDPROI:NDPROI,NDPROT),
     *        ZSPUMM(NDAKNO,-NDPROI:NDPROI,NDPROT)
C
      DIMENSION
     *        AUXDIA(1:4*NDSTAT),IAUXDI(1:4*NDSTAT)
      DIMENSION
     *        DETWRK(2)
      DIMENSION
     *        YBT_PN(1:NDBTKN),YBT_WG(1:NDBTKN)
      COMMON /KNOTS/
     *        XA_PNT(1:NDAKNO),XA_WGT(1:NDAKNO),
     *        XB_PNT(1:NDBKNO),XB_WGT(1:NDBKNO),
     *        XAT_PN(1:NDATKN),XAT_WG(1:NDATKN),
     *        XBT_PN(1:NDBTKN),XBT_WG(1:NDBTKN)
C
C=======================================================================
C
      CALL CPUTIM('BETAME',1)
C
C=======================================================================
C                     A L L O C A T I O N S
C=======================================================================
C
      IF (.NOT.ALLOCATED(WARIGH)) THEN
          ALLOCATE (WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WARIGH','BETAME')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(WALEFT)) THEN
          ALLOCATE (WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WALEFT','BETAME')
      END IF
C=======================================================================
      ALLOCATE (WARAUX(1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WARAUX','BETAME')
C=======================================================================
      ALLOCATE (TARIGH(1:2*NDBASE,1:8*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('TARIGH','BETAME')
C=======================================================================
      ALLOCATE (TALEFT(1:2*NDBASE,1:8*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('TALEFT','BETAME')
C=======================================================================
C
C=======================================================================
      ALLOCATE (OVRLAP(1:4*NDSTAT,1:4*NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('OVRLAP','BETAME')
C=======================================================================
      ALLOCATE (OVKERN(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('OVKERN','BETAME')
C=======================================================================
      ALLOCATE (PNKE10(1:NDASAV,1:NDBKNO,1:NDASAV,1:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('PNKE10','BETAME')
C=======================================================================
      ALLOCATE (PNKE1P(1:NDASAV,1:NDBKNO,1:NDASAV,1:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('PNKE1P','BETAME')
C=======================================================================
      ALLOCATE (PNKE1M(1:NDASAV,1:NDBKNO,1:NDASAV,1:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('PNKE1M','BETAME')
C=======================================================================
C
C=======================================================================
      ALLOCATE (GTKE00(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKE00','BETAME')
C=======================================================================
      ALLOCATE (GTKE0P(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKE0P','BETAME')
C=======================================================================
      ALLOCATE (GTKE0M(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKE0M','BETAME')
C=======================================================================
      ALLOCATE (GTKEP0(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKEP0','BETAME')
C=======================================================================
      ALLOCATE (GTKEPP(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKEPP','BETAME')
C=======================================================================
      ALLOCATE (GTKEPM(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKEPM','BETAME')
C=======================================================================
      ALLOCATE (GTKEM0(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKEM0','BETAME')
C=======================================================================
      ALLOCATE (GTKEMP(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKEMP','BETAME')
C=======================================================================
      ALLOCATE (GTKEMM(1:NDASAV,1:NDBKNO,1:NDASAV,0:NDBTKN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('GTKEMM','BETAME')
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      DO ISOS=0,NDISOS
         LDSTAR(ISOS)=LDSTAT(ISOS)
      ENDDO
C
C=======================================================================
C      READING WAVE FUNCTION OF THE DAUGHTER (LEFT STATE) NUCLEUS:
C=======================================================================
C
      CALL REA_WL(NFIWAV,   998,     1,FILWAV,
     *            ISOMIL,ISOMAL,ISOTZL)
C
      FERMOP='T+/-'
      GTOPER='G+/-'
C
      IFE_SR=1
      IGT_SR=1
C
      IF (IABS(ISOTZL-ISOTZR).NE.2) THEN
C
      WRITE(*, 14) ISFERL,IIFERL/IEVEN_,CHALF_,
     *                    ITFERL/IEVEN_,CHALF_,
     *                    ISOTZL/IEVEN_,CHALF_,FERMOP,
     *             ISFERR,IIFERR/IEVEN_,CHALF_,
     *                    ITFERR/IEVEN_,CHALF_,
     *                    ISOTZR/IEVEN_,CHALF_
C
      WRITE(*, 14) ISFERL,IIFERL/IEVEN_,CHALF_,
     *                    ITFERL/IEVEN_,CHALF_,
     *                    ISOTZL/IEVEN_,CHALF_,GTOPER,
     *             ISFERR,IIFERR/IEVEN_,CHALF_,
     *                    ITFERR/IEVEN_,CHALF_,
     *                    ISOTZR/IEVEN_,CHALF_
C
  14  FORMAT(1H*,77X,1H*,/,
     *       1H*,1X,'< i=',I2,'; I=',I2,A2,', T=',I2,A2,', Tz=',I2,A2,
     *                          ' | ',A4,' | j=',
     *                     I2,'; I=',I2,A2,', T=',I2,A2,', Tz=',I2,A2,
     *                                                 '> = 0',1X,1H*)
      WRITE(*,116)
      WRITE(*,115)
 116  FORMAT(1H*,77X,1H*)
C
      IFE_SR=0
      IGT_SR=0
C
      GO TO 1111
C
      ENDIF
C
      IF (IABS(IIFERL-IIFERR).GT.2) THEN
C
      WRITE(*, 14) ISFERL,IIFERL/IEVEN_,CHALF_,
     *                    ITFERL/IEVEN_,CHALF_,
     *                    ISOTZL/IEVEN_,CHALF_,FERMOP,
     *             ISFERR,IIFERR/IEVEN_,CHALF_,
     *                    ITFERR/IEVEN_,CHALF_,
     *                    ISOTZR/IEVEN_,CHALF_
C
      WRITE(*, 14) ISFERL,IIFERL/IEVEN_,CHALF_,
     *                    ITFERL/IEVEN_,CHALF_,
     *                    ISOTZL/IEVEN_,CHALF_,GTOPER,
     *             ISFERR,IIFERR/IEVEN_,CHALF_,
     *                    ITFERR/IEVEN_,CHALF_,
     *                    ISOTZR/IEVEN_,CHALF_
C
      WRITE(*,116)
      WRITE(*,115)
C
      IFE_SR=0
      IGT_SR=0
C
      GO TO 1111
C
      ENDIF
C
      IF (IABS(IIFERL-IIFERR).NE.0) THEN
C
      WRITE(*, 14) ISFERL,IIFERL/IEVEN_,CHALF_,
     *                    ITFERL/IEVEN_,CHALF_,
     *                    ISOTZL/IEVEN_,CHALF_,FERMOP,
     *             ISFERR,IIFERR/IEVEN_,CHALF_,
     *                    ITFERR/IEVEN_,CHALF_,
     *                    ISOTZR/IEVEN_,CHALF_
C
      WRITE(*,116)
      WRITE(*,115)
C
      IFE_SR=0
C
      ENDIF
C
      IF (IIFERL.EQ.0.AND.IIFERR.EQ.0) THEN
C
      WRITE(*, 14) ISFERL,IIFERL/IEVEN_,CHALF_,
     *                    ITFERL/IEVEN_,CHALF_,
     *                    ISOTZL/IEVEN_,CHALF_,GTOPER,
     *             ISFERR,IIFERR/IEVEN_,CHALF_,
     *                    ITFERR/IEVEN_,CHALF_,
     *                    ISOTZR/IEVEN_,CHALF_
C
      WRITE(*,116)
      WRITE(*,115)
C
      IGT_SR=0
C
      ENDIF
C
                              FEROPE='T+'
      IF (ISOTZR.EQ.ISOTZL+2) FEROPE='T-'
C
                              GT_OPE='G+'
      IF (ISOTZR.EQ.ISOTZL+2) GT_OPE='G-'
C
                              MU_ISO=+2
      IF (ISOTZR.EQ.ISOTZL+2) MU_ISO=-2
C
      DO ISOS=0,NDISOS
         LDSTAL(ISOS)=LDSTAT(ISOS)
      ENDDO
C
C=======================================================================
C         CONTROL PRINTOUT AFTER READING DATA FOR THE LEFT STATE
C=======================================================================
C
      WRITE(*,116)
C
      IF (IFE_SR.EQ.1)
     *WRITE(*, 15) ISFERL,IIFERL/IEVEN_,CHALF_,
     *                    ITFERL/IEVEN_,CHALF_,
     *                    ISOTZL/IEVEN_,CHALF_,FEROPE,
     *             ISFERR,IIFERR/IEVEN_,CHALF_,
     *                    ITFERR/IEVEN_,CHALF_,
     *                    ISOTZR/IEVEN_,CHALF_
C
      IF (IGT_SR.EQ.1)
     *WRITE(*, 15) ISFERL,IIFERL/IEVEN_,CHALF_,
     *                    ITFERL/IEVEN_,CHALF_,
     *                    ISOTZL/IEVEN_,CHALF_,GT_OPE,
     *             ISFERR,IIFERR/IEVEN_,CHALF_,
     *                    ITFERR/IEVEN_,CHALF_,
     *                    ISOTZR/IEVEN_,CHALF_
C
  15  FORMAT(1H*,4X,'< i=',I2,'; I=',I2,A2,', T=',I2,A2,', Tz=',I2,A2,
     *                          ' | ',A2,' | i=',
     *                     I2,'; I=',I2,A2,', T=',I2,A2,', Tz=',I2,A2,
     *                                                     '>',4X,1H*)
      WRITE(*,116)
C
      WRITE(*,117)
 117  FORMAT(1H*,32X,'LEFT STATE',20X,'RIGHT STATE',4X,1H*)
      WRITE(*,116)
C
      WRITE(*,118) ISOMIL/IEVEN_,CHALF_,ISOMAL/IEVEN_,CHALF_,
     *             ISOTZL/IEVEN_,CHALF_,
     *             ISOMIR/IEVEN_,CHALF_,ISOMAR/IEVEN_,CHALF_,
     *             ISOTZR/IEVEN_,CHALF_
 118  FORMAT(1H*,2X,'Tmin/Tmax/Tz ',
     *           9X,3(I4,A2),13X,3(I4,A2),4X,1H*)
      WRITE(*,116)
C
      WRITE(*,119) EIGE_L,EIGE_R
 119  FORMAT(1H*,2X,'       ENERGY',
     *           15X,F12.6,19X,F12.6,4X,1H*)
      WRITE(*,116)
C
      WRITE(*,1667) NUAKNO,NUBKNO,NBTKNO
 1667 FORMAT(1H*,19X,'NUAKNO=',I3,5X,'NUBKNO=',I3,
     *                            5X,'NBTKNO=',I3,18X,1H*)
      WRITE(*,116)
CWS
CWS      DO ISOS=0,NDISOS
CWS      WRITE(*,33) ISOS,LDSTAT(ISOS),LDUPPE(ISOS)
CWS 33   FORMAT(1H*,14X,'ISOS=',I1,5X,'LDSTAT(ISOS)=',I3,5X,
CWS     *                             'LDUPPE(ISOS)=',I3,15X,1H*)
CWS      ENDDO
CWS      WRITE(*,116)
CWS
C
C=======================================================================
C                 END OF CONTROL PRINTOUT BLOCK
C=======================================================================
C
C=======================================================================
C     SET PARAMETERS FOR ISOSPIN DECOMPOSITION OF MEAN FIELD STATES
C             IN CASE OF ANGULAR MOMENTUM PROJECTION
C   THE PARAMETERS WILL BE RESTORED TO THEIR ORIGINAL VALUES AT THE END
C=======================================================================
C
      LPROJT=1
C
      IF (NBTKNO.EQ.1) THEN
C
         LPROJT=0
C
         ISOMAL=ISOMIL+ISOADD
         ISOMAR=ISOMIR+ISOADD
C
         WRITE(*,101) NBTKNT,ISOMAL,ISOMAR
 101     FORMAT (
     *      1H*,13X,'PARAMETERS USED FOR ISOSPIN DECOMPOSITION',
     *              ' IN BETAME',13X,1H*,/,
     *      1H*, 6X,'NBTKNT =',I2,
     *              ' MAXIMUM ISOSPINS (2T) ADMITTED ARE: LEFT =',I2,
     *              ' RIGHT =',I2,6X,1H*)
C
         IF (NBTKNT.GT.NDBTKN) THEN
         WRITE(*,102) NBTKNT,NDBTKN
 102     FORMAT (1H*,77(1H-),1H*,/,
     *           1H*,8X,' STOP:',
     *                  ' RECOMPILE THE CODE WITH LARGER NUMBER',
     *                  ' OF KNOTS - NDBTKN',7X,1H*,/,
     *           1H*,26X,' NBTKNT =',I3,' >',' NDBTKN =',I3,25X,1H*,/,
     *           1H*,77(1H-),1H*)
         STOP
         END IF
C
         CALL GAULEG(-1.D0,1.D0,YBT_PN,YBT_WG,NBTKNT)
C
            DO I=1,NBTKNT
C
               YBT_PN(I)=ACOS(YBT_PN(I))
C
            END DO
C
        ITL=1
        DO ISOSAC = ISOMIL,ISOMAL,2
        ITL=ITL+1
C
           DO LPROJE = -IIFERL,IIFERL,2
              F_KT_L(LPROJE,ITL,0)=F_KT_L(LPROJE,1,0)
           END DO
C
        END DO
C
        ITR=1
        DO ISOSAC = ISOMIR,ISOMAR,2
        ITR=ITR+1
C
           DO KPROJB = -IIFERR,IIFERR,2
              F_KT_R(KPROJB,ITR,0)=F_KT_R(KPROJB,1,0)
           END DO
C
        END DO
C
        END IF
C
C=======================================================================
C             HERE BEGIN THE LOOPS OVER THE GAUSS KNOTS.
C=======================================================================
C
      DO I=1,NUAKNO
         DO K=1,NUAKNO
            DO J=1,NUBKNO
C
               ALPROT=XA_PNT(I)
               BETROT=XB_PNT(J)
               GAMROT=XA_PNT(K)
C
               DO L=1,NBTKNT
C
                 BETISO=YBT_PN(L)
C
                 DO ICHARG=0,NDISOS
C
C=======================================================================
C         FETCHING THE RIGHT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                  LSTATR=LDSTAR(ICHARG)
C
                  DO ISTATE=1,LSTATR
                     DO IBASE=1,LDBASE
                        DO ISPIN=0,NDSPIN
C
                             WARIGH(IBASE,ISTATE,ISPIN)=
     *                       SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1)
C
                        END DO
                     END DO
                  END DO
C
                  IF (NUAKNO.GT.1.OR.NUBKNO.GT.1)
     *
     *                CALL ROTWAV(LSTATR,WARIGH)
C
                  IF (IKEINV.GE.1.OR.IKEKAR.GE.1)
     *
     *                CALL INVWAV(LSTATR,IKEINV,IKEKAR,WARIGH)
C
                  DO ISTATE=1,LSTATR
                     DO IBASE=1,LDBASE
                        JBASE=  LDBASE+IBASE
                        DO ISPIN=0,NDSPIN
C
                          IF (ICHARG.EQ.0) THEN
                             TARIGH(IBASE,ISTATE,ISPIN)=
     *                       COS(BETISO/2)*WARIGH(IBASE,ISTATE,ISPIN)
C
                             TARIGH(JBASE,ISTATE,ISPIN)=
     *                       SIN(BETISO/2)*WARIGH(IBASE,ISTATE,ISPIN)
C
                          ELSE
C
                             JSTATE=LDSTAR(0)+ISTATE
                             TARIGH(IBASE,JSTATE,ISPIN)=
     *                      -SIN(BETISO/2)*WARIGH(IBASE,ISTATE,ISPIN)
C
                             TARIGH(JBASE,JSTATE,ISPIN)=
     *                       COS(BETISO/2)*WARIGH(IBASE,ISTATE,ISPIN)
C
                          ENDIF
C
                        END DO
                     END DO
                  END DO
C
C=======================================================================
C         FETCHING THE LEFT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                  LSTATL=LDSTAL(ICHARG)
C
                  DO ISTATE=1,LSTATL
                     DO IBASE=1,LDBASE
                        DO ISPIN=0,NDSPIN
C
                             WALEFT(IBASE,ISTATE,ISPIN)=
     *                       SALEFT(IBASE,ISTATE,ISPIN,ICHARG)
C
                        END DO
                     END DO
                  END DO
C
                  DO ISTATE=1,LSTATL
                     DO IBASE=1,LDBASE
                        JBASE=  LDBASE+IBASE
                        DO ISPIN=0,NDSPIN
C
                          IF (ICHARG.EQ.0) THEN
                             TALEFT(IBASE,ISTATE,ISPIN)=
     *                       WALEFT(IBASE,ISTATE,ISPIN)
C
                             TALEFT(JBASE,ISTATE,ISPIN)=C_ZERO
C
                          ELSE
C
                             JSTATE=LDSTAL(0)+ISTATE
                             TALEFT(IBASE,JSTATE,ISPIN)=C_ZERO
C
                             TALEFT(JBASE,JSTATE,ISPIN)=
     *                       WALEFT(IBASE,ISTATE,ISPIN)
C
                          ENDIF
C
                        END DO
                     END DO
                  END DO
C=======================================================================
C                    ----> END OF CHARGE LOOP <----
C=======================================================================
                 END DO
C
C=======================================================================
C                     CALCULATING THE OVERLAP MATRIX
C=======================================================================
C
                  LSTAT2=LDSTAR(0)+LDSTAR(1)
                  LBASE2=LDBASE   +LDBASE
C
                  IF (LSTAT2.GT.4*NDSTAT)
     *                STOP ' LSTAT2.GT.4*NDSTAT IN BETAME'
C
                  DO ISTATE=1,LSTAT2
                     DO JSTATE=1,LSTAT2
C
                          OVRLAP(ISTATE,JSTATE)=C_ZERO
C
                     END DO
                  END DO
C
                  DO ISTATE=1,LSTAT2
                     DO JSTATE=1,LSTAT2
                        DO IBASE=1,LBASE2
                           DO ISPIN=0,NDSPIN
C
                              OVRLAP(ISTATE,JSTATE)=
     *                        OVRLAP(ISTATE,JSTATE)
     *                        +CONJG(TALEFT(IBASE,ISTATE,ISPIN))
     *                              *TARIGH(IBASE,JSTATE,ISPIN)
C
                           END DO
                        END DO
                     END DO
                  END DO
C
C=======================================================================
C                     INVERTING THE OVERLAP MATRIX
C=======================================================================
C
                  CALL ZGECO(OVRLAP,4*NDSTAT,LSTAT2,IAUXDI,
     *                                       RICOND,AUXDIA)
                  CALL ZGEDI(OVRLAP,4*NDSTAT,LSTAT2,IAUXDI,
     *                                       DETWRK,AUXDIA,11)
C
                  OVKERN(I,J,K,L)=DETWRK(1)*10.0D0**REAL(DETWRK(2))
C
                  IF (ABS(RICOND).LT.1.0D-12.AND.IHEADE.EQ.0) THEN
C
                      WRITE(NFIPRI,*)
     *                'BE CAREFUL - THE OVERLAP MATRIX ',
     *                'MAY BE SINGULAR FOR:'
                      WRITE(NFIPRI,'(''  I='',I3,''  J='',I3,
     *                               ''  K='',I3,''  L='',I3,
     *                               ''  ICHARG='',I1,''  MPAHFB='',I1,
     *                               ''  RICOND='',E15.5)')
     *                               I,J,K,L,ICHARG,MPAHFB,RICOND
C
                      IHEADE=1
C
                  END IF
C
C=======================================================================
C     SUMMING UP RIGHT VECTORS WITH THE INVERSE OF THE OVERLAP MATRIX
C=======================================================================
C
                  DO I_BASE=1,2*LDBASE
C
                     DO ISTATE=1,LSTAT2
C
                        DO ISPIN=0,NDSPIN
C
                           WARAUX(ISTATE,ISPIN)=C_ZERO
C
                           DO KSTATE=1,LSTAT2
C
                              WARAUX(ISTATE,ISPIN)=WARAUX(ISTATE,ISPIN)
     *                                     +TARIGH(I_BASE,KSTATE,ISPIN)
     *                                     *OVRLAP(KSTATE,ISTATE)
                           END DO
C
                        END DO
                     END DO
C
                     DO ISTATE=1,LSTAT2
                        DO ISPIN=0,NDSPIN
C
                           TARIGH(I_BASE,ISTATE,ISPIN)=
     *                            WARAUX(ISTATE,ISPIN)
C
                        END DO
                     END DO
C
                  END DO
C
C=======================================================================
C                      HERE STARTS "KERNEL" BLOCK
C=======================================================================
C
               TRNN=C_ZERO
               TRPP=C_ZERO
               TRNP=C_ZERO
               TRPN=C_ZERO
C
               DO ICHARG=0,NDISOS
                  LSTATE=LDSTAT(ICHARG)
C
C=======================================================================
C          FETCHING THE LEFT WAVE FUNCTIONS FOR THE GIVEN CHARGE
C=======================================================================
C
                  DO ISTATE=1,LSTATE
                     DO IBASE=1,LDBASE
                        DO ISPIN=0,NDSPIN
C
                               WALEFT(IBASE,ISTATE,ISPIN)=
     *                         SALEFT(IBASE,ISTATE,ISPIN,ICHARG)
C
                        END DO
                     END DO
                  END DO
C
                  IF (ICHARG.EQ.0) THEN
C
C=======================================================================
C            FETCHING THE RIGHT WAVE FUNCTIONS TO BE USED TO
C               CALCULATE THE NEUTRON-NEUTRON DENSITY
C=======================================================================
C
                    DO IBASE=1,LDBASE
                       DO ISTATE=1,LSTATE
                          DO ISPIN=0,NDSPIN
C
                               WARIGH(IBASE,ISTATE,ISPIN)=
     *                         TARIGH(IBASE,ISTATE,ISPIN)
C
                          END DO
                       END DO
                    END DO
C
C=======================================================================
C           CALCULATING NEUTRON-NEUTRON TRANSITION DENSITY MATRIX
C=======================================================================
C
                    CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,
     *                                        WALEFT,WARIGH,1)
C
                    CALL SAVDEN(ISIMPY,ITPNMX)
C
                    DO IBRA=1,LDBASE
                       TRNN=TRNN+(BIG_PP(IBRA,IBRA,0)
     *                           +BIG_PP(IBRA,IBRA,1))
                    END DO
C
                    CALL SPIKER(ISIMPY,IROTAT,SPININ)
C
                    DO ISPI=1,NDKART
                       SPI_NN(ISPI)=SPININ(ISPI)
                    END DO
C
C=======================================================================
C            FETCHING THE RIGHT WAVE FUNCTIONS TO BE USED TO
C                 CALCULATE THE PROTON-NEUTRON DENSITY
C=======================================================================
C
                    DO IBASE=1,LDBASE
                       JBASE=  LDBASE+IBASE
                       DO ISTATE=1,LSTATE
                          DO ISPIN=0,NDSPIN
C
                               WARIGH(IBASE,ISTATE,ISPIN)=
     *                         TARIGH(JBASE,ISTATE,ISPIN)
C
                          END DO
                       END DO
                    END DO
C
C=======================================================================
C             CALCULATING PROTON-NEUTRON TRANSITION DENSITY MATRIX
C=======================================================================
C
                    CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,
     *                                        WALEFT,WARIGH,1)
C
                    CALL SAVDEN(ISIMPY,ITPNMX)
C
                    DO IBRA=1,LDBASE
                       TRPN=TRPN+(BIG_PP(IBRA,IBRA,0)
     *                           +BIG_PP(IBRA,IBRA,1))
                    END DO
C
                    CALL SPIKER(ISIMPY,IROTAT,SPININ)
C
                    DO ISPI=1,NDKART
                       SPI_PN(ISPI)=SPININ(ISPI)
                    END DO
C
                  ELSE
C
C=======================================================================
C             FETCHING THE RIGHT WAVE FUNCTIONS TO BE USED
C               TO CALCULATE THE PROTON-PROTON DENSITIES
C=======================================================================
C
                    DO IBASE=1,LDBASE
                       JBASE=  LDBASE+IBASE
                       DO ISTATE=1,LDSTAT(1)
                          KSTATE=  LDSTAT(0)+ISTATE
                          DO ISPIN=0,NDSPIN
                            WARIGH(IBASE,ISTATE,ISPIN)
     *                     =TARIGH(JBASE,KSTATE,ISPIN)
                          END DO
                       END DO
                    END DO
C
C=======================================================================
C            CALCULATING PROTON-PROTON TRANSITION DENSITY MATRIX
C=======================================================================
C
                    CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,
     *                                        WALEFT,WARIGH,1)
C
                    CALL SAVDEN(ISIMPY,ITPNMX)
C
                    DO IBRA=1,LDBASE
                       TRPP=TRPP+(BIG_PP(IBRA,IBRA,0)
     *                           +BIG_PP(IBRA,IBRA,1))
                    END DO
C
                    CALL SPIKER(ISIMPY,IROTAT,SPININ)
C
                    DO ISPI=1,NDKART
                       SPI_PP(ISPI)=SPININ(ISPI)
                    END DO
C
C=======================================================================
C             FETCHING THE RIGHT WAVE FUNCTIONS TO BE USED
C               TO CALCULATE THE NEUTRON-PROTON DENSITIES
C=======================================================================
C
                    DO IBASE=1,LDBASE
                       DO ISTATE=1,LDSTAT(1)
                          KSTATE=  LDSTAT(0)+ISTATE
                          DO ISPIN=0,NDSPIN
                            WARIGH(IBASE,ISTATE,ISPIN)
     *                     =TARIGH(IBASE,KSTATE,ISPIN)
                          END DO
                       END DO
                    END DO
C
C
C=======================================================================
C           CALCULATING NEUTRON-PROTON TRANSITION DENSITY MATRIX
C=======================================================================
C
                    CALL DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,
     *                                        WALEFT,WARIGH,1)
C
                    CALL SAVDEN(ISIMPY,ITPNMX)
C
                    DO IBRA=1,LDBASE
                       TRNP  =TRNP  +(BIG_PP(IBRA,IBRA,0)
     *                               +BIG_PP(IBRA,IBRA,1))
                    END DO
C
                    CALL SPIKER(ISIMPY,IROTAT,SPININ)
C
                    DO ISPI=1,NDKART
                       SPI_NP(ISPI)=SPININ(ISPI)
                    END DO
C
               END IF
C
               END DO
C
               PNKE10(I,J,K,L)= TRNN-TRPP
               PNKE1M(I,J,K,L)=+SQRT(2.)*TRNP
               PNKE1P(I,J,K,L)=-SQRT(2.)*TRPN
C
CWS: CONTROL OUTPUT
CWS        IF(I.EQ.1.AND.K.EQ.1) THEN
CWS        WRITE(*,201) I,J,K,L,PNKE10(I,J,K,L),
CWS     *               PNKE1M(I,J,K,L),PNKE1P(I,J,K,L)
CWS  201   FORMAT(1H%,2X,4I3,1X,6F10.5,2X,1H%)
CWS        ENDIF
CWS: CONTROL OUTPUT
C
C=======================================================================
C           BUILD MATRIX ELEMENTS OF THE CARTESIAN OPERATORS:
C                         O_ij = TAU_i * SIGMA_j
C=======================================================================
C
               DO ISPI=1,NDKART
C
                  TAUXSP(ISPI) =        2.*(SPI_NP(ISPI)+SPI_PN(ISPI))
                  TAUYSP(ISPI) = UNIT_I*2.*(SPI_NP(ISPI)-SPI_PN(ISPI))
                  TAUZSP(ISPI) =        2.*(SPI_NN(ISPI)-SPI_PP(ISPI))
C
               END DO
C
CWS: CONTROL OUTPUT
CWS               IF (I.EQ.1.AND.J.EQ.1.AND.K.EQ.1) THEN
CWS               WRITE(*,1999) TAUXSP(1),TAUXSP(2),TAUXSP(3),
CWS     *                       TAUYSP(1),TAUYSP(2),TAUYSP(3),
CWS     *                       TAUZSP(1),TAUZSP(2),TAUZSP(3)
CWS 1999          FORMAT(1X,6(F14.5),/,1X,6(F14.5),/,1X,6(F14.5))
CWS               END IF
CWS: CONTROL OUTPUT
C
C=======================================================================
C   REWRITE MATRIX ELEMENTS (KERNELS) TO THE SPHERICAL REPRESENTATION
C                         O_ij = TAU_1\mu * SIGMA_1\nu
C                INDICES \mu AND \nu ARE ENCODED IN THE NAMES
C=======================================================================
C
               GTKE00(I,J,K,L) =   TAUZSP(3)
               GTKE0P(I,J,K,L) = -(TAUZSP(1)+UNIT_I*TAUZSP(2))/SQRT(2.)
               GTKE0M(I,J,K,L) =  (TAUZSP(1)-UNIT_I*TAUZSP(2))/SQRT(2.)
C
               GTKEP0(I,J,K,L) = -(TAUXSP(3)+UNIT_I*TAUYSP(3))/SQRT(2.)
               GTKEPP(I,J,K,L) =  (TAUXSP(1)+UNIT_I*TAUXSP(2)
     *                            -TAUYSP(2)+UNIT_I*TAUYSP(1))/2
               GTKEPM(I,J,K,L) = -(TAUXSP(1)-UNIT_I*TAUXSP(2)
     *                            +TAUYSP(2)+UNIT_I*TAUYSP(1))/2
C
               GTKEM0(I,J,K,L) =  (TAUXSP(3)-UNIT_I*TAUYSP(3))/SQRT(2.)
               GTKEMP(I,J,K,L) = -(TAUXSP(1)+UNIT_I*TAUXSP(2)
     *                            +TAUYSP(2)-UNIT_I*TAUYSP(1))/2
               GTKEMM(I,J,K,L) =  (TAUXSP(1)-UNIT_I*TAUXSP(2)
     *                            -TAUYSP(2)-UNIT_I*TAUYSP(1))/2
CWS: CONTROL OUTPUT
CWS      WRITE(*,1668) I,J,K,L,GTKE00(I,J,K,L),GTKE0P(I,J,K,L),
CWS     *                                      GTKE0M(I,J,K,L)
CWS      WRITE(*,1669) I,J,K,L,GTKEP0(I,J,K,L),GTKEPP(I,J,K,L),
CWS     *                                      GTKEPM(I,J,K,L)
CWS      WRITE(*,1670) I,J,K,L,GTKEM0(I,J,K,L),GTKEMP(I,J,K,L),
CWS     *                                      GTKEMM(I,J,K,L)
CWS 1668 FORMAT(' 00,0P,0M:',4I3,6F12.5)
CWS 1669 FORMAT(' P0,PP,PM:',4I3,6F12.5)
CWS 1670 FORMAT(' M0,MP,MM:',4I3,6F12.5)
CWS: CONTROL OUTPUT
C
C=======================================================================
C               HERE END THE LOOPS OVER THE EULER ANGLES
C=======================================================================
C
               END DO
            END DO
         END DO
      END DO
C
C=======================================================================
C                          KERNELS ARE LOADED
C                   HERE STARTS THE "INTEGRATION" BLOCK
C=======================================================================
C
C ---> IT IS ENOUGH TO TAKE ISOSAC FROM ISOMIR TO ISOMAR
C      (SEE A FORMULA FOR FER_ME BELOW)
C
C      ISOMIN=ISOMIL
C      IF (ISOMIR.LT.ISOMIL) ISOMIN=ISOMIR
C      ISOMAX=ISOMAL
C      IF (ISOMAR.GT.ISOMAL) ISOMAX=ISOMAR
C
      ISOMIN=ISOMIR
      ISOMAX=ISOMAR
C
      IT = 0
      DO ISOSAC=ISOMIR,ISOMAR,2
      IT = IT+1
C
         DO LPROAC=-IIFERR,IIFERR,2
            DO KPROAC=-IIFERR,IIFERR,2
C
            TPN_10(LPROAC,KPROAC,IT)=C_ZERO
            TPN_1P(LPROAC,KPROAC,IT)=C_ZERO
            TPN_1M(LPROAC,KPROAC,IT)=C_ZERO
C
            TSP_00(LPROAC,KPROAC,IT)=C_ZERO
            TSP_0P(LPROAC,KPROAC,IT)=C_ZERO
            TSP_0M(LPROAC,KPROAC,IT)=C_ZERO
C
            TSP_P0(LPROAC,KPROAC,IT)=C_ZERO
            TSP_PP(LPROAC,KPROAC,IT)=C_ZERO
            TSP_PM(LPROAC,KPROAC,IT)=C_ZERO
C
            TSP_M0(LPROAC,KPROAC,IT)=C_ZERO
            TSP_MP(LPROAC,KPROAC,IT)=C_ZERO
            TSP_MM(LPROAC,KPROAC,IT)=C_ZERO
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C
      DO J=1,NUBKNO
        DO I=1,NUAKNO
          DO K=1,NUAKNO
C
            IT = 0
            DO ISOSAC=ISOMIR,ISOMAR,2
            IT = IT+1
C
            TPNU10(IT)=C_ZERO
            TPNU1P(IT)=C_ZERO
            TPNU1M(IT)=C_ZERO
C
            TSPU00(IT)=C_ZERO
            TSPU0P(IT)=C_ZERO
            TSPU0M(IT)=C_ZERO
C
            TSPUP0(IT)=C_ZERO
            TSPUPP(IT)=C_ZERO
            TSPUPM(IT)=C_ZERO
C
            TSPUM0(IT)=C_ZERO
            TSPUMP(IT)=C_ZERO
            TSPUMM(IT)=C_ZERO
C
               DO L=1,NBTKNT
C
                  FACI10=C_ZERO
                  FACI1M=C_ZERO
                  FACI1P=C_ZERO
C
                  IF (ISOSAC.GE.IABS(ISOTZR)) THEN
                     IF (ISOSAC.GE.IABS(ISOTZL  ))
     *                 FACI10=DSMALH(ISOSAC,ISOTZL  ,ISOTZR,
     *                                   YBT_PN(L),NEWWIG,ISWIND,NUANGU)
                     IF (ISOSAC.GE.IABS(ISOTZL-2))
     *                 FACI1P=DSMALH(ISOSAC,ISOTZL-2,ISOTZR,
     *                                   YBT_PN(L),NEWWIG,ISWIND,NUANGU)
                     IF (ISOSAC.GE.IABS(ISOTZL+2))
     *                 FACI1M=DSMALH(ISOSAC,ISOTZL+2,ISOTZR,
     *                                   YBT_PN(L),NEWWIG,ISWIND,NUANGU)
                  END IF
C
                  FACI10=FACI10*YBT_WG(L)*OVKERN(I,J,K,L)
                  FACI1M=FACI1M*YBT_WG(L)*OVKERN(I,J,K,L)
                  FACI1P=FACI1P*YBT_WG(L)*OVKERN(I,J,K,L)
C
                  TPNU10(IT)=TPNU10(IT)+FACI10*PNKE10(I,J,K,L)
                  TPNU1P(IT)=TPNU1P(IT)+FACI1P*PNKE1P(I,J,K,L)
                  TPNU1M(IT)=TPNU1M(IT)+FACI1M*PNKE1M(I,J,K,L)
C
                  TSPU00(IT)=TSPU00(IT)+FACI10*GTKE00(I,J,K,L)
                  TSPU0P(IT)=TSPU0P(IT)+FACI10*GTKE0P(I,J,K,L)
                  TSPU0M(IT)=TSPU0M(IT)+FACI10*GTKE0M(I,J,K,L)
C
                  TSPUP0(IT)=TSPUP0(IT)+FACI1P*GTKEP0(I,J,K,L)
                  TSPUPP(IT)=TSPUPP(IT)+FACI1P*GTKEPP(I,J,K,L)
                  TSPUPM(IT)=TSPUPM(IT)+FACI1P*GTKEPM(I,J,K,L)
C
                  TSPUM0(IT)=TSPUM0(IT)+FACI1M*GTKEM0(I,J,K,L)
                  TSPUMP(IT)=TSPUMP(IT)+FACI1M*GTKEMP(I,J,K,L)
                  TSPUMM(IT)=TSPUMM(IT)+FACI1M*GTKEMM(I,J,K,L)
C
C=======================================================================
C        HERE END THE LOOPS OVER L (BETISO) GAUSS KNOTS & ISOSPIN
C=======================================================================
C
               END DO
            END DO
C
            IT = 0
            DO ISOSAC=ISOMIR,ISOMAR,2
            IT = IT+1
               PNKE10(I,J,K,IT)=TPNU10(IT)
               PNKE1P(I,J,K,IT)=TPNU1P(IT)
               PNKE1M(I,J,K,IT)=TPNU1M(IT)
C
               GTKE00(I,J,K,IT)=TSPU00(IT)
               GTKE0P(I,J,K,IT)=TSPU0P(IT)
               GTKE0M(I,J,K,IT)=TSPU0M(IT)
C
               GTKEP0(I,J,K,IT)=TSPUP0(IT)
               GTKEPP(I,J,K,IT)=TSPUPP(IT)
               GTKEPM(I,J,K,IT)=TSPUPM(IT)
C
               GTKEM0(I,J,K,IT)=TSPUM0(IT)
               GTKEMP(I,J,K,IT)=TSPUMP(IT)
               GTKEMM(I,J,K,IT)=TSPUMM(IT)
C
            END DO
C
          END DO
        END DO
      END DO
C=======================================================================
C   ----> HERE STARTS INTEGRATION OVER THE ALPHA,BETA,GAMMA ANGLES <----
C=======================================================================
      DO J=1,NUBKNO
C
      IT = 0
      DO ISOSAC=ISOMIR,ISOMAR,2
      IT = IT+1
C
          DO I=1,NUAKNO
C
          DO KPROAC=-IIFERR,IIFERR,2
C
C=======================================================================
C         ZEROING AUXILIARY ARRAYS OF OVERLAP AND ENERGY KERNELS
C=======================================================================
C
          ZPNU10(I,KPROAC,IT)=C_ZERO
          ZPNU1P(I,KPROAC,IT)=C_ZERO
          ZPNU1M(I,KPROAC,IT)=C_ZERO
C
          ZSPU00(I,KPROAC,IT)=C_ZERO
          ZSPU0P(I,KPROAC,IT)=C_ZERO
          ZSPU0M(I,KPROAC,IT)=C_ZERO
C
          ZSPUP0(I,KPROAC,IT)=C_ZERO
          ZSPUPP(I,KPROAC,IT)=C_ZERO
          ZSPUPM(I,KPROAC,IT)=C_ZERO
C
          ZSPUM0(I,KPROAC,IT)=C_ZERO
          ZSPUMP(I,KPROAC,IT)=C_ZERO
          ZSPUMM(I,KPROAC,IT)=C_ZERO
C
C=======================================================================
C         BELOW WE INTEGRATE KERNELS OVER THE GAMMA EULER ANGLE AND
C         AT THE SAME TIME WE MULTIPLY THEM BY THE  GAUSS  WEIGHTS
C=======================================================================
C
              DO K=1,NUAKNO
C
              GAMM_K=XA_PNT(K)*0.5D0*KPROAC
C
              FACINT=XA_WGT(K)*(COS(GAMM_K)+UNIT_I*SIN(GAMM_K))
C
                  ZPNU10(I,KPROAC,IT)=ZPNU10(I,KPROAC,IT)
     *                           +FACINT*PNKE10(I,J,K,IT)
                  ZPNU1P(I,KPROAC,IT)=ZPNU1P(I,KPROAC,IT)
     *                           +FACINT*PNKE1P(I,J,K,IT)
                  ZPNU1M(I,KPROAC,IT)=ZPNU1M(I,KPROAC,IT)
     *                           +FACINT*PNKE1M(I,J,K,IT)
C
                  ZSPU00(I,KPROAC,IT)=ZSPU00(I,KPROAC,IT)
     *                           +FACINT*GTKE00(I,J,K,IT)
                  ZSPU0P(I,KPROAC,IT)=ZSPU0P(I,KPROAC,IT)
     *                           +FACINT*GTKE0P(I,J,K,IT)
                  ZSPU0M(I,KPROAC,IT)=ZSPU0M(I,KPROAC,IT)
     *                           +FACINT*GTKE0M(I,J,K,IT)
C
                  ZSPUP0(I,KPROAC,IT)=ZSPUP0(I,KPROAC,IT)
     *                           +FACINT*GTKEP0(I,J,K,IT)
                  ZSPUPP(I,KPROAC,IT)=ZSPUPP(I,KPROAC,IT)
     *                           +FACINT*GTKEPP(I,J,K,IT)
                  ZSPUPM(I,KPROAC,IT)=ZSPUPM(I,KPROAC,IT)
     *                           +FACINT*GTKEPM(I,J,K,IT)
C
                  ZSPUM0(I,KPROAC,IT)=ZSPUM0(I,KPROAC,IT)
     *                           +FACINT*GTKEM0(I,J,K,IT)
                  ZSPUMP(I,KPROAC,IT)=ZSPUMP(I,KPROAC,IT)
     *                           +FACINT*GTKEMP(I,J,K,IT)
                  ZSPUMM(I,KPROAC,IT)=ZSPUMM(I,KPROAC,IT)
     *                           +FACINT*GTKEMM(I,J,K,IT)
C
C=======================================================================
C          HERE END THE LOOPS  OVER THE  GAMMA (K) GAUSS  KNOTS
C         AND THE LOOP OVER THE K PROJECTION ON THE INTRINSIC AXIS
C=======================================================================
C
              END DO
          END DO
C
C=======================================================================
C           HERE END THE LOOPS  OVER THE  ALPHA (I) GAUSS  KNOTS
C=======================================================================
C
        END DO
C
C
C=======================================================================
C         HERE STARTS THE LOOP OVER THE K' PROJECTION ON THE INTRINSIC
C         AXIS; INDEX "LPROAC", AND OVER THE K PROJECTION ON THE
C         INTRINSIC AXIS; INDEX "KPROAC".
C=======================================================================
C
          DO LPROAC=-IIFERR,IIFERR,2
            DO KPROAC=-IIFERR,IIFERR,2
C
C=======================================================================
C                   ZEROING AUXILIARY ARRAYS
C=======================================================================
C
              CPNU10(LPROAC,KPROAC,IT)=C_ZERO
              CPNU1P(LPROAC,KPROAC,IT)=C_ZERO
              CPNU1M(LPROAC,KPROAC,IT)=C_ZERO
C
              CSPU00(LPROAC,KPROAC,IT)=C_ZERO
              CSPU0P(LPROAC,KPROAC,IT)=C_ZERO
              CSPU0M(LPROAC,KPROAC,IT)=C_ZERO
C
              CSPUP0(LPROAC,KPROAC,IT)=C_ZERO
              CSPUPP(LPROAC,KPROAC,IT)=C_ZERO
              CSPUPM(LPROAC,KPROAC,IT)=C_ZERO
C
              CSPUM0(LPROAC,KPROAC,IT)=C_ZERO
              CSPUMP(LPROAC,KPROAC,IT)=C_ZERO
              CSPUMM(LPROAC,KPROAC,IT)=C_ZERO
C
C=======================================================================
C         HERE WE INTEGRATE THE KERNELS OVER THE ALPHA EULER ANGLE
C=======================================================================
C
              DO I=1,NUAKNO
C
              ALPH_L=XA_PNT(I)*0.5D0*LPROAC
              FACINT=XA_WGT(I)*(COS(ALPH_L)+UNIT_I*SIN(ALPH_L))
C
              CPNU10(LPROAC,KPROAC,IT)=CPNU10(LPROAC,KPROAC,IT)
     *                         +FACINT*ZPNU10(I,     KPROAC,IT)
              CPNU1P(LPROAC,KPROAC,IT)=CPNU1P(LPROAC,KPROAC,IT)
     *                         +FACINT*ZPNU1P(I,     KPROAC,IT)
              CPNU1M(LPROAC,KPROAC,IT)=CPNU1M(LPROAC,KPROAC,IT)
     *                         +FACINT*ZPNU1M(I,     KPROAC,IT)
C
              CSPU00(LPROAC,KPROAC,IT)=CSPU00(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPU00(I,     KPROAC,IT)
              CSPU0P(LPROAC,KPROAC,IT)=CSPU0P(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPU0P(I,     KPROAC,IT)
              CSPU0M(LPROAC,KPROAC,IT)=CSPU0M(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPU0M(I,     KPROAC,IT)
C
              CSPUP0(LPROAC,KPROAC,IT)=CSPUP0(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPUP0(I,     KPROAC,IT)
              CSPUPP(LPROAC,KPROAC,IT)=CSPUPP(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPUPP(I,     KPROAC,IT)
              CSPUPM(LPROAC,KPROAC,IT)=CSPUPM(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPUPM(I,     KPROAC,IT)
C
              CSPUM0(LPROAC,KPROAC,IT)=CSPUM0(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPUM0(I,     KPROAC,IT)
              CSPUMP(LPROAC,KPROAC,IT)=CSPUMP(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPUMP(I,     KPROAC,IT)
              CSPUMM(LPROAC,KPROAC,IT)=CSPUMM(LPROAC,KPROAC,IT)
     *                         +FACINT*ZSPUMM(I,     KPROAC,IT)
C
C=======================================================================
C         HERE ENDS THE LOOP OVER THE ALPHA GAUSS KNOTS (I), THE
C         LOOPS OVER THE L AND K PROJECTIONS ON THE INTRINSIC AXIS,
C         AND THE LOOP OVER THE ISOSPIN
C=======================================================================
C
              END DO
C
            END DO
          END DO
C
       END DO
C
C=======================================================================
C               HERE STARTS FINAL INTEGRATION OVER BETA (J)
C=======================================================================
C
            DO LPROAC=-IIFERR,IIFERR,2
C
               DO KPROAC=-IIFERR,IIFERR,2
C
                  FACINT=XB_WGT(J)*DSMALH(IIFERR,LPROAC,KPROAC,
     *                                   XB_PNT(J),NEWWIG,ISWIND,NUANGU)
C
                  IT = 0
                  DO ISOSAC=ISOMIR,ISOMAR,2
                  IT = IT+1
C
                  TPN_10(LPROAC,KPROAC,IT)=
     *            TPN_10(LPROAC,KPROAC,IT)
     *                   +FACINT*CPNU10(LPROAC,KPROAC,IT)
                  TPN_1P(LPROAC,KPROAC,IT)=
     *            TPN_1P(LPROAC,KPROAC,IT)
     *                   +FACINT*CPNU1P(LPROAC,KPROAC,IT)
                  TPN_1M(LPROAC,KPROAC,IT)=
     *            TPN_1M(LPROAC,KPROAC,IT)
     *                   +FACINT*CPNU1M(LPROAC,KPROAC,IT)
C
                  TSP_00(LPROAC,KPROAC,IT)=
     *            TSP_00(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPU00(LPROAC,KPROAC,IT)
                  TSP_0P(LPROAC,KPROAC,IT)=
     *            TSP_0P(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPU0P(LPROAC,KPROAC,IT)
                  TSP_0M(LPROAC,KPROAC,IT)=
     *            TSP_0M(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPU0M(LPROAC,KPROAC,IT)
C
                  TSP_P0(LPROAC,KPROAC,IT)=
     *            TSP_P0(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPUP0(LPROAC,KPROAC,IT)
                  TSP_PP(LPROAC,KPROAC,IT)=
     *            TSP_PP(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPUPP(LPROAC,KPROAC,IT)
                  TSP_PM(LPROAC,KPROAC,IT)=
     *            TSP_PM(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPUPM(LPROAC,KPROAC,IT)
C
                  TSP_M0(LPROAC,KPROAC,IT)=
     *            TSP_M0(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPUM0(LPROAC,KPROAC,IT)
                  TSP_MP(LPROAC,KPROAC,IT)=
     *            TSP_MP(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPUMP(LPROAC,KPROAC,IT)
                  TSP_MM(LPROAC,KPROAC,IT)=
     *            TSP_MM(LPROAC,KPROAC,IT)
     *                   +FACINT*CSPUMM(LPROAC,KPROAC,IT)
C
C=======================================================================
C              HERE ENDS THE INTERNAL LOOP OVER THE ISOSPIN
C=======================================================================
C
              END DO
C=======================================================================
C         HERE END THE LOOPS OVER THE ANGULAR MOMENTUM PROJECTIONS
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C              HERE ENDS THE LOOP OVER THE BETA GAUSS KNOTS
C=======================================================================
C
      END DO
C
C=======================================================================
C         MULTIPLYING THE INTEGRATED KERNELS BY OVERALL FACTORS
C=======================================================================
C
         DO LPROAC=-IIFERR,IIFERR,2
C
            DO KPROAC=-IIFERR,IIFERR,2
C
               IF (NUBKNO.EQ.1) THEN
                   FACNOI=             1/( 4.0D0*PI*PI)
               ELSE
                   FACNOI=(IIFERR+1.0D0)/( 8.0D0*PI*PI)
               ENDIF
C
               IT=0
C
                  DO ISOSAC=ISOMIR,ISOMAR,2
C
                  IT=IT+1
C
                  IF (NBTKNT.EQ.1) THEN
                      FACNOR=FACNOI
                  ELSE
                      FACNOR=FACNOI*(ISOSAC+1.0D0)/2.D0
                  ENDIF
C
                  TPN_10(LPROAC,KPROAC,IT)=
     *            TPN_10(LPROAC,KPROAC,IT)*FACNOR
                  TPN_1P(LPROAC,KPROAC,IT)=
     *            TPN_1P(LPROAC,KPROAC,IT)*FACNOR
                  TPN_1M(LPROAC,KPROAC,IT)=
     *            TPN_1M(LPROAC,KPROAC,IT)*FACNOR
C
                  TSP_00(LPROAC,KPROAC,IT)=
     *            TSP_00(LPROAC,KPROAC,IT)*FACNOR
                  TSP_0P(LPROAC,KPROAC,IT)=
     *            TSP_0P(LPROAC,KPROAC,IT)*FACNOR
                  TSP_0M(LPROAC,KPROAC,IT)=
     *            TSP_0M(LPROAC,KPROAC,IT)*FACNOR
C
                  TSP_P0(LPROAC,KPROAC,IT)=
     *            TSP_P0(LPROAC,KPROAC,IT)*FACNOR
                  TSP_PP(LPROAC,KPROAC,IT)=
     *            TSP_PP(LPROAC,KPROAC,IT)*FACNOR
                  TSP_PM(LPROAC,KPROAC,IT)=
     *            TSP_PM(LPROAC,KPROAC,IT)*FACNOR
C
                  TSP_M0(LPROAC,KPROAC,IT)=
     *            TSP_M0(LPROAC,KPROAC,IT)*FACNOR
                  TSP_MP(LPROAC,KPROAC,IT)=
     *            TSP_MP(LPROAC,KPROAC,IT)*FACNOR
                  TSP_MM(LPROAC,KPROAC,IT)=
     *            TSP_MM(LPROAC,KPROAC,IT)*FACNOR
C
               END DO
C
C=======================================================================
C                HERE END THE LOOPS OVER THE PROJECTIONS
C=======================================================================
C
            END DO
         END DO
C
C=======================================================================
C
C        CALCULATE MATRIX ELEMENT OF THE FERMI TRANSITION OPERATOR
C
C=======================================================================
C
         FER_ME=C_ZERO
C
         IF (IFE_SR.EQ.1) THEN
C
         ITL=0
         DO ISOACL=ISOMIL,ISOMAL,2
         ITL=ITL+1
C
            ITR=0
            DO ISOACR=ISOMIR,ISOMAR,2
            ITR=ITR+1
C
               IF (ISOTZR.EQ.ISOTZL+2)
     *         CGALL=CGCOEF(ISOACR,ISOTZR  , 2,-2,ISOACL,ISOTZL)
               IF (ISOTZR.EQ.ISOTZL-2)
     *         CGALL=CGCOEF(ISOACR,ISOTZR  , 2, 2,ISOACL,ISOTZL)
C
               CG_10=CGCOEF(ISOACR,ISOTZL  , 2, 0,ISOACL,ISOTZL)
               CG_1P=CGCOEF(ISOACR,ISOTZL-2, 2, 2,ISOACL,ISOTZL)
               CG_1M=CGCOEF(ISOACR,ISOTZL+2, 2,-2,ISOACL,ISOTZL)
C
               DO LPROJE=-IIFERR,IIFERR,2
               DO KPROJB=-IIFERR,IIFERR,2
C
               FER_ME = FER_ME +
     *           CONJG(F_KT_L(LPROJE,ITL,0))*F_KT_R(KPROJB,ITR,0)*
     *                 CGALL*(CG_10*TPN_10(LPROJE,KPROJB,ITR)+
     *                        CG_1P*TPN_1P(LPROJE,KPROJB,ITR)+
     *                        CG_1M*TPN_1M(LPROJE,KPROJB,ITR))
C
CWS: CONTROL OUTPUT
CWS               WRITE (*,701) LPROJE,KPROJB,
CWS     *                       CG_1P*TPN_1P(LPROJE,KPROJB,ITR),
CWS     *                       CG_1M*TPN_1M(LPROJE,KPROJB,ITR)
CWS 701           FORMAT (1H%,2X,2I4,5X,2F12.6,2F12.6,14X,1H%)
CWS: CONTROL OUTPUT
C
               END DO
               END DO
C
            END DO
         END DO
C
C=======================================================================
C   FER_ME CALCULATED ABOVE CORRESPONDS TO
C           <I, T, Tz | T_{1 +/-1} | I, T', Tz-/+1 >
C   HENCE, THE TRUE FERMI M.E. MUST BE SCALED AS FOLLOWS:
C           <I, T, Tz | T_{+/-} | I, T', Tz-/+1 >  =
C                  -/+ <I, T, Tz| T_{1 +/-1} | I, T', Tz-/+1 > / SQRT(2)
C=======================================================================
C
      IF (ISOTZR.EQ.ISOTZL+2)
     *                  FER_ME= FER_ME/SQRT(2.0D0)
      IF (ISOTZR.EQ.ISOTZL-2)
     *                  FER_ME=-FER_ME/SQRT(2.0D0)
C
      WRITE(*,116)
      WRITE(*,112) FER_ME, ABS(FER_ME)**2
 112  FORMAT(1H*,3X,'FERMI MATRIX ELEMENT:',2F14.10,
     *              ' |MF|^2=',F14.10,3X,1H*)
C
      WRITE(*,116)
C
      IF (ITFERR.EQ.ITFERL) THEN
          IF(ISOTZR.EQ.ISOTZL+2)
     *    FACT_T=ITFERR*(ITFERR+2)/4.D0-ISOTZR*(ISOTZR-2)/4.D0
          IF(ISOTZR.EQ.ISOTZL-2)
     *    FACT_T=ITFERR*(ITFERR+2)/4.D0-ISOTZR*(ISOTZR+2)/4.D0
C
C=======================================================================
C                  CALCULATE COULOMB CORRECTION
C                  |M_F|^2 = FACT_T (1-DELTA_C)
C             see HARDY & TOWNER arXiv:0812.1202  Eq. (6)
C            ---------------------------------------------
C=======================================================================
C
      DELTA_C=1-ABS(FER_ME)**2/FACT_T
C
      WRITE(*,109) DELTA_C*100
 109  FORMAT(1H*,15X,'THE CALCULATED ISOSPIN MIXING IS =',
     *                                F10.6,'[%]',15X,1H*)
      WRITE(*,116)
C
      ENDIF
C
      WRITE(*,115)
 115  FORMAT(79(1H*))
C
      END IF
C=======================================================================
C                  END OF THE FERMI TRANSITION ME BLOCK
C=======================================================================
C
C=======================================================================
C     CALCULATE REDUCED MATRIX ELEMENT OF THE G-T TRANSITION OPERATOR
C=======================================================================
C
         IF (IGT_SR.EQ.1) THEN
C
            ITR=0
            DO ISOACR=ISOMIR,ISOMAR,2
            ITR=ITR+1
C
               DO LPROJE=-IIFERR,IIFERR,2
               DO KPROJB=-IIFERR,IIFERR,2
C
CWS: CONTROL OUTPUT
CWS           WRITE(*,1998) LPROJE,KPROJB,ISOACR,
CWS     *     TSP_00(LPROJE,KPROJB,ITR),TSP_0P(LPROJE,KPROJB,ITR),
CWS     *     TSP_0M(LPROJE,KPROJB,ITR),TSP_P0(LPROJE,KPROJB,ITR),
CWS     *     TSP_PP(LPROJE,KPROJB,ITR),TSP_PM(LPROJE,KPROJB,ITR),
CWS     *     TSP_M0(LPROJE,KPROJB,ITR),TSP_MP(LPROJE,KPROJB,ITR),
CWS     *     TSP_MM(LPROJE,KPROJB,ITR)
CWS 1998      FORMAT(1H&,2X,'L,K,T: ',3I4,56X,1H&,/,
CWS     *                  1H&,2X,6(F12.8),3X,1H&,/,
CWS     *                  1H&,2X,6(F12.8),3X,1H&,/,
CWS     *                  1H&,2X,6(F12.8),3X,1H&)
CWS: CONTROL OUTPUT
C
               END DO
               END DO
C
            END DO
C
         GT_RED=C_ZERO
C
         ITL=0
         DO ISOACL=ISOMIL,ISOMAL,2
         ITL=ITL+1
C
            ITR=0
            DO ISOACR=ISOMIR,ISOMAR,2
            ITR=ITR+1
C
               IF (ISOTZR.EQ.ISOTZL+2)
     *         CGTALL=CGCOEF(ISOACR,ISOTZR  , 2,-2,ISOACL,ISOTZL)
               IF (ISOTZR.EQ.ISOTZL-2)
     *         CGTALL=CGCOEF(ISOACR,ISOTZR  , 2, 2,ISOACL,ISOTZL)
C
               CGT_10=CGCOEF(ISOACR,ISOTZL  , 2, 0,ISOACL,ISOTZL)
               CGT_1P=CGCOEF(ISOACR,ISOTZL-2, 2, 2,ISOACL,ISOTZL)
               CGT_1M=CGCOEF(ISOACR,ISOTZL+2, 2,-2,ISOACL,ISOTZL)
C
               DO LPROJE=-IIFERL,IIFERL,2
               DO KPROJB=-IIFERR,IIFERR,2
C
               CGI_10=CGCOEF(IIFERR,LPROJE  , 2, 0,IIFERL,LPROJE)
               CGI_1P=CGCOEF(IIFERR,LPROJE-2, 2, 2,IIFERL,LPROJE)
               CGI_1M=CGCOEF(IIFERR,LPROJE+2, 2,-2,IIFERL,LPROJE)
C
               IF (IIFERR.GE.IABS(LPROJE))
     *         GT_RED = GT_RED +
     *             CONJG(F_KT_L(LPROJE,ITL,0))*F_KT_R(KPROJB,ITR,0)*
     *             CGTALL*(CGT_10*CGI_10*TSP_00(LPROJE  ,KPROJB,ITR)+
     *                     CGT_1P*CGI_10*TSP_P0(LPROJE  ,KPROJB,ITR)+
     *                     CGT_1M*CGI_10*TSP_M0(LPROJE  ,KPROJB,ITR))
C
               IF (IIFERR.GE.IABS(LPROJE-2))
     *         GT_RED = GT_RED +
     *             CONJG(F_KT_L(LPROJE,ITL,0))*F_KT_R(KPROJB,ITR,0)*
     *             CGTALL*(CGT_10*CGI_1P*TSP_0P(LPROJE-2,KPROJB,ITR)+
     *                     CGT_1P*CGI_1P*TSP_PP(LPROJE-2,KPROJB,ITR)+
     *                     CGT_1M*CGI_1P*TSP_MP(LPROJE-2,KPROJB,ITR))
C
               IF (IIFERR.GE.IABS(LPROJE+2))
     *         GT_RED = GT_RED +
     *             CONJG(F_KT_L(LPROJE,ITL,0))*F_KT_R(KPROJB,ITR,0)*
     *             CGTALL*(CGT_10*CGI_1M*TSP_0M(LPROJE+2,KPROJB,ITR)+
     *                     CGT_1P*CGI_1M*TSP_PM(LPROJE+2,KPROJB,ITR)+
     *                     CGT_1M*CGI_1M*TSP_MM(LPROJE+2,KPROJB,ITR))
C
CWS CONTROL:
CWS      WRITE(*,1997) LPROJE,KPROJB,ISOACL,ISOACR,
CWS     *              CONJG(F_KT_L(LPROJE,ITL,0))*F_KT_R(KPROJB,ITR,0),
CWS     *              CGTALL,CGT_10,CGT_1P,CGT_1M,CGI_10,CGI_1P,CGI_1M,
CWS     *              GT_RED
CWS 1997 FORMAT(1X,'KL,KR,TL,TR,GT:',4I4,5X,2F14.10,/,1X,7F10.6,2F14.10)
CWS CONTROL:
C
               END DO
               END DO
C
            END DO
         END DO
C
C=======================================================================
C                         SUM OVER POLARIZATIONS
C=======================================================================
C
      GT_KAR=C_ZERO
      GT_MAT=0.D0
C
         DO LPROJE=-IIFERL,IIFERL,2
            DO KPROJB=-IIFERR,IIFERR,2
C
            GT_KAR(1)=
     *       (CGCOEF(IIFERR,KPROJB, 2,-2,IIFERL,LPROJE)
     *       -CGCOEF(IIFERR,KPROJB, 2, 2,IIFERL,LPROJE))*GT_RED/2.
C
            GT_KAR(2)=UNIT_I*
     *       (CGCOEF(IIFERR,KPROJB, 2,-2,IIFERL,LPROJE)
     *       +CGCOEF(IIFERR,KPROJB, 2, 2,IIFERL,LPROJE))*GT_RED/2.
C
            GT_KAR(3)=
     *        CGCOEF(IIFERR,KPROJB, 2, 0,IIFERL,LPROJE)*GT_RED/SQRT(2.)
C
            GT_MAT = GT_MAT + ABS(GT_KAR(1))**2+ABS(GT_KAR(2))**2
     *                                         +ABS(GT_KAR(3))**2
C
      WRITE(*,1992) LPROJE,KPROJB,GT_KAR(1),GT_KAR(2),GT_KAR(3),GT_MAT
 1992 FORMAT(1H*,1X,2I4,3(1X,2F9.5),F10.6,1X,1H*)
C
            END DO
        END DO
C
      WRITE(*,1993) SQRT(GT_MAT),GT_MAT/3,GT_MAT/(IIFERL+1)
 1993 FORMAT(1H*,55X,'|GT_MAT|  =',F10.6,1X,1H*,/,
     *       1H*,55X,'|GT_MAT|/3=',F10.6,1X,1H*,/,
     *       1H*,55X,'  B(GT)   =',F10.6,1X,1H*)
      WRITE(*,116)
C
C=======================================================================
C       PROPERLY NORMALIZED REDUCED MATRIX ELEMENT OF THE G-T
C  GT^(+/-)_{1M} = -/+ 1/SQRT(2) * SUM_i [TAU_(1 +/-1) SIGMA_1{M}]
C                   OPERATOR EQUALS [B&M 1A-60]:
C=======================================================================
C
C OVERALL PHASE IS STILL MISSING!!!!
C ----------------------------------
C
      GT_RED = GT_RED/SQRT(2.D0)
C
      GT_RED = SQRT(IIFERL+1.D0)*GT_RED
C
C=======================================================================
C    TOTAL GT PROBABILITY SUMMED UP OVER mu=-1,0,1 AND POLARIZATIONS OF
C    THE FINAL STATE M EQUALS [B&M 1A-67]:
C=======================================================================
C
      GTPROB = ABS(GT_RED)**2/(IIFERR+1)
      GA_NEU =-1.2701
C
      WRITE(*,116)
      WRITE(*,111) GT_RED, ABS(GT_RED), GTPROB, GTPROB*GA_NEU**2
 111  FORMAT(1H*,1X,'GAMOW-TELLER REDUCED ME:',2F14.10,
     *              ' |M_GT|= ',F14.10,1X,1H*,/,
     *       1H*,4X,'B_GT = |M_GT|^2/(2I_i+1) =',F14.10,
     *              '  (g_A)^2*B_GT =',F14.10,3X,1H*)
C
      WRITE(*,116)
      WRITE(*, 78) IIFERL/IEVEN_,CHALF_,IIFERR/IEVEN_,CHALF_,
     *                           GTPROB*(IIFERR+1)/(IIFERL+1),
     *               (GA_NEU)**2*GTPROB*(IIFERR+1)/(IIFERL+1)
  78  FORMAT(1H*,3X,I3,A2,' --->',I3,A2,
     *          ' TRANSITION B_GT: ',F10.6,' AND (g_A)^2*B_GT:',
     *                                            F10.6,3X,1H*)
C
      WRITE(*,116)
      WRITE(*,115)
C
      END IF
C
C=======================================================================
C  RESTORE ISOSPIN PROJECTION PARAMERES TO THEIR INITIAL VALUES IN
C     CASE OF LPROJT.EQ.0 (SEE THE BEGINNING OF THE SUBROUTINE)
C=======================================================================
C
      IF (LPROJT.EQ.0) THEN
C
         ITL=1
         DO ISOSAC = ISOMIL,ISOMAL,2
         ITL=ITL+1
C
            DO LPROJE = -IIFERL,IIFERL,2
               F_KT_L(LPROJE,ITL,0)=C_ZERO
            END DO
C
         END DO
C
         ITR=1
         DO ISOSAC = ISOMIR,ISOMAR,2
         ITR=ITR+1
C
            DO KPROJB = -IIFERR,IIFERR,2
               F_KT_R(KPROJB,ITR,0)=C_ZERO
            END DO
C
         END DO
C
         ISOMAL=ISOMIL
         ISOMAR=ISOMIR
C
      END IF
C
C=======================================================================
      DEALLOCATE (OVRLAP)
      DEALLOCATE (WARAUX)
      DEALLOCATE (TARIGH)
      DEALLOCATE (TALEFT)
      DEALLOCATE (OVKERN,PNKE10,PNKE1P,PNKE1M)
      DEALLOCATE (GTKE00,GTKE0P,GTKE0M)
      DEALLOCATE (GTKEP0,GTKEPP,GTKEPM)
      DEALLOCATE (GTKEM0,GTKEMP,GTKEMM)
C=======================================================================
C
 1111 CONTINUE
C
      CALL CPUTIM('BETAME',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIAPRO(JPROMI,JPROMA,KPROJE,IAXIAL,IHALF_,
     *                  JSOSMI,JSOSMA,ISOSTZ,LPROJJ,LPROJT,
     *                                ICUTOV,CUTOWE,CUTOWF,
     *                                IMIPRI,ISLPRI,ISUPRI,
     *                                       NUISOM,IENPRI,
     *                                       MINDIK,IBETME)
C
C=======================================================================
      USE hfodd_sizes
      USE TXXX_Y
      USE HAMMIX
C=======================================================================
C
      CHARACTER
     *          CHALF_*2
      CHARACTER
     *          HAFLIN*38,HAFLIM*38
C
      COMPLEX
     *          EPROJE,OPROJE
      COMPLEX
     *          WFI0T1,WPROI0,F_KT_R
      COMPLEX
     *          C_ZERO,FPROJE,HAMCUT
C
      DIMENSION
     *          OVEEIG(1:NDPROD),HAMEIG(1:NDPROD)
C     DIMENSION
C    *          AVRG_K(0:NDPROI,1:NDPROD,NDISOM)
      DIMENSION
     *          LINDIM(2),HAFLIN(1:NDPROD,2)
C
      COMMON
     *       /TMX0RA/ WPROI0(NDPROT),WFI0T1(NDPROT),E_I0T1
      COMMON
     *       /TMX0RB/ NPROI0(NDPROT),I_I0T1
      COMMON
     *       /FERMIR/ F_KT_R(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_R,IDIM_R,IIFERR,ITFERR,ISFERR
      COMMON
     *       /APROJE/ EPROJE(NDPROM,NDISOM),OPROJE(NDPROM,NDISOM)
      COMMON
     *       /ALLPRO/ NUMPRO(0:NDPROI,0:NDISOM)
      COMMON
     *       /ISOIND/ ISOMAT(NDISOM),LSOMAT(NDISOM),KSOMAT(NDISOM)
      COMMON
     *       /IMKIND/ INDIMK(0:NDPROI,-NDPROI:NDPROI,-NDPROI:NDPROI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      IND_IK(IPRDUM,KPRDUM)=(IPRDUM**2-IHALF_)/4+(IPRDUM+KPRDUM)/2+1
C     INDIMK(IPRDUM,MPRDUM,KPRDUM)=(IPRDUM*(IPRDUM-1)*(IPRDUM+1))/6
C    *      +(IPRDUM+1)*((IPRDUM+MPRDUM)/2)+(IPRDUM+KPRDUM)/2+1
C
      CALL CPUTIM('DIAPRO',1)
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HAMILTONIAN MATRIX FOR
C         THE ANGULAR-MOMENTUM AND 1D-ISOSPIN PROJECTED STATES
C=======================================================================
C         THE SUBROUTINE GIVES THE K-MIXED EIGENVECTORS IN THE  ARRAY
C         "WAVPRO", THEIR EIGEN-ENERGIES IN THE  ARRAY  "ENEPRO"  AND
C         THE NUMBER THEREOF IN THE  ARRAY "NUMPRO". VALUES OF "0" IN
C         NUMPRO  ARRAY MEAN THE ABSENCE OF THE GIVEN SPIN  COMPONENT
C         IN THE HF WAVE FUNCTION; IN THIS CASE "WAVPRO" AND "ENEPRO"
C         ARRAYS ARE NOT DEFINED.
C=======================================================================
C
                       CHALF_='  '
      IF (IHALF_.EQ.1) CHALF_='/2'
C
      IEVEN_=2/(IHALF_+1)
C
      ISTORE=0
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        ALLOCATING LOCAL ARRAYS
C=======================================================================
C
      ALLOCATE (CELMTS(1:((NDPROD+1)*NDPROD)/2),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIAPRO')
      ALLOCATE (OVEWAV(1:NDPROD,1:NDPROD),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('OVEWAV','DIAPRO')
      ALLOCATE (HAMWAV(1:NDPROD,1:NDPROD),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('HAMWAV','DIAPRO')
      ALLOCATE (HAMMAT(1:NDPROD,1:NDPROD),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('HAMMAT','DIAPRO')
      ALLOCATE (OVEPRO(0:NDPROI,1:NDPROD,NUISOM),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('OVEPRO','DIAPRO')
C
      IF (.NOT.ALLOCATED(WAVPRO)) THEN
          ALLOCATE (WAVPRO(0:NDPROK,1:NDPROD,NUISOM),STAT=IALLOC)
                IF (IALLOC.NE.0) CALL NOALLO('WAVPRO','DIAPRO')
      END IF
      IF (.NOT.ALLOCATED(ENEPRO)) THEN
          ALLOCATE (ENEPRO(0:NDPROI,1:NDPROD,NUISOM),STAT=IALLOC)
                IF (IALLOC.NE.0) CALL NOALLO('ENEPRO','DIAPRO')
      END IF
C
C=======================================================================
C            HERE STARTS THE LOOP OVER THE ISOSPIN
C=======================================================================
C
C     IT=0
C
      DO INDISO=1,NUISOM
C
         ISOSAC=ISOMAT(INDISO)
C
C     DO ISOSAC=JSOSMI,JSOSMA,2
C
C     IT=IT+1
C
C=======================================================================
C         HERE STARTS THE LOOP OVER THE ANGULAR MOMENTA
C=======================================================================
C
      DO IPROAC=JPROMI,JPROMA,2
C
         IPRDIM=IPROAC+1
C
C=======================================================================
C         HERE WE CONSIDER THE CASE OF AN AXIAL NUCLEUS WHEN ONLY ONE
C         VALUE OF THE Z-COMPONENT  OF ANGULAR MOMENTUM  "KPROJE"  IS
C         TAKEN INTO ACCOUNT
C=======================================================================
C
         IF (IAXIAL.EQ.1) THEN
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN THE EIGENVECTOR  CANNOT
C           BE ACCEPTED IN TO THE GCM SPACE, I.E., THE SPIN=IPROAC/2
C           DOES NOT APPEAR IN THE HF WAVE FUNCTION
C=======================================================================
C           ATTENTION: UP TO VERSION 2.91, THE TEST BELOW WAS  PERFORMED
C                      FOR THE REAL PART AND NOT FOR THE ABSOLUTE VALUE.
C                      AS A RESULT, FOR CALCULATION OF  MATRIX  ELEMENTS
C                      BETWEEN THE GIVEN AND D2H-TRANSFORMED STATES, THE
C                      STATES HAVING NEGATIVE OVERLAP WERE NOT APPEARING
C                      IN THE LIST OF  ADMITTED  STATES.  THIS  BUG  WAS
C                      CORRECTED ON 10/07/2019 IN VERSION (2.90A).
C=======================================================================
C
            IF (ABS(OPROJE(INDIMK(IPROAC,KPROJE,KPROJE),
     *                                           INDISO)).LT.CUTOWE)
     *                                                          THEN
C
                 NUMPRO(IPROAC,INDISO)=0
C
             ELSE
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN THE EIGENVECTOR CAN BE
C           ACCEPTED IN TO THE GCM SPACE
C=======================================================================
C
                 KPRDIM=1
C
                 DO KBRA=1,KPRDIM
                    DO KPROAC=-IPROAC,IPROAC,2
C
                       IF (KPROAC.EQ.KPROJE) THEN
C
                           FPROJE=1.0D0/SQRT(ABS(REAL(OPROJE(
     *                            INDIMK(IPROAC,KPROJE,KPROJE),
     *                                                 INDISO))))
                       ELSE
                           FPROJE=C_ZERO
C
                       END IF
C
                       IF (IND_IK(IPROAC,KPROAC).GT.NDPROK)
     *                     STOP ' WRONG INDEX IN DIAPRO (1)'
C
                       WAVPRO(IND_IK(IPROAC,KPROAC),KBRA,INDISO)=FPROJE
C
                    END DO
C
                    ENEPRO(IPROAC,KBRA,INDISO)=
     *                     REAL(EPROJE(INDIMK(IPROAC,KPROJE,KPROJE),
     *                                                      INDISO))
     *                    /REAL(OPROJE(INDIMK(IPROAC,KPROJE,KPROJE),
     *                                                      INDISO))
C
                 END DO
C
                 NUMPRO(IPROAC,INDISO)=KPRDIM
C
             END IF
C
         ELSE
C
C=======================================================================
C                     BELOW WE TREAT 3D AMP CASE IAXIAL.EQ.0
C                     --------------------------------------
C             DIAGONALIZING THE OVERLAP MATRIX FOR A GIVEN SPIN=IPROAC/2
C                                                   AND ISOSPIN=ISOSAC/2
C=======================================================================
C
             DO LPROAC=-IPROAC,IPROAC,2
                DO KPROAC=-IPROAC,IPROAC,2
C
                   IBRA=(LPROAC+IPROAC)/2+1
                   IKET=(KPROAC+IPROAC)/2+1
C
                   HAMMAT(IBRA,IKET)=
     *                           EPROJE(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                       INDISO)
C
                   IF (IBRA.GE.IKET) THEN
C
                       NCOUNT=IBRA+((2*IPRDIM-IKET)*(IKET-1))/2
C
                       CELMTS(NCOUNT)=
     *                           OPROJE(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                       INDISO)
C
                   END IF
C
                END DO
             END DO
C
C            WRITE(*,'(2X,''1 IPROAC,ISOSAC,IPRDIM,NDPROD:'',4I5)')
C    *                        IPROAC,ISOSAC,IPRDIM,NDPROD
C
             CALL DIAMAT(CELMTS,OVEEIG,OVEWAV,IPRDIM,NDPROD,IPRDIM)
C
C=======================================================================
C           DEFINING THE HAMILTONIAN MATRIX FOR A GIVEN SPIN=IPROAC/2
C                                                AND ISOSPIN=ISOSAC/2
C=======================================================================
C
C=======================================================================
C           DEFINING THE OVERLAP CUT-OFF PARAMETER OVEMIN BASED ON THE
C           SMALLEST (NEGATIVE) EIGENVALUE OF THE OVERLAP MATRIX  (SEE
C           THE ANALYSIS BY BURZYNSKI & DOBACZEWSKI, PRC 51,1825(1995)
C=======================================================================
C
             OVEMIN=-OVEEIG(1)
C
             IF (ICUTOV.EQ.1) OVEMIN=CUTOWE+CUTOWF*OVEMIN
C
C=======================================================================
C           CUTTING-OFF THE SMALL EIGENVALUES
C=======================================================================
C
             IPRMIN=0
C
             DO IBAS=IPRDIM,1,-1
C
                IF(OVEEIG(IBAS).GT.OVEMIN) IPRMIN=IBAS
C
             END DO
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN NO EIGENVECTORS WERE
C           ACCEPTED IN TO THE GCM SPACE, I.E., SPECIFIC VALUES
C           OF THE SPIN=IPROAC/2 AND ISOSPIN=ISOSAC/2 DO NOT APPEAR
C           IN THE HF WAVE FUNCTION
C=======================================================================
C
             IF (IPRMIN.EQ.0) THEN
C
                 NUMPRO(IPROAC,INDISO)=0
C
             ELSE
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN SOME EIGENVECTORS WERE
C           ACCEPTED IN TO THE GCM SPACE
C=======================================================================
C
                 KPRDIM=IPRDIM-IPRMIN+1
C
                 DO JBRA=IPRMIN,IPRDIM
                    DO JKET=IPRMIN,IPRDIM
C
                       HAMCUT=C_ZERO
C
                       DO IBRA=1,IPRDIM
                          DO IKET=1,IPRDIM
C
                             HAMCUT=HAMCUT+CONJG(OVEWAV(IBRA,JBRA))
     *                                          *HAMMAT(IBRA,IKET)
     *                                          *OVEWAV(IKET,JKET)
C
                          END DO
                       END DO
C
                       HAMCUT=HAMCUT/SQRT(OVEEIG(JBRA)*OVEEIG(JKET))
C
                       KBRA=JBRA-IPRMIN+1
                       KKET=JKET-IPRMIN+1
C
                       IF (KBRA.GE.KKET) THEN
C
                           NCOUNT=KBRA+((2*KPRDIM-KKET)*(KKET-1))/2
C
                           CELMTS(NCOUNT)=HAMCUT
C
                       END IF
C
                    END DO
                 END DO
C
C                WRITE(*,'(2X,''2 IPROAC,ISOSAC,KPRDIM,NDPROD:'',4I5)')
C    *                            IPROAC,ISOSAC,KPRDIM,NDPROD
C
                 CALL DIAMAT(CELMTS,HAMEIG,HAMWAV,KPRDIM,NDPROD,KPRDIM)
C
C=======================================================================
C           CALCULATING THE WAVE FUNCTIONS
C=======================================================================
C
                 DO KBRA=1,KPRDIM
C
C                   AVRG_K(IPROAC,KBRA,INDISO)=0.0D0
C
                    DO KPROAC=-IPROAC,IPROAC,2
C
                       IKET=(KPROAC+IPROAC)/2+1
C
                       FPROJE=C_ZERO
C
                       DO JBAS=IPRMIN,IPRDIM
                          KBAS=JBAS-IPRMIN+1
C
                          FPROJE=FPROJE+OVEWAV(IKET,JBAS)
     *                                 /SQRT(OVEEIG(JBAS))
     *                                 *HAMWAV(KBAS,KBRA)
C
                       END DO
C
C                      AVRG_K(IPROAC,KBRA,INDISO)=
C    *                 AVRG_K(IPROAC,KBRA,INDISO)
C    *                                    +ABS(FPROJE)**2
C    *                                    +ABS(KPROAC)*ABS(FPROJE)**2/2
C
                       IF (IND_IK(IPROAC,KPROAC).GT.MINDIK)
     *                     STOP ' WRONG INDEX IN DIAPRO (2)'
C
                       WAVPRO(IND_IK(IPROAC,KPROAC),KBRA,INDISO)=FPROJE
C
                    END DO
C
                    ENEPRO(IPROAC,KBRA,INDISO)=HAMEIG(KBRA)
                    OVEPRO(IPROAC,KBRA,INDISO)=OVEEIG(IPRDIM-KBRA+1)
C
                 END DO
C
                 NUMPRO(IPROAC,INDISO)=KPRDIM
C
             END IF
C
         END IF
C
C=======================================================================
C       HERE END THE LOOPS OVER THE ANGULAR MOMENTUM AND THE ISOSPIN
C=======================================================================
C
      END DO
      END DO
C
C=======================================================================
C        PRINTING THE RESULTS OF THE K-MIXING FOR DIFFERENT ISOSPIN
C        COMPONENTS:
C=======================================================================
C
      IF (LPROJJ.EQ.0) GOTO 110
C
      WRITE(NFIPRI,'(1H*,77(1H*),1H*)')
C
      IF (IAXIAL.NE.1.AND.LPROJT.EQ.0) THEN
               WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,23X,''RESULTS OF K-MIXING CALCULATION'',
     *                                             23X,1H*,/,
     *                                         1H*,77X,1H*,/,
     *                                     1H*,77(1H*),1H*)')
      END IF
C
      DO INDISO=1,NUISOM
C
         ISOSAC=ISOMAT(INDISO)
C
C     IT=0
C
C     DO ISOSAC=JSOSMI,JSOSMA,2
C
C     IT=IT+1
C
      IF (IAXIAL.NE.1.AND.LPROJT.NE.0) THEN
               WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,17X,'' RESULTS OF K-MIXING CALCULATION'',
     *                 '' FOR T = '',           I2,A2,15X,1H*,/,
     *                                            1H*,77X,1H*,/,
     *                                        1H*,77(1H*),1H*)')
     *
     *                  ISOSAC/IEVEN_,CHALF_
      END IF
C
      I_HALF=0
      I_HEAD=0
C
      DO KBRA=1,JPROMA+1
C
         HAFLIN(KBRA,1)='                                      '
         HAFLIN(KBRA,2)='                                      '
C
      END DO
C
      DO IPROAC=JPROMI,JPROMA,2
C
         IPRDIM=IPROAC+1
C
         KPRDIM=NUMPRO(IPROAC,INDISO)
C
         IF (KPRDIM.GT.0.AND.IMIPRI.GT.0.AND.IAXIAL.NE.1.AND.
     *                   IPROAC.GE.ISLPRI.AND.IPROAC.LE.ISUPRI) THEN
C
             I_HALF=I_HALF+1
C
             LINDIM(I_HALF)=KPRDIM
C
             DO KBRA=1,KPRDIM
C
                WRITE(HAFLIN(KBRA,I_HALF),
C    *                '(2X,I4,A2,I4,(1PE11.2),0PF13.6,2X)')
     *                '(1X,I3,A2,I3,(1PE15.6),0PF13.6,1X)')
     *             IPROAC/IEVEN_,CHALF_,KBRA,
     *             OVEPRO(IPROAC,KBRA,INDISO),
     *             ENEPRO(IPROAC,KBRA,INDISO)
C
             END DO
C
             IF (I_HALF.EQ.2) THEN
C
                 I_HALF=0
C
                 IF (I_HEAD.EQ.0) THEN
C
                     IF (IEVEN_.EQ.1) THEN
C
C                        HAFLIM='      I    N    OVERLAP       ENERGY  '
                         HAFLIM='    I   N        OVERLAP       ENERGY '
C
                     ELSE
C
C                        HAFLIM='    I      N    OVERLAP       ENERGY  '
                         HAFLIM='  I     N        OVERLAP       ENERGY '
C
                     END IF
C
                     WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                  1H*,1X,'' RESULTS OF THE K-MIXING CALCULATION'',
     *                         '' FOR THE FOLLOWING OVERLAP'',
     *                         '' CUTOFF DATA'',    2X,1H*,/,
     *                  1H*,1X,'' ICUTOV='',I1,'', CUTOVE='',1PE8.1,
     *                                         '', CUTOVF='',1PE8.1,
     *                                                33X,1H*,/,
     *                                            1H*,77X,1H*,/,
     *                          79(1H*),/,1H*,38X,1H|,38X,1H*,/,
     *                                    1H*,A38,1H|,A38,1H*,/,
     *                                    1H*,38X,1H|,38X,1H*,/,
     *                            1H*,38(1H*),1H|,38(1H*),1H*)')
     *
     *                  ICUTOV,CUTOWE,CUTOWF,HAFLIM,HAFLIM
C
                     I_HEAD=1
C
                 END IF
C
                 DO KBRA=1,MAX(LINDIM(1),LINDIM(2))
C
                    WRITE(NFIPRI,'(1H*,A38,1H|,A38,1H*)')
     *                                     HAFLIN(KBRA,1),HAFLIN(KBRA,2)
C
                 END DO
C
                 WRITE(NFIPRI,'(1H*,38(1H-),1H|,38(1H-),1H*)')
C
                 DO KBRA=1,JPROMA+1
C
                 HAFLIN(KBRA,1)='                                      '
                 HAFLIN(KBRA,2)='                                      '
C
                 END DO
C
             END IF
C
         END IF
C
      END DO
C
      IF (I_HALF.EQ.1) THEN
C
          DO KBRA=1,LINDIM(1)
C
             WRITE(NFIPRI,'(1H*,A38,1H|,38X,1H*)') HAFLIN(KBRA,1)
C
          END DO
C
      END IF
C
      IF (IMIPRI.GT.0.AND.IAXIAL.NE.1) WRITE(NFIPRI,'(79(1H*))')
C
C=======================================================================
C       HERE ENDS THE LOOP OVER THE ISOSPIN IN THE PRINTING BLOCK
C=======================================================================
C
      END DO
C
  110 CONTINUE
C
      IF (LPROJT.EQ.0) GOTO 111
C
C=======================================================================
C          HERE STARTS THE COULOMB REDIAGONALIZATION BLOCK
C=======================================================================
C
      DO IPROAC=JPROMI,JPROMA,2
C
C=======================================================================
C      CALCULATE DIMENSION "IDIM" FOR A GIVEN SPIN VALUE IPROAC
C=======================================================================
C
         II=0
C        IT=0
C
C        DO ISOSAC=JSOSMI,JSOSMA,2
C
C        IT=IT+1
         DO INDISO=1,NUISOM
C
            ISOSAC=ISOMAT(INDISO)
C
            II=II+NUMPRO(IPROAC,INDISO)
C
           IF (IPROAC.EQ.0)      THEN
              NPROI0(IT)=NUMPRO(0,IT)
              IF (NUMPRO(0,IT).EQ.1)
     *            WPROI0(  IT)=WAVPRO(IND_IK(0,0),1,IT)
              IF (NUMPRO(0,IT).EQ.0)
     *            WPROI0(  IT)=C_ZERO
           END IF
C
         END DO
C
         NUMPRO(IPROAC,0)=II
C
         IF (NUMPRO(IPROAC,0).EQ.0) THEN
            WRITE(*,112) IPROAC/IEVEN_,CHALF_
 112        FORMAT(1H*,77X,1H*,/,
     *            1H*,11X,'THERE IS NO SPIN I=',I3,A2,
     *               ' COMPONENT IN THE WAVE FUNCTION',11X,1H*,/,
     *            1H*,77X,1H*)
            GOTO 113
         END IF
C
C=======================================================================
C        CALCULATE HAMILTONIAN MATRIX ELEMENTS AND PERFORM
C                    COULOMB REDIAGONALIZATION
C=======================================================================
C
          IL=0
C         ITBRA=0
C           DO ISOBRA=JSOSMI,JSOSMA,2
C           ITBRA=ITBRA+1
            DO ITBRA=1,NUISOM
C
               ISOBRA=ISOMAT(ITBRA)
C
            DO II=1,NUMPRO(IPROAC,ITBRA)
            IL=IL+1
C
            IR=0
C           ITKET=0
C             DO ISOKET=JSOSMI,JSOSMA,2
C             ITKET=ITKET+1
              DO ITKET=1,NUISOM
C
                 ISOKET=ISOMAT(ITKET)
C
C
              DO JJ=1,NUMPRO(IPROAC,ITKET)
              IR=IR+1
C
              HAMMAT(IL,IR)=C_ZERO
C
              E_10=CGCOEF(ISOKET,ISOSTZ  ,2, 0,ISOBRA,ISOSTZ)
              E11P=CGCOEF(ISOKET,ISOSTZ-2,2, 2,ISOBRA,ISOSTZ)
              E11M=CGCOEF(ISOKET,ISOSTZ+2,2,-2,ISOBRA,ISOSTZ)
              E_20=CGCOEF(ISOKET,ISOSTZ  ,4, 0,ISOBRA,ISOSTZ)
              E21P=CGCOEF(ISOKET,ISOSTZ-2,4, 2,ISOBRA,ISOSTZ)
              E21M=CGCOEF(ISOKET,ISOSTZ+2,4,-2,ISOBRA,ISOSTZ)
              E22P=CGCOEF(ISOKET,ISOSTZ-4,4, 4,ISOBRA,ISOSTZ)
              E22M=CGCOEF(ISOKET,ISOSTZ+4,4,-4,ISOBRA,ISOSTZ)
C
              E211P=E_10*E11P
              E211M=E_10*E11M
C
              E221P=E_20*E21P
              E221M=E_20*E21M
              E222P=E_20*E22P
              E222M=E_20*E22M
C
              E2_10=E_10*E_10
              E2_20=E_20*E_20
C
                IF (IL.EQ.IR) THEN
C
                   HAMMAT(IL,IL)=ENEPRO(IPROAC,II,ITBRA)
C
                ELSE
C
                IF (LPROJT.NE.0.AND.ITKET.NE.ITBRA) THEN
C
                DO LPROAC=-IPROAC,IPROAC,2
                  DO KPROAC=-IPROAC,IPROAC,2
C
                  IF (IND_IK(IPROAC,LPROAC).GT.MINDIK)
     *                STOP ' WRONG INDEX IN DIAPRO (3)'
                  IF (IND_IK(IPROAC,KPROAC).GT.MINDIK)
     *                STOP ' WRONG INDEX IN DIAPRO (4)'
C
                   HAMMAT(IL,IR)=HAMMAT(IL,IR)+
     *             (E2_10*(TC1_D0(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)+
     *                     TC1_X0(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET))
     *             +E211P*(TC1_DP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)+
     *                     TC1_XP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET))
     *             +E211M*(TC1_DM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)+
     *                     TC1_XM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET))
     *             +E2_20*(TC2_D0(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)+
     *                     TC2_X0(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET))
     *             +E221P*(TC21DP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)+
     *                     TC21XP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET))
     *             +E221M*(TC21DM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)+
     *                     TC21XM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET))
     *             +E222P*(TC22DP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)+
     *                     TC22XP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET))
     *             +E222M*(TC22DM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)+
     *                     TC22XM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                                  ITKET)))
     *                  *CONJG(WAVPRO(IND_IK(IPROAC,LPROAC),II,ITBRA))
     *                  *      WAVPRO(IND_IK(IPROAC,KPROAC),JJ,ITKET)
C
CWS        WRITE(*,789) IL,IR,IPROAC,LPROAC,KPROAC,ISOBRA,II,ISOKET,JJ,
C     *                    (TC1_D0(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC1_X0(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *                    (TC1_DP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC1_XP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *                    (TC1_DM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC1_XM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *                    (TC2_D0(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC2_X0(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *                    (TC21DP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC21XP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *                    (TC21DM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC21XM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *                    (TC22DP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC22XP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *                    (TC22DM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC22XM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *              E2_10*(TC1_D0(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC1_X0(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *              E211P*(TC1_DP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC1_XP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *              E211M*(TC1_DM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC1_XM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *              E2_20*(TC2_D0(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC2_X0(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *              E221P*(TC21DP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC21XP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *              E221M*(TC21DM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC21XM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *              E222P*(TC22DP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC22XP(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *              E222M*(TC22DM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)+
C     *                     TC22XM(INDIMK(IPROAC,LPROAC,KPROAC),
C     *                                                  ITKET)),
C     *                         WAVPRO(IND_IK(IPROAC,LPROAC),II,ITBRA),
C     *                         WAVPRO(IND_IK(IPROAC,KPROAC),JJ,ITKET)
C
C 789  FORMAT(2X,2I3,'  I,K,L=',3I3,'  TBRA,II=',2I3,'  TKET,JJ=',2I3,/,
C     *       2X,'1m: ',3(F10.6,F6.3),/,2X,'2m: ',5(F10.6,F6.3),/,
C     *       2X,'1m: ',3(F10.6,F6.3),/,2X,'2m: ',5(F10.6,F6.3),/,
C     *       2X,'WF: ',2(F16.6,1X,F6.3))
CWS
                  END DO
                END DO
C
                END IF
C
                END IF
C
                END DO
                END DO
C
            END DO
            END DO
C
            IF (IENPRI.EQ.2)
     *      WRITE(*,212)
 212        FORMAT(1H*,77X,1H*,/,
     *             1H*,21X,'MATRIX ELEMENTS OF THE HAMILTONIAN',22X,
     *             1H*,/,1H*,77X,1H*)
C
            IDIM= NUMPRO(IPROAC,0)
            DO IL=1,IDIM
              DO IR=1,IL
C
             IF (IENPRI.EQ.2)
     *       WRITE(*,213) IL,IR,HAMMAT(IL,IR),IR,IL,HAMMAT(IR,IL)
 213         FORMAT(1H*,2(2I3,2F16.10),1X,1H*)
C
                NCOUNT=IL+((2*IDIM-IR)*(IR-1))/2
                CELMTS(NCOUNT)=HAMMAT(IL,IR)
C
              END DO
            END DO
C
C           WRITE(*,'(2X,''3 IPROAC,ISOSAC,IDIM,NDPROD:'',4I5)')
C    *                       IPROAC,ISOSAC,IDIM,NDPROD
C
            CALL DIAMAT(CELMTS,HAMEIG,HAMWAV,IDIM,NDPROD,IDIM)
C
            IF (LPROJJ.EQ.0.AND.LPROJT.EQ.1)
     *      WRITE(*,663)
 663        FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *      1H*,26X,'ISOSPIN-MIXED EIGENSTATES',
     *      26X,1H*,/,1H*,26X,25(1H-),26X,1H*,/,1H*,77X,1H*)
C
            IF (LPROJJ.EQ.1.AND.LPROJT.EQ.1)
     *      WRITE(*,664) IPROAC/IEVEN_,CHALF_
 664        FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *      1H*,17X,'ISOSPIN- AND K-MIXED EIGENSTATES FOR I=',I2,A2,
     *      17X,1H*,/,1H*,17X,43(1H-),17X,1H*,/,1H*,77X,1H*)
C
            IF (LPROJJ.EQ.1.AND.LPROJT.EQ.0)
     *      WRITE(*,665) IPROAC/IEVEN_,CHALF_
 665        FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *      1H*,23X,'K-MIXED EIGENSTATES FOR I=',I3,A2,
     *      23X,1H*,/,1H*,23X,31(1H-),23X,1H*,/,1H*,77X,1H*)
C
            WRITE(*,666)
 666        FORMAT(1H*,3X,'  N',2X,'     EIGENENERGY',4X,' i',2X,
     *              '  T  ',2X,
     *              '   |C_i|^2',2X,'   Re[C_i]',2X,'   Im[C_i]',4X,
     *              1H*,/,1H*,77X,1H*)
C
C=======================================================================
C   CALCULATE DOMINANT ISOSPIN AND COULOMB MIXING FOR EACH EIGENSTATE
C        (FOR LPROJT.EQ.0: T=|T_z| AND ZERO MIXING ARE PRINTED)
C=======================================================================
C
       IT_BLO=0
C
       DO MM=1,IDIM
C
            IT=0
            LL=0
            DO ISOSPI=JSOSMI,JSOSMA,2
            IT=IT+1
              DO LI=1,NUMPRO(IPROAC,IT)
                 LL=LL+1
C
              IF (LL.EQ.1)
     *        WRITE(*,667) MM,HAMEIG(MM),LL,ISOSPI/IEVEN_,CHALF_,
     *              ABS(HAMWAV(LL,MM))**2, REAL(HAMWAV(LL,MM)),
     *                                    AIMAG(HAMWAV(LL,MM))
 667          FORMAT(1H*,3X,I3,2X,F16.6,4X,I2,2X,I3,A2,3(2X,F10.6),
     *                   4X,1H*)
              IF (LL.GT.1)
     *        WRITE(*,668)                LL,ISOSPI/IEVEN_,CHALF_,
     *              ABS(HAMWAV(LL,MM))**2, REAL(HAMWAV(LL,MM)),
     *                                    AIMAG(HAMWAV(LL,MM))
 668          FORMAT(1H*,28X,I2,2X,I3,A2,3(2X,F10.6),4X,1H*)
C
              END DO
C
            END DO
C
            WAVMAX=0
            CO_MIX=1-WAVMAX
C
            IT=0
            NN=0
            DO ISOSAC=JSOSMI,JSOSMA,2
            IT=IT+1
               DO LL=1,NUMPRO(IPROAC,IT)
                  NN=NN+1
                  IF (ABS(HAMWAV(NN,MM))**2.GE.WAVMAX) THEN
                  WAVMAX=ABS(HAMWAV(NN,MM))**2
                  CO_MIX=1-WAVMAX
                  ISOMAX=ISOSAC
                  END IF
               END DO
            END DO
C
            CO_MAX=0
            IT=0
            NN=0
            DO ISOSAC=JSOSMI,JSOSMA,2
            IT=IT+1
               DO LL=1,NUMPRO(IPROAC,IT)
                  NN=NN+1
                  IF (ISOSAC.EQ.ISOMAX) THEN
                  C_WAVE=ABS(HAMWAV(NN,MM))**2
                  CO_MAX=CO_MAX+C_WAVE
                  END IF
               END DO
            END DO
C
            CO_MIX=1-CO_MAX
C
      WRITE(*,669) WAVMAX,ISOMAX/IEVEN_,CHALF_,CO_MIX,CO_MIX*100
 669  FORMAT(1H*,1X,'DOMINANT AMPLITUDE SQUARED EQUALS:',F14.10,
     *              ' AND CORRESPONDS TO T =',I2,A2,1X,1H*,/,
     *       1H*,1X,'COULOMB MIXING IN  THIS  STATE IS:',F14.10,
     *       ' [',F10.6,'%]',14X,1H*,/,1H*,77X,1H*,/,1H*,77X,1H*)
C
C==========================================================================
C      STORE WAVE FUNCTION FOR FURTHER CALCULATION OF THE TRANSITION
C                 MATRIX ELEMENTS E.G. FERMI AND GT
C                      (USING BETAME SUBROUTIONE)
C==========================================================================
C
          IF (IBETME.NE.0) THEN
C
            IF (IPROAC.EQ.IIFERR.AND.ISOMAX.EQ.ITFERR
     *                          .AND.ISTORE.EQ.0) THEN
              IT_BLO=IT_BLO+1
              IF (IT_BLO.NE.ISFERR) GOTO 313
              EIGE_R=HAMEIG(MM)
              IDIM_R=(JSOSMA-JSOSMI)/2+1
              WRITE(*,1)
  1           FORMAT(1H*,1X,'-> EXPANSION COEFFICIENTS F_KT OF THE',
     *                      ' W.F. OF THE STATE ABOVE ARE STORED <-',
     *                   1X,1H*,/,1H*,77X,1H*,/,
     *               1H*,16X,'i',2X,'  K',2X,'  T',12X,'Re(F_KT)',8X,
     *               'Im(F_KT)',14X,1H*)
C
               ISTORE=1
               IDIMAX=0
               IT=0
               DO ISOSAC=JSOSMI,JSOSMA,2
               IT=IT+1
C
                  IDIMIN=IDIMAX+1
                  IDIMAX=IDIMAX+NUMPRO(IIFERR,IT)
C
                  DO KPROAC=-IIFERR,IIFERR,2
                  F_KT_R(KPROAC,IT,0)=C_ZERO
C
                       IF (IND_IK(IIFERR,KPROAC).GT.MINDIK)
     *                     STOP ' WRONG INDEX IN DIAPRO (5)'
C
                     DO II=IDIMIN,IDIMAX
                        JJ=II-IDIMIN+1
                        F_KT_R(KPROAC,IT,0)=
     *                  F_KT_R(KPROAC,IT,0)+HAMWAV(II,MM)*
     *                            WAVPRO(IND_IK(IIFERR,KPROAC),JJ,IT)
C
CWS                     WRITE(*,16) II,IIFERR,KPROAC,IT,HAMWAV(II,MM),
CWS     *                         WAVPRO(IND_IK(IIFERR,KPROAC),JJ,IT)
CWS  16                 FORMAT(2X,4I3,4F15.6)
C
                     END DO
C
                  WRITE(*,17) IT,KPROAC/IEVEN_,CHALF_,ISOSAC/IEVEN_,
     *                                    CHALF_,F_KT_R(KPROAC,IT,0)
  17              FORMAT(1H*,14X,I3,2X,2(I3,A2),2X,2F16.6,14X,1H*)
                  END DO
C
                END DO
C
                WRITE(*,18)
  18            FORMAT(1H*,77X,1H*)
            END IF
C
 313          CONTINUE
C
          END IF
C
      END DO
C
 113  CONTINUE
C
C=======================================================================
C               HERE ENDS THE "IPROAC" BLOCK
C=======================================================================
C
      WRITE(*,670)
 670  FORMAT(79(1H*))
C
      END DO
C
 111  CONTINUE
C
C=======================================================================
      DEALLOCATE (CELMTS,OVEWAV,HAMWAV,HAMMAT,OVEPRO)
C=======================================================================
C
      CALL CPUTIM('DIAPRO',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIAMUR(JPROMI,JPROMA,IHALF_,
     *                  LPROJJ,LPROJT,
     *                  ICUTOV,CUTOWE,CUTOWF,
     *                  IMIPRI,ISLPRI,ISUPRI,
     *                                NUISOM)
C
C=======================================================================
      USE hfodd_sizes
      USE TXXX_Y
      USE HAMMIX
      USE MURMIX
C=======================================================================
C
      CHARACTER
     *          CHALF_*2
      CHARACTER
     *          HAFLIN*38,HAFLIM*38
C
      COMPLEX
     *          WFI0T1,WPROI0,F_KT_R
      COMPLEX
     *          C_ZERO,FPROJE,HAMCUT,OVEMAT,WAVMUR
C
      DIMENSION
     *          OVEEIG(1:NDCONF),HAMEIG(1:NDCONF)
      DIMENSION
     *          LINDIM(2),HAFLIN(1:NDCONF,2)
      DIMENSION
     *          OVEMAT(1:NDCONF,1:NDCONF)
C
      COMMON
     *       /TMX0RA/ WPROI0(NDPROT),WFI0T1(NDPROT),E_I0T1
      COMMON
     *       /TMX0RB/ NPROI0(NDPROT),I_I0T1
      COMMON
     *       /FERMIR/ F_KT_R(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_R,IDIM_R,IIFERR,ITFERR,ISFERR
      COMMON
     *       /ALLMUR/ NUMMUR(0:NDPROI,0:NDISOM)
      COMMON
     *       /ISOIND/ ISOMAT(NDISOM),LSOMAT(NDISOM),KSOMAT(NDISOM)
      COMMON
     *       /PROIND/ IROMAT(NDPROM),LROMAT(NDPROM),KROMAT(NDPROM)
      COMMON
     *       /IMKIND/ INDIMK(0:NDPROI,-NDPROI:NDPROI,-NDPROI:NDPROI)
      COMMON
     *       /COLMIX/ MIXCOL(0:NDPROI,0:NDISOM,NDCONF)
      COMMON
     *       /COLMUR/ WAVMUR(0:NDPROI,0:NDISOM,NDCONF,NDCONF),
     *                ENEMUR(0:NDPROI,0:NDISOM,NDCONF),
     *                OVEMUR(0:NDPROI,0:NDISOM,NDCONF)
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /CFIPRI/ NFIPRI
C
      CALL CPUTIM('DIAMUR',1)
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HAMILTONIAN MATRIX FOR
C         THE MULTI-REFERENCE ANGULAR-MOMENTUM AND 1D-ISOSPIN PROJECTED
C         STATES
C=======================================================================
C         THE SUBROUTINE GIVES THE MULTI-REFERENCE-MIXED EIGENVECTORS
C         IN THE ARRAY "WAVMUR", THEIR EIGEN-ENERGIES  IN  THE  ARRAY
C         "ENEMUR"  AND THE NUMBER THEREOF  IN  THE  ARRAY  "NUMMUR".
C         VALUES OF "0" IN THE ARRAY "NUMMUR" MEAN THE ABSENCE OF THE
C         GIVEN MULTI-REFERENCE COMPONENT IN THE MIXED WAVE FUNCTION;
C         IN THIS CASE "WAVMUR" AND "ENEMUR" ARRAYS ARE NOT DEFINED.
C=======================================================================
C         ATTENTION: THE CURRENT VERSION MIXES THE LOWEST K-MIXED STATES
C                    ONLY.
C=======================================================================
C
                       CHALF_='  '
      IF (IHALF_.EQ.1) CHALF_='/2'
C
      IEVEN_=2/(IHALF_+1)
C
      ISTORE=0
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        ALLOCATING LOCAL ARRAYS
C=======================================================================
C
      ALLOCATE (CELMTS(1:((NDCONF+1)*NDCONF)/2),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIAMUR')
      ALLOCATE (OVEWAV(1:NDCONF,1:NDCONF),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('OVEWAV','DIAMUR')
      ALLOCATE (HAMWAV(1:NDCONF,1:NDCONF),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('HAMWAV','DIAMUR')
      ALLOCATE (HAMMAT(1:NDCONF,1:NDCONF),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('HAMMAT','DIAMUR')
C
      IF (.NOT.ALLOCATED(OMRMIX)) STOP ' OMRMIX NOT ALLOCATED IN DIAMUR'
      IF (.NOT.ALLOCATED(EMRMIX)) STOP ' EMRMIX NOT ALLOCATED IN DIAMUR'
C
C=======================================================================
C            HERE STARTS THE LOOP OVER THE ISOSPIN
C=======================================================================
C
      DO INDISO=1,NUISOM
C
         ISOSAC=ISOMAT(INDISO)
C
C=======================================================================
C         HERE STARTS THE LOOP OVER THE ANGULAR MOMENTA
C=======================================================================
C
      DO IPROAC=JPROMI,JPROMA,2
C
C=======================================================================
C        HERE WE POPULATE THE OVERLAP AND HAMILTONIAN  ARRAYS  BASED  ON
C        THE LIST OF THE SINGLE-REFERENCE STATES THAT COVERS THEIR UPPER
C        TRIANGLE ELEMENTS.
C=======================================================================
C
         DO INDKET=1,MIXNUM
C
            INRWAV=MICONF(INDKET)
C
            IF (MIXCOL(IPROAC,INDISO,INRWAV).LT.1) THEN
C
                NUMMUR(IPROAC,INDISO)=0
                GO TO 5830
C
            END IF
C
            DO INDBRA=1,INDKET
C
               INLWAV=MICONF(INDBRA)
C
               KMURMI=NMATMI(IPROAC,INDISO,INLWAV,INRWAV,1,1)
C
               HAMMAT(INDBRA,INDKET)=      EMRMIX(KMURMI)
               HAMMAT(INDKET,INDBRA)=CONJG(EMRMIX(KMURMI))
C
               OVEMAT(INDBRA,INDKET)=      OMRMIX(KMURMI)
               OVEMAT(INDKET,INDBRA)=CONJG(OMRMIX(KMURMI))
C
            END DO
         END DO
C
C=======================================================================
C        HERE WE POPULATE THE LINEARIZED OVERLAP ARRAY BASED ON THE LIST
C        OF THE SINGLE-REFERENCE STATES THAT COVERS THEIR LOWER-TRIANGLE
C        ELEMENTS.
C=======================================================================
C
         DO IBRA=1,MIXNUM
C
            DO IKET=1,IBRA
C
               NCOUNT=IBRA+((2*MIXNUM-IKET)*(IKET-1))/2
C
               CELMTS(NCOUNT)=OVEMAT(IBRA,IKET)
C
            END DO
         END DO
C
C=======================================================================
C         DIAGONALIZING THE OVERLAP MATRIX FOR A GIVEN SPIN=IPROAC/2
C                                               AND ISOSPIN=ISOSAC/2
C=======================================================================
C
         CALL DIAMAT(CELMTS,OVEEIG,OVEWAV,MIXNUM,NDCONF,MIXNUM)
C
C=======================================================================
C           DEFINING THE HAMILTONIAN MATRIX FOR A GIVEN SPIN=IPROAC/2
C                                                AND ISOSPIN=ISOSAC/2
C=======================================================================
C
C=======================================================================
C           DEFINING THE OVERLAP CUT-OFF PARAMETER OVEMIN BASED ON THE
C           SMALLEST (NEGATIVE) EIGENVALUE OF THE OVERLAP MATRIX  (SEE
C           THE ANALYSIS BY BURZYNSKI & DOBACZEWSKI, PRC 51,1825(1995)
C=======================================================================
C           ATTENTION: AT PRESENT, THE  MULTI-REFERENCE-MIXING  CUTOFF
C                      PARAMETERS ARE KEPT AT THE VALUES USED FOR  THE
C                      K-MIXING
C=======================================================================
C
         OVEMIN=-OVEEIG(1)
C
         IF (ICUTOV.EQ.1) OVEMIN=CUTOWE+CUTOWF*OVEMIN
C
C=======================================================================
C           CUTTING-OFF THE SMALL EIGENVALUES
C=======================================================================
C
         IPRMIN=0
C
         DO IBAS=MIXNUM,1,-1
C
            IF(OVEEIG(IBAS).GT.OVEMIN) IPRMIN=IBAS
C
         END DO
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN NO EIGENVECTORS WERE
C           ACCEPTED IN TO THE GCM SPACE, I.E., SPECIFIC VALUES
C           OF THE SPIN=IPROAC/2 AND ISOSPIN=ISOSAC/2 DO NOT APPEAR
C           IN THE HF WAVE FUNCTION
C=======================================================================
C
         IF (IPRMIN.EQ.0) THEN
C
             NUMMUR(IPROAC,INDISO)=0
C
         ELSE
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN SOME EIGENVECTORS WERE
C           ACCEPTED IN TO THE GCM SPACE
C=======================================================================
C
             KPRDIM=MIXNUM-IPRMIN+1
C
             DO JBRA=IPRMIN,MIXNUM
                DO JKET=IPRMIN,MIXNUM
C
                   HAMCUT=C_ZERO
C
                   DO IBRA=1,MIXNUM
                      DO IKET=1,MIXNUM
C
                         HAMCUT=HAMCUT+CONJG(OVEWAV(IBRA,JBRA))
     *                                      *HAMMAT(IBRA,IKET)
     *                                      *OVEWAV(IKET,JKET)
C
                      END DO
                   END DO
C
                   HAMCUT=HAMCUT/SQRT(OVEEIG(JBRA)*OVEEIG(JKET))
C
                   KBRA=JBRA-IPRMIN+1
                   KKET=JKET-IPRMIN+1
C
                   IF (KBRA.GE.KKET) THEN
C
                       NCOUNT=KBRA+((2*KPRDIM-KKET)*(KKET-1))/2
C
                       CELMTS(NCOUNT)=HAMCUT
C
                   END IF
C
                END DO
             END DO
C
C            WRITE(*,'(2X,''2 IPROAC,ISOSAC,KPRDIM,NDPROD:'',4I5)')
C    *                        IPROAC,ISOSAC,KPRDIM,NDPROD
C
             CALL DIAMAT(CELMTS,HAMEIG,HAMWAV,KPRDIM,NDCONF,KPRDIM)
C
C=======================================================================
C           CALCULATING THE WAVE FUNCTIONS
C=======================================================================
C
             DO KBRA=1,KPRDIM
C
                DO IKET=1,MIXNUM
C
                   FPROJE=C_ZERO
C
                   DO JBAS=IPRMIN,MIXNUM
                      KBAS=JBAS-IPRMIN+1
C
                      FPROJE=FPROJE+OVEWAV(IKET,JBAS)
     *                             /SQRT(OVEEIG(JBAS))
     *                             *HAMWAV(KBAS,KBRA)
C
                   END DO
C
                   WAVMUR(IPROAC,INDISO,IKET,KBRA)=FPROJE
C
                END DO
C
                ENEMUR(IPROAC,INDISO,KBRA)=HAMEIG(KBRA)
                OVEMUR(IPROAC,INDISO,KBRA)=OVEEIG(MIXNUM-KBRA+1)
C
             END DO
C
             NUMMUR(IPROAC,INDISO)=KPRDIM
C
         END IF
C
C=======================================================================
C       HERE END THE LOOPS OVER THE ANGULAR MOMENTUM AND THE ISOSPIN
C=======================================================================
C
 5830 CONTINUE
C
      END DO
      END DO
C
C=======================================================================
C        PRINTING THE RESULTS OF THE MULTI-REFERENCE-MIXING FOR
C        DIFFERENT ANGULAR-MOMENTUM AND ISOSPIN COMPONENTS:
C=======================================================================
C
      IF (LPROJJ.EQ.0) GOTO 110
C
      WRITE(NFIPRI,'(1H*,77(1H*),1H*)')
C
      IF (LPROJT.NE.0) STOP 'DIAMUR NOT READY FOR LPROJT.NE.0'
C
      DO INDISO=1,NUISOM
C
      ISOSAC=ISOMAT(INDISO)
C
      I_HALF=0
      I_HEAD=0
C
      DO KBRA=1,KPRDIM
C
         HAFLIN(KBRA,1)='                                      '
         HAFLIN(KBRA,2)='                                      '
C
      END DO
C
      DO IPROAC=JPROMI,JPROMA,2
C
         KPRDIM=NUMMUR(IPROAC,INDISO)
C
         IF (KPRDIM.GT.0.AND.IMIPRI.GT.0.AND.
     *                       IPROAC.GE.ISLPRI.AND.IPROAC.LE.ISUPRI) THEN
C
             I_HALF=I_HALF+1
C
             LINDIM(I_HALF)=KPRDIM
C
             DO KBRA=1,KPRDIM
C
                WRITE(HAFLIN(KBRA,I_HALF),
C    *                '(2X,I4,A2,I4,(1PE11.2),0PF13.6,2X)')
     *                '(1X,I3,A2,I3,(1PE15.6),0PF13.6,1X)')
     *             IPROAC/IEVEN_,CHALF_,KBRA,
     *             OVEMUR(IPROAC,INDISO,KBRA),
     *             ENEMUR(IPROAC,INDISO,KBRA)
C
             END DO
C
             IF (I_HALF.EQ.1) THEN
C
                 IF (I_HEAD.EQ.0) THEN
C
                     HAFLIM='  SPIN  N  EIGEN_OVERLAP EIGEN_ENERGY '
C
                     WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                  1H*,1X,'' RESULTS OF THE MULTI-REFERENCE'',
     *                         '' CALCULATION FOR THE'',
     *                         '' OVERLAP CUTOFF DATA'',    5X,1H*,/,
     *                  1H*,1X,'' ICUTOV='',I1,'', CUTOVE='',1PE8.1,
     *                                         '', CUTOVF='',1PE8.1,
     *                                                33X,1H*,/,
     *                                            1H*,77X,1H*,/,
     *                          79(1H*),/,1H*,A38,1H|,A38,1H*,/,
     *             1H*,''  ----  -  ------------- ------------ '',
     *             1H|,''  ----  -  ------------- ------------ '',1H*)')
     *
     *                  ICUTOV,CUTOWE,CUTOWF,HAFLIM,HAFLIM
C
                     I_HEAD=1
C
                 END IF
C
             ELSE
C
                 I_HALF=0
C
                 DO KBRA=1,MAX(LINDIM(1),LINDIM(2))
C
                    WRITE(NFIPRI,'(1H*,A38,1H|,A38,1H*)')
     *                                     HAFLIN(KBRA,1),HAFLIN(KBRA,2)
C
                 END DO
C
                 WRITE(NFIPRI,'(1H*,
     *                 ''  ----  -  ------------- ------------ '',1H|,
     *                 ''  ----  -  ------------- ------------ '',1H*)')
C
                 DO KBRA=1,KPRDIM
C
                 HAFLIN(KBRA,1)='                                      '
                 HAFLIN(KBRA,2)='                                      '
C
                 END DO
C
             END IF
C
         END IF
C
      END DO
C
      IF (I_HALF.EQ.1) THEN
C
          DO KBRA=1,LINDIM(1)
C
             WRITE(NFIPRI,'(1H*,A38,1H|,38X,1H*)') HAFLIN(KBRA,1)
C
          END DO
C
      END IF
C
      IF (IMIPRI.GT.0) WRITE(NFIPRI,'(79(1H*))')
C
C=======================================================================
C       HERE ENDS THE LOOP OVER THE ISOSPIN IN THE PRINTING BLOCK
C=======================================================================
C
      END DO
C
  110 CONTINUE
C
C=======================================================================
      DEALLOCATE (CELMTS,OVEWAV,HAMWAV,HAMMAT)
C=======================================================================
C
      CALL CPUTIM('DIAMUR',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIAP3D(JPROMI,JPROMA,KPROJE,KPLEFT,IAXIAL,LPROJJ,
     *                  JSOSMI,JSOSMA,ISOSTZ,IAXIAT,LPROJT,
     *                         IHALF_,ICUTOV,CUTOWE,CUTOWF,
     *                                IMIPRI,ISLPRI,ISUPRI,
     *                                              IENPRI,
     *                                       MINDIK,IBETME)
C
C=======================================================================
      USE hfodd_sizes
      USE TXXX_Y
      USE HAMMIX
C=======================================================================
C
      CHARACTER
     *          CHALF_*2
      CHARACTER
     *          HAFLIN*38,HAFLIM*38
C
      COMPLEX
     *          EPROJE,OPROJE
      COMPLEX
     *          F_KT_R
      COMPLEX
     *          C_ZERO,FPROJE,HAMCUT
C
      DIMENSION
     *          IPRDIM(0:NDPROI,0:NDPROT)
      DIMENSION
     *          OVEEIG(1:NDPROD),HAMEIG(1:NDPROD)
      DIMENSION
     *          LINDIM(2),HAFLIN(1:NDPROD,2)
C
      COMMON
     *       /FERMIR/ F_KT_R(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_R,IDIM_R,IIFERR,ITFERR,ISFERR
      COMMON
     *       /APROJE/ EPROJE(NDPROM,NDISOM),OPROJE(NDPROM,NDISOM)
C=======================================================================
C            ATTENTION: VALUE OF NDISOK CHANGED IN VERSION (2.82A) ON
C            17/07/2017
C=======================================================================
      COMMON
     *       /ALL_3D/ NUM_3D(0:NDPROI,0:NDPROT),N3DMIX(0:NDPROI)
      COMMON
     *       /ISOIND/ ISOMAT(NDISOM),LSOMAT(NDISOM),KSOMAT(NDISOM)
      COMMON
     *       /IMKIND/ INDIMK(0:NDPROI,-NDPROI:NDPROI,-NDPROI:NDPROI)
      COMMON
     *       /TMKIND/ INDTMK(0:NDPROT,-NDPROT:NDPROT,-NDPROT:NDPROT)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      KPRSTA(IPRDUM)=IAXIAL*KPROJE-(1-IAXIAL)*IPRDUM
      KPRSTO(IPRDUM)=IAXIAL*KPROJE+(1-IAXIAL)*IPRDUM
C
      LPRSTA(IPRDUM)=IAXIAL*KPLEFT-(1-IAXIAL)*IPRDUM
      LPRSTO(IPRDUM)=IAXIAL*KPLEFT+(1-IAXIAL)*IPRDUM
C
      KSOSTA(IPRDUM)=IAXIAT*ISOSTZ-(1-IAXIAT)*IPRDUM
      KSOSTO(IPRDUM)=IAXIAT*ISOSTZ+(1-IAXIAT)*IPRDUM
C
      IND_IK(IPRDUM,KPRDUM)=(IPRDUM**2-IHALF_)/4+(IPRDUM+KPRDUM)/2+1
C
      CALL CPUTIM('DIAP3D',1)
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HAMILTONIAN MATRIX FOR
C         THE ANGULAR-MOMENTUM AND 3D-ISOSPIN PROJECTED STATES
C=======================================================================
C         THE SUBROUTINE GIVES THE K-MIXED EIGENVECTORS IN  THE  ARRAY
C         "WAV_3D", THEIR EIGEN-ENERGIES IN  THE  ARRAY  "ENE_3D"  AND
C         THE NUMBER THEREOF IN THE  ARRAY "NUM_3D". VALUES OF "0"  IN
C         NUM_3D  ARRAY MEAN THE ABSENCE OF THE GIVEN SPIN AND ISOSPIN
C         COMPONENT IN THE HF WAVE FUNCTION; IN THIS CASE "WAV_3D" AND
C         "ENE_3D" ARRAYS ARE NOT DEFINED.
C=======================================================================
C
                       CHALF_='  '
      IF (IHALF_.EQ.1) CHALF_='/2'
C
      IEVEN_=2/(IHALF_+1)
C
      ISTORE=0
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        ALLOCATING LOCAL ARRAYS
C=======================================================================
C
      ALLOCATE (CELMTS(1:((NDPROD+1)*NDPROD)/2),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIAP3D')
      ALLOCATE (OVEWAV(1:NDPROD,1:NDPROD),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('OVEWAV','DIAP3D')
      ALLOCATE (HAMWAV(1:NDPROD,1:NDPROD),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('HAMWAV','DIAP3D')
      ALLOCATE (HAMMAT(1:NDPROD,1:NDPROD),STAT=IALLOC)
            IF (IALLOC.NE.0) CALL NOALLO('HAMMAT','DIAP3D')
C
      IF (.NOT.ALLOCATED(WAV_3D)) THEN
          ALLOCATE (WAV_3D(0:NDPROK,1:NDPROD,NDISOK),STAT=IALLOC)
                IF (IALLOC.NE.0) CALL NOALLO('WAV_3D','DIAP3D')
      END IF
      IF (.NOT.ALLOCATED(ENE_3D)) THEN
          ALLOCATE (ENE_3D(0:NDPROI,1:NDPROD,0:NDPROT),STAT=IALLOC)
                IF (IALLOC.NE.0) CALL NOALLO('ENE_3D','DIAP3D')
      END IF
C
C=======================================================================
C            DETERMINING DIMENSIONS OF THE SPIN-ISOSPIN BLOCKS
C=======================================================================
C
      IDIMAX=0
C
      DO ISOSAC=JSOSMI,JSOSMA,2
         DO IPROAC=JPROMI,JPROMA,2
C
            IDIM=0
C
            DO LSOSAC=KSOSTA(ISOSAC),KSOSTO(ISOSAC),2
               DO LPROAC=KPRSTA(IPROAC),KPRSTO(IPROAC),2
C
                  IDIM=IDIM+1
C
               END DO
            END DO
C
            IPRDIM(IPROAC,ISOSAC)=IDIM
C
            IDIMAX=MAX(IDIMAX,IDIM)
C
         END DO
      END DO
C
      IF (IDIMAX.GT.NDPROD) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' PARAMETER NDPROD TOO SMALL'',
     *                     '' IN DIAP3D'',       1X,19(1H/),/,
     *          1X,20(1H/),'' NDPROD ='',I3,
     *                     '' INCREASE(1) TO VALUE='',I3,
     *                                           1X,19(1H/),/)')
     *
     *    NDPROD,IDIMAX
C
          STOP 'INCREASE NDPROD IN DIAP3D (1)'
C
      END IF
C
      IF (IDIMAX.LT.NDPROD) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' PARAMETER NDPROD TOO LARGE'',
     *                     '' IN DIAP3D'',       1X,19(1H/),/,
     *          1X,20(1H/),'' NDPROD ='',I3,
     *                     '' CAN BE DECRESED(1) TO'',I3,
     *                                           1X,19(1H/),/)')
     *
     *    NDPROD,IDIMAX
C
      END IF
C
C=======================================================================
C            HERE START LOOPS OVER THE ISOSPIN AND ANGULAR MOMENTUM
C=======================================================================
C
      DO ISOSAC=JSOSMI,JSOSMA,2
         DO IPROAC=JPROMI,JPROMA,2
C
            IBRA=0
C
            DO LSOSAC=KSOSTA(ISOSAC),KSOSTO(ISOSAC),2
               DO LPROAC=LPRSTA(IPROAC),LPRSTO(IPROAC),2
C
                  IBRA=IBRA+1
                  IKET=0
C
                  DO KSOSAC=KSOSTA(ISOSAC),KSOSTO(ISOSAC),2
                     DO KPROAC=KPRSTA(IPROAC),KPRSTO(IPROAC),2
C
                        IKET=IKET+1
C
                        HAMMAT(IBRA,IKET)=
     *                           EPROJE(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                  INDTMK(ISOSAC,LSOSAC,KSOSAC))
C
CWS       WRITE(*,1889) ISOSAC,IPROAC,LSOSAC,LPROAC,KSOSAC,KPROAC,
CWS     *               IBRA,IKET,HAMMAT(IBRA,IKET)
CWS 1889  FORMAT(' HAMMAT1',4X,2I4,4X,4I4,4X,2I4,2F16.8)
C
                        IF (IBRA.GE.IKET) THEN
C
                            NCOUNT=IBRA+((2*IPRDIM(IPROAC,ISOSAC)-IKET)*
     *                                                       (IKET-1))/2
C
                            CELMTS(NCOUNT)=
     *                           OPROJE(INDIMK(IPROAC,LPROAC,KPROAC),
     *                                  INDTMK(ISOSAC,LSOSAC,KSOSAC))
C
                        END IF
C
                     END DO
                  END DO
               END DO
            END DO
C
            CALL DIAMAT(CELMTS,OVEEIG,OVEWAV,IPRDIM(IPROAC,ISOSAC),
     *                                NDPROD,IPRDIM(IPROAC,ISOSAC))
C
C=======================================================================
C           DEFINING THE HAMILTONIAN MATRIX FOR A GIVEN SPIN=IPROAC/2
C                                                AND ISOSPIN=ISOSAC/2
C=======================================================================
C
C=======================================================================
C           DEFINING THE OVERLAP CUT-OFF PARAMETER OVEMIN BASED ON THE
C           SMALLEST (NEGATIVE) EIGENVALUE OF THE OVERLAP MATRIX  (SEE
C           THE ANALYSIS BY BURZYNSKI & DOBACZEWSKI, PRC 51,1825(1995)
C=======================================================================
C
            OVEMIN=-OVEEIG(1)
C
            IF (ICUTOV.EQ.1) OVEMIN=CUTOWE+CUTOWF*OVEMIN
C
C=======================================================================
C           CUTTING-OFF THE SMALL EIGENVALUES
C=======================================================================
C
            IPRMIN=0
C
            DO IBAS=IPRDIM(IPROAC,ISOSAC),1,-1
C
               IF(OVEEIG(IBAS).GT.OVEMIN) IPRMIN=IBAS
C
C JD           WRITE(*,'('' WYMIARY'',4I5,E14.6)') IPROAC,ISOSAC,
C JD *                       IPRDIM(IPROAC,ISOSAC),IBAS,OVEEIG(IBAS)
C
            END DO
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN NO EIGENVECTORS WERE
C           ACCEPTED IN TO THE GCM SPACE, I.E., SPECIFIC VALUES
C           OF THE SPIN=IPROAC/2 AND ISOSPIN=ISOSAC/2 DO NOT APPEAR
C           IN THE HF WAVE FUNCTION
C=======================================================================
C
            IF (IPRMIN.EQ.0) THEN
C
                NUM_3D(IPROAC,ISOSAC)=0
C
            ELSE
C
C=======================================================================
C           HERE WE TREAT THE SITUATION WHEN SOME EIGENVECTORS WERE
C           ACCEPTED IN TO THE GCM SPACE
C=======================================================================
C
                KPRDIM=IPRDIM(IPROAC,ISOSAC)-IPRMIN+1
C
                DO JBRA=IPRMIN,IPRDIM(IPROAC,ISOSAC)
                   DO JKET=IPRMIN,IPRDIM(IPROAC,ISOSAC)
C
                      HAMCUT=C_ZERO
C
                      DO IBRA=1,IPRDIM(IPROAC,ISOSAC)
                         DO IKET=1,IPRDIM(IPROAC,ISOSAC)
C
                            HAMCUT=HAMCUT+CONJG(OVEWAV(IBRA,JBRA))
     *                                         *HAMMAT(IBRA,IKET)
     *                                         *OVEWAV(IKET,JKET)
C
                         END DO
                      END DO
C
                      HAMCUT=HAMCUT/SQRT(OVEEIG(JBRA)*OVEEIG(JKET))
C
                      KBRA=JBRA-IPRMIN+1
                      KKET=JKET-IPRMIN+1
C
CWS      WRITE(*,1890) KBRA,KKET,HAMCUT,SQRT(OVEEIG(JBRA)*OVEEIG(JKET))
CWS 1890 FORMAT(6X,'HAMCUT',2I6,3F16.10)
C
                      IF (KBRA.GE.KKET) THEN
C
                          NCOUNT=KBRA+((2*KPRDIM-KKET)*(KKET-1))/2
C
                          CELMTS(NCOUNT)=HAMCUT
C
                      END IF
C
                   END DO
                END DO
C
                CALL DIAMAT(CELMTS,HAMEIG,HAMWAV,KPRDIM,NDPROD,KPRDIM)
C
C=======================================================================
C           CALCULATING THE WAVE FUNCTIONS
C=======================================================================
C
                DO KBRA=1,KPRDIM
C
                   IKET=0
C
                   DO KSOSAC=KSOSTA(ISOSAC),KSOSTO(ISOSAC),2
                      DO KPROAC=KPRSTA(IPROAC),KPRSTO(IPROAC),2
C
                         IKET=IKET+1
C
                         FPROJE=C_ZERO
C
                         DO JBAS=IPRMIN,IPRDIM(IPROAC,ISOSAC)
                            KBAS=JBAS-IPRMIN+1
C
                            FPROJE=FPROJE+OVEWAV(IKET,JBAS)
     *                                   /SQRT(OVEEIG(JBAS))
     *                                   *HAMWAV(KBAS,KBRA)
C
                         END DO
C
                         IF (IND_IK(IPROAC,KPROAC).GT.MINDIK)
     *                       STOP ' WRONG INDEX IN DIAP3D (1)'
C
                         WAV_3D(IND_IK(IPROAC,KPROAC),KBRA,
     *                          IND_IK(ISOSAC,KSOSAC))=FPROJE
C
                      END DO
                   END DO
C
                   ENE_3D(IPROAC,KBRA,ISOSAC)=HAMEIG(KBRA)
C
CWS         WRITE(*,1888) IPROAC,KBRA,ISOSAC,ENE_3D(IPROAC,KBRA,ISOSAC)
CWS 1888    FORMAT(2X,3I4,F16.8)
C
                END DO
C
                NUM_3D(IPROAC,ISOSAC)=KPRDIM
C
            END IF
C
C=======================================================================
C       HERE END THE LOOPS OVER THE ANGULAR MOMENTUM AND THE ISOSPIN
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C        PRINTING THE RESULTS OF THE K-MIXING FOR DIFFERENT ISOSPIN
C        COMPONENTS:
C=======================================================================
C
      IF (LPROJJ.EQ.0.OR.IAXIAT.EQ.0) GOTO 110
C
      WRITE(NFIPRI,'(1H*,77(1H*),1H*)')
C
      IF (IAXIAL.NE.1.AND.LPROJT.EQ.0) THEN
               WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,23X,''RESULTS OF K-MIXING CALCULATION'',
     *                                             23X,1H*,/,
     *                                         1H*,77X,1H*,/,
     *                                     1H*,77(1H*),1H*)')
      END IF
C
      DO ISOSAC=JSOSMI,JSOSMA,2
C
      IF (IAXIAL.NE.1) THEN
               WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,17X,'' RESULTS OF K-MIXING CALCULATION'',
     *                 '' FOR T = '',           I2,A2,15X,1H*,/,
     *                                            1H*,77X,1H*,/,
     *                                        1H*,77(1H*),1H*)')
     *
     *                  ISOSAC/IEVEN_,CHALF_
      END IF
C
      I_HALF=0
      I_HEAD=0
C
      DO KBRA=1,JPROMA+1
C
         HAFLIN(KBRA,1)='                                      '
         HAFLIN(KBRA,2)='                                      '
C
      END DO
C
      DO IPROAC=JPROMI,JPROMA,2
C
         KPRDIM=NUM_3D(IPROAC,ISOSAC)
C
         IF (KPRDIM.GT.0.AND.IMIPRI.GT.0.AND.IAXIAL.NE.1.AND.
     *                   IPROAC.GE.ISLPRI.AND.IPROAC.LE.ISUPRI) THEN
C
             I_HALF=I_HALF+1
C
             LINDIM(I_HALF)=KPRDIM
C
             DO KBRA=1,KPRDIM
C
                WRITE(HAFLIN(KBRA,I_HALF),
     *                '(2X,I4,A2,I4,F13.6,2X)')
     *             IPROAC/IEVEN_,CHALF_,KBRA,
C    *             OVE_3D(IPROAC,KBRA,ISOSAC),
     *             ENE_3D(IPROAC,KBRA,ISOSAC)
C
             END DO
C
             IF (I_HALF.EQ.2) THEN
C
                 I_HALF=0
C
                 IF (I_HEAD.EQ.0) THEN
C
                     IF (IEVEN_.EQ.1) THEN
C
                         HAFLIM='      I    N    OVERLAP       ENERGY  '
C
                     ELSE
C
                         HAFLIM='    I      N    OVERLAP       ENERGY  '
C
                     END IF
C
                     WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                  1H*,1X,'' RESULTS OF THE K-MIXING CALCULATION'',
     *                         '' FOR THE FOLLOWING OVERLAP'',
     *                         '' CUTOFF DATA'',    2X,1H*,/,
     *                  1H*,1X,'' ICUTOV='',I1,'', CUTOVE='',1PE8.1,
     *                                         '', CUTOVF='',1PE8.1,
     *                                                33X,1H*,/,
     *                                            1H*,77X,1H*,/,
     *                          79(1H*),/,1H*,38X,1H|,38X,1H*,/,
     *                                    1H*,A38,1H|,A38,1H*,/,
     *                                    1H*,38X,1H|,38X,1H*,/,
     *                            1H*,38(1H*),1H|,38(1H*),1H*)')
     *
     *                  ICUTOV,CUTOWE,CUTOWF,HAFLIM,HAFLIM
C
                     I_HEAD=1
C
                 END IF
C
                 DO KBRA=1,MAX(LINDIM(1),LINDIM(2))
C
                    WRITE(NFIPRI,'(1H*,A38,1H|,A38,1H*)')
     *                                     HAFLIN(KBRA,1),HAFLIN(KBRA,2)
C
                 END DO
C
                 WRITE(NFIPRI,'(1H*,38(1H-),1H|,38(1H-),1H*)')
C
                 DO KBRA=1,JPROMA+1
C
                 HAFLIN(KBRA,1)='                                      '
                 HAFLIN(KBRA,2)='                                      '
C
                 END DO
C
             END IF
C
         END IF
C
      END DO
C
      IF (I_HALF.EQ.1) THEN
C
          DO KBRA=1,LINDIM(1)
C
             WRITE(NFIPRI,'(1H*,A38,1H|,38X,1H*)') HAFLIN(KBRA,1)
C
          END DO
C
      END IF
C
      IF (IMIPRI.GT.0.AND.IAXIAL.NE.1) WRITE(NFIPRI,'(79(1H*))')
C
C=======================================================================
C       HERE ENDS THE LOOP OVER THE ISOSPIN IN THE PRINTING BLOCK
C=======================================================================
C
      END DO
C
  110 CONTINUE
C
      IF (LPROJT.EQ.0) GOTO 111
C
C=======================================================================
C           HERE STARTS THE COULOMB REDIAGONALIZATION BLOCK
C      COULOMB MIXING PROCEEDS WITHIN I,T_z BLOCKS
C=======================================================================
C
      WRITE(*,2888) ISOSTZ
 2888 FORMAT(1H*,30X,'ISOSTZ = N-Z =',I3,30X,1H*)
C
      N3DMAX=0
C
      DO IPROAC=JPROMI,JPROMA,2
C
C=======================================================================
C         CALCULATING DIMENSION OF THE HAMILTONIAN MATRIX FOR
C                     A GIVEN SPIN VALUE IPROAC
C=======================================================================
C
         II=0
C
         DO ISOSAC=IABS(ISOSTZ),JSOSMA,2
C
            II=II+NUM_3D(IPROAC,ISOSAC)
C
         END DO
C
         N3DMIX(IPROAC)=II
C
         N3DMAX=MAX(N3DMAX,II)
C
      END DO
C
      IF (N3DMAX.GT.NDPROD) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' PARAMETER NDPROD TOO SMALL'',
     *                     '' IN DIAP3D'',       1X,19(1H/),/,
     *          1X,20(1H/),'' NDPROD ='',I3,
     *                     '' INCREASE(2) TO VALUE='',I3,
     *                                           1X,19(1H/),/)')
     *
     *    NDPROD,N3DMAX
C
          STOP 'INCREASE NDPROD IN DIAP3D (2)'
C
      END IF
C
      IF (N3DMAX.LT.NDPROD) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' PARAMETER NDPROD TOO LARGE'',
     *                     '' IN DIAP3D'',       1X,19(1H/),/,
     *          1X,20(1H/),'' NDPROD ='',I3,
     *                     '' CAN BE DECRESED(2) TO'',I3,
     *                                           1X,19(1H/),/)')
     *
     *    NDPROD,N3DMAX
C
      END IF
C
      DO IPROAC=JPROMI,JPROMA,2
C
         IF (N3DMIX(IPROAC).EQ.0) THEN
            WRITE(*,112) IPROAC/IEVEN_,CHALF_
 112        FORMAT(1H*,77X,1H*,/,
     *            1H*,11X,'THERE IS NO SPIN I=',I3,A2,
     *               ' COMPONENT IN THE WAVE FUNCTION',11X,1H*,/,
     *            1H*,77X,1H*)
            GOTO 113
         END IF
C
C=======================================================================
C        CALCULATING HAMILTONIAN MATRIX ELEMENTS AND PERFORMING
C                    COULOMB REDIAGONALIZATION
C    IT IS ASSUMED THAT, ON ENTRY, THE HAMILTONIAN IS DIAGONAL IN
C               GOOD SPIN AND GOOD ISOSPIN BASIS.
C   THE OFF-DIAGONAL MATRIX ELEMENTS IN ISOSPIN ARE CALCULATED BELOW
C=======================================================================
C
         HAMMAT=C_ZERO
C
         IL=0
C
         DO ISOBRA=IABS(ISOSTZ),JSOSMA,2
C
            DO II=1,NUM_3D(IPROAC,ISOBRA)
C
            IL=IL+1
            IR=0
C
               DO ISOKET=IABS(ISOSTZ),JSOSMA,2
C
                  DO JJ=1,NUM_3D(IPROAC,ISOKET)
                  IR=IR+1
C
                  IF (IL.EQ.IR)
     *               HAMMAT(IL,IL)=ENE_3D(IPROAC,II,ISOKET)
C
                  E10ALL=CGCOEF(ISOKET,ISOSTZ,2,0,ISOBRA,ISOSTZ)
                  E20ALL=CGCOEF(ISOKET,ISOSTZ,4,0,ISOBRA,ISOSTZ)
C
                     DO KSOBRA=-ISOBRA,ISOBRA,2
C
                     E_10=CGCOEF(ISOKET,KSOBRA  ,2, 0,ISOBRA,KSOBRA)
                     E11P=CGCOEF(ISOKET,KSOBRA-2,2, 2,ISOBRA,KSOBRA)
                     E11M=CGCOEF(ISOKET,KSOBRA+2,2,-2,ISOBRA,KSOBRA)
C
                     E_20=CGCOEF(ISOKET,KSOBRA  ,4, 0,ISOBRA,KSOBRA)
                     E21P=CGCOEF(ISOKET,KSOBRA-2,4, 2,ISOBRA,KSOBRA)
                     E21M=CGCOEF(ISOKET,KSOBRA+2,4,-2,ISOBRA,KSOBRA)
                     E22P=CGCOEF(ISOKET,KSOBRA-4,4, 4,ISOBRA,KSOBRA)
                     E22M=CGCOEF(ISOKET,KSOBRA+4,4,-4,ISOBRA,KSOBRA)
C
                     E2_10=E10ALL*E_10
                     E211P=E10ALL*E11P
                     E211M=E10ALL*E11M
C
                     E2_20=E20ALL*E_20
                     E221P=E20ALL*E21P
                     E221M=E20ALL*E21M
                     E222P=E20ALL*E22P
                     E222M=E20ALL*E22M
C
                        DO KSOKET=-ISOKET,ISOKET,2
C
                           DO LPROAC=-IPROAC,IPROAC,2
                              DO KPROAC=-IPROAC,IPROAC,2
C
                              IF (IND_IK(IPROAC,LPROAC).GT.MINDIK)
     *                            STOP ' WRONG INDEX IN DIAP3D (2)'
                              IF (IND_IK(IPROAC,KPROAC).GT.MINDIK)
     *                            STOP ' WRONG INDEX IN DIAP3D (3)'
C
                              IF(IABS(KSOBRA  ).LE.ISOKET)
     *                        HAMMAT(IL,IR)=HAMMAT(IL,IR)+
     *                       (E2_10*
     *                       (TC1_D0(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA,KSOKET))+
     *                        TC1_X0(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA,KSOKET)))
     *                       +E2_20*
     *                       (TC2_D0(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA,KSOKET))+
     *                        TC2_X0(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA,KSOKET))))
     *                           *CONJG(WAV_3D(IND_IK(IPROAC,LPROAC),
     *                                      II,IND_IK(ISOBRA,KSOBRA)))
     *                                 *WAV_3D(IND_IK(IPROAC,KPROAC),
     *                                      JJ,IND_IK(ISOKET,KSOKET))
C
                              IF(IABS(KSOBRA-2).LE.ISOKET)
     *                        HAMMAT(IL,IR)=HAMMAT(IL,IR)+
     *                       (E211P*
     *                       (TC1_DP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA-2,KSOKET))+
     *                        TC1_XP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA-2,KSOKET)))
     *                       +E221P*
     *                       (TC21DP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA-2,KSOKET))+
     *                        TC21XP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA-2,KSOKET))))
     *                           *CONJG(WAV_3D(IND_IK(IPROAC,LPROAC),
     *                                      II,IND_IK(ISOBRA,KSOBRA)))
     *                                 *WAV_3D(IND_IK(IPROAC,KPROAC),
     *                                      JJ,IND_IK(ISOKET,KSOKET))
C
                              IF(IABS(KSOBRA+2).LE.ISOKET)
     *                        HAMMAT(IL,IR)=HAMMAT(IL,IR)+
     *                       (E211M*
     *                       (TC1_DM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                              INDTMK(ISOKET,KSOBRA+2,KSOKET))+
     *                        TC1_XM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA+2,KSOKET)))
     *                       +E221M*
     *                       (TC21DM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA+2,KSOKET))+
     *                        TC21XM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA+2,KSOKET))))
     *                           *CONJG(WAV_3D(IND_IK(IPROAC,LPROAC),
     *                                      II,IND_IK(ISOBRA,KSOBRA)))
     *                                 *WAV_3D(IND_IK(IPROAC,KPROAC),
     *                                      JJ,IND_IK(ISOKET,KSOKET))
C
                              IF(IABS(KSOBRA-4).LE.ISOKET)
     *                        HAMMAT(IL,IR)=HAMMAT(IL,IR)+
     *                       (E222P*
     *                       (TC22DP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA-4,KSOKET))+
     *                        TC22XP(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA-4,KSOKET))))
     *                           *CONJG(WAV_3D(IND_IK(IPROAC,LPROAC),
     *                                      II,IND_IK(ISOBRA,KSOBRA)))
     *                                 *WAV_3D(IND_IK(IPROAC,KPROAC),
     *                                      JJ,IND_IK(ISOKET,KSOKET))
C
                              IF(IABS(KSOBRA+4).LE.ISOKET)
     *                        HAMMAT(IL,IR)=HAMMAT(IL,IR)+
     *                       (E222M*
     *                       (TC22DM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA+4,KSOKET))+
     *                        TC22XM(INDIMK(IPROAC,LPROAC,KPROAC),
     *                               INDTMK(ISOKET,KSOBRA+4,KSOKET))))
     *                           *CONJG(WAV_3D(IND_IK(IPROAC,LPROAC),
     *                                      II,IND_IK(ISOBRA,KSOBRA)))
     *                                 *WAV_3D(IND_IK(IPROAC,KPROAC),
     *                                      JJ,IND_IK(ISOKET,KSOKET))
CWS
CWS      IF ((IL.EQ.1.AND.IR.EQ.3).OR.(IL.EQ.3.AND.IR.EQ.1)) THEN
CWS      WRITE(*,2777) IL,IR,ISOBRA,KSOBRA,ISOKET,KSOKET,
CWS     *              HAMMAT(IL,IR)
CWS 2777 FORMAT(2X,'INDTMK:',2X,6I4,2F16.8)
CWS      END IF
CWS
C
                              END DO
                           END DO
C
                        END DO
                     END DO
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (IENPRI.EQ.2) WRITE(*,212)
 212        FORMAT(1H*,77X,1H*,/,
     *             1H*,21X,'MATRIX ELEMENTS OF THE HAMILTONIAN',22X,
     *             1H*,/,1H*,77X,1H*)
C
         IDIM=N3DMIX(IPROAC)
C
         DO IL=1,IDIM
            DO IR=1,IL
C
               IF (IENPRI.EQ.2)
     *            WRITE(*,213) IL,IR,HAMMAT(IL,IR),IR,IL,HAMMAT(IR,IL)
 213              FORMAT(1H*,2(2I3,2F16.10),1X,1H*)
C
               NCOUNT=IL+((2*IDIM-IR)*(IR-1))/2
               CELMTS(NCOUNT)=HAMMAT(IL,IR)
C
            END DO
         END DO
C
         CALL DIAMAT(CELMTS,HAMEIG,HAMWAV,IDIM,NDPROD,IDIM)
C
         IF (LPROJJ.EQ.0)
     *       WRITE(*,664)
 664         FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *       1H*,26X,'ISOSPIN-MIXED EIGENSTATES',
     *       26X,1H*,/,1H*,26X,25(1H-),26X,1H*,/,1H*,77X,1H*)
C
         IF (LPROJJ.EQ.1)
     *       WRITE(*,665) IPROAC/IEVEN_,CHALF_
 665         FORMAT(79(1H*),/,1H*,77X,1H*,/,
     *       1H*,17X,'ISOSPIN- AND K-MIXED EIGENSTATES FOR I=',I2,A2,
     *       17X,1H*,/,1H*,17X,43(1H-),17X,1H*,/,1H*,77X,1H*)
C
         WRITE(*,666)
 666         FORMAT(1H*,3X,'  N',2X,'     EIGENENERGY',4X,' i',2X,
     *              '  T  ',2X,
     *              '   |C_i|^2',2X,'   Re[C_i]',2X,'   Im[C_i]',4X,
     *              1H*,/,1H*,77X,1H*)
C
         IT_BLO=0
C
         DO MM=1,IDIM
C
            IT=0
            LL=0
            DO ISOSPI=IABS(ISOSTZ),JSOSMA,2
               IT=IT+1
C
               DO LI=1,NUM_3D(IPROAC,ISOSPI)
                  LL=LL+1
C
                  IF (LL.EQ.1)
     *            WRITE(*,667) MM,HAMEIG(MM),LL,ISOSPI/IEVEN_,CHALF_,
     *                    ABS(HAMWAV(LL,MM))**2, REAL(HAMWAV(LL,MM)),
     *                                          AIMAG(HAMWAV(LL,MM))
 667              FORMAT(1H*,3X,I3,2X,F16.6,4X,I2,2X,I3,A2,3(2X,F10.6),
     *                                                        4X,1H*)
                  IF (LL.GT.1)
     *            WRITE(*,668)                LL,ISOSPI/IEVEN_,CHALF_,
     *                     ABS(HAMWAV(LL,MM))**2, REAL(HAMWAV(LL,MM)),
     *                                           AIMAG(HAMWAV(LL,MM))
 668              FORMAT(1H*,28X,I2,2X,I3,A2,3(2X,F10.6),4X,1H*)
C
               END DO
C
            END DO
C
C=======================================================================
C          CALCULATE DOMINANT ISOSPIN COMPONENT (STATE'S ISOPIN)
C             AND ISOSPIN MIXING FOR A GIVEN EIGENSTATE "MM"
C=======================================================================
C
            WAVMAX=0
            NN=0
C
               DO ISOSAC=IABS(ISOSTZ),JSOSMA,2
               WAVISO=0
C
                  DO LL=1,NUM_3D(IPROAC,ISOSAC)
                     NN=NN+1
                     WAVISO=WAVISO+ABS(HAMWAV(NN,MM))**2
                  END DO
C
                  IF (WAVISO.GE.WAVMAX) THEN
                     WAVMAX=WAVISO
                     CO_MIX=1-WAVMAX
                     ISOMAX=ISOSAC
                  END IF
C
               END DO
C
            WRITE(*,669) WAVMAX,ISOMAX/IEVEN_,CHALF_,CO_MIX,
     *                                                  CO_MIX*100
 669        FORMAT(1H*,1X,'DOMINANT AMPLITUDE SQUARED EQUALS:',
     *            F14.10,' AND CORRESPONDS TO T =',I2,A2,1X,1H*,/,
     *         1H*,1X,'COULOMB MIXING IN  THIS  STATE IS:',F14.10,
     *        ' [',F10.6,'%]',14X,1H*,/,1H*,77X,1H*,/,1H*,77X,1H*)
C
C==========================================================================
C       STORE WAVE FUNCTION FOR FURTHER CALCULATION OF THE TRANSITION M.E.
C       THE STORED WAVE FUNCTION IS IDENTIFIED BY ITS:
C       ANGULAR MOMENTUM                                        -  IIFERR
C       ISOSPIN (DOMINANT COMPONENT)                            -  ITFERR
C       EXCITATION ENERGY WITHIN A GIVEN IIFERR,ITFERR BLOCK    -  ISFERR
C==========================================================================
C
            IF (IBETME.NE.0) THEN
C
               IF (IPROAC.EQ.IIFERR.AND.ISOMAX.EQ.ITFERR
     *                            .AND.ISTORE.EQ.0) THEN
C
               IT_BLO=IT_BLO+1
               IF (IT_BLO.NE.ISFERR) GO TO 313
C
               EIGE_R=HAMEIG(MM)
               IDIM_R=N3DMIX(IPROAC)
C
               WRITE(*,1)
  1            FORMAT(1H*,1X,'-> EXPANSION COEFFICIENTS F_KT OF THE',
     *                      ' W.F. OF THE STATE ABOVE ARE STORED <-',
     *                                        1X,1H*,/,1H*,77X,1H*,/,
     *               1H*,16X,'i',2X,'  K',2X,'  T',12X,'Re(F_KT)',8X,
     *                                            'Im(F_KT)',14X,1H*)
C
               ISTORE=1
               IDIMAX=0
C
                  DO ISOSAC=JSOSMI,JSOSMA,2
C
                  IDIMIN=IDIMAX+1
                  IDIMAX=IDIMAX+NUM_3D(IIFERR,ISOSAC)
C
                     DO KPROAC = -IIFERR,IIFERR,2
                        DO KSOSAC = -ISOSAC,ISOSAC,2
C
                        IF (IND_IK(IIFERR,KPROAC).GT.MINDIK)
     *                      STOP ' WRONG INDEX IN DIAP3D (4)'
C
                        F_KT_R(KPROAC,ISOSAC,KSOSAC)=C_ZERO
C
                           DO II=IDIMIN,IDIMAX
                              JJ=II-IDIMIN+1
                              F_KT_R(KPROAC,ISOSAC,KSOSAC)=
     *                        F_KT_R(KPROAC,ISOSAC,KSOSAC)+
     &                                                  HAMWAV(II,MM)*
     *                                   WAV_3D(IND_IK(IIFERR,KPROAC),
     *                                       JJ,IND_IK(ISOSAC,KSOSAC))
                           END DO
C
                           WRITE(*,17) IT,KPROAC/IEVEN_,CHALF_,
     *                                 ISOSAC/IEVEN_,CHALF_,
     *                                 F_KT_R(KPROAC,ISOSAC,KSOSAC)
  17                       FORMAT(1H*,14X,I3,2X,2(I3,A2),2X,2F16.6,
     *                                                      14X,1H*)
C
                        END DO
                     END DO
C
                     WRITE(*,18)
  18                 FORMAT(1H*,77X,1H*)
C
                  END DO
C
               END IF
C
            END IF
C
 313        CONTINUE
C
         END DO
C
 113  CONTINUE
C
      WRITE(*,670)
 670  FORMAT(79(1H*))
C
C=======================================================================
C                   BELOW ENDS THE "IPROAC" LOOP
C=======================================================================
C
      END DO
C
 111  CONTINUE
C
C=======================================================================
      DEALLOCATE (CELMTS,OVEWAV,HAMWAV,HAMMAT)
C=======================================================================
C
      CALL CPUTIM('DIAP3D',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE REDPRO(JPROMI,JPROMA,KPROJE,KPLEFT,IAXIAL,IHALF_,
     *                  ISCHIF,NMURED,NMARED,NASRED,NSIRED,NSIMIN,
     *                         ILFWAV,IRGWAV,NFIWAV,FILWAV,
     *                  IDIAGO,IRMPRI,IELPRI,ISLPRI,ISUPRI,
     *                  LPROJJ,IWRIRM,NFIRED,NMAORD,NASORD,
     *                  MINDIK,NUISOM,QMUCUT,QMACUT,QASCUT,QSICUT)
C
C=======================================================================
C       >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C                        !!!  W A R N I N G !!!
C       THIS SUBROUTINE DOES NOT WORK FOR ISOSPIN PROJECTION YET
C             ALL ISOSPIN INDICES ARE TEMPORARLY SET TO 1
C       >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C
C=======================================================================
      USE REDMOM
      USE REEMOM
      USE HAMMIX
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          FILWAV*68
      CHARACTER
     *          CHALF_*2,IMAFLA*1
      CHARACTER
     *          NAMMUL*45,NAMELE*45,NAMRBE*45,NAMSPE*45,NAMRBM*45,
     *          NAMSUR*45,NAMSCH*45,NAMMAG*45,NAMMAR*45,NAMSPM*45,
     *                              NAMASM*45,NAMASR*45,NAMSPA*45
      CHARACTER
     *          NAMWRK*45
      CHARACTER
     *          HAFLIN*38
      CHARACTER
     *          REEFIC*11
C
C=======================================================================
      COMPLEX
     *          C_ZERO
C
      DIMENSION
     *          HAFLIN(2)
C=======================================================================
      COMMON
     *       /ALLPRO/ NUMPRO(0:NDPROI,0:NDISOM)
      COMMON
     *       /ALLLEF/ NUMLEF(0:NDPROI,0:NDISOM)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /ASMUNI/ BUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /IPRIAM/ ILIMAM,IALLAM
      COMMON
     *       /ALLPRI/ IPRALL
C
      DATA
     *       NAMMUL /'MULTIPOLE MOMENTS [UNITS:  (10 FERMI)^LAMBDA]'/,
     *       NAMELE /'TRUE ELECTRIC MOMENTS [UNITS:   FERMI^LAMBDA]'/,
     *       NAMRBE /'RATES BE(IR--->IL) [UNITS:  FERMI^(2*LAMBDA)]'/,
     *       NAMSPE /'CORR ELECTRIC OPERATORS [UNITS: FERMI^LAMBDA]'/,
     *       NAMRBM /'RATES BM(IR--->IL)[UNITS: FERMI^(2*LAMBDA-2)]'/,
     *       NAMSUR /'SURFACE MOMENTS, UNITS: (10 FERMI)^(LAMBDA+2)'/,
     *       NAMSCH /'SCHIFF MOMENTS,  UNITS: (10 FERMI)^(LAMBDA+2)'/,
     *       NAMMAG /'P+N MAGNETIC MOMENTS [MGNTN*FERMI^(LAMBDA-1)]'/,
     *       NAMMAR /'P+N MAGNETIC MOMENTS [MTN*FERMI^(N+LAMBDA-1)]'/,
     *       NAMSPM /'P+N CORR MAG OPERTRS [MGNTN*FERMI^(LAMBDA-1)]'/,
     *       NAMASM /'SPIN-ASYMMETRY MOMNTS [(10*FERMI)^(LAMBDA+1)]'/,
     *       NAMASR /'MOMTS SPIN-ASYMMETRY [FM^N(10*FM)^(LAMBDA+1)]'/,
     *       NAMSPA /'CORR SPIN-ASY OPERTRS [(10*FERMI)^(LAMBDA+1)]'/
C
C=======================================================================
C
      KPRSTA(IPRDUM)=IAXIAL*KPROJE-(1-IAXIAL)*IPRDUM
      KPRSTO(IPRDUM)=IAXIAL*KPROJE+(1-IAXIAL)*IPRDUM
C
      LPRSTA(IPRDUM)=IAXIAL*KPLEFT-(1-IAXIAL)*IPRDUM
      LPRSTO(IPRDUM)=IAXIAL*KPLEFT+(1-IAXIAL)*IPRDUM
C
C     IND_LM(LAMDUM,MIUDUM)=LAMDUM**2+LAMDUM+MIUDUM+1
      IND_IK(IPRDUM,KPRDUM)=(IPRDUM**2-IHALF_)/4+(IPRDUM+KPRDUM)/2+1
C     INDIMK(IPRDUM,MPRDUM,KPRDUM)=(IPRDUM*(IPRDUM-1)*(IPRDUM+1))/6
C    *      +(IPRDUM+1)*((IPRDUM+MPRDUM)/2)+(IPRDUM+KPRDUM)/2+1
C    *      +(IPRDUM+1)*((IPRDUM+MPRDUM)/2)+(IPRDUM+KPRDUM)/2+1
      IND_IN(IPRDUM,KLEDUM)=(IPRDUM**2-IHALF_)/4+KLEDUM
C
C=======================================================================
C
      CALL CPUTIM('REDPRO',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(REEQ_P)) THEN
          ALLOCATE (REEQ_P(0:NDREDU),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REEQ_P','REDPRO')
      END IF
      IF (.NOT.ALLOCATED(REEM_P)) THEN
          ALLOCATE (REEM_P(0:NDREDU,0:NMAORD),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REEM_P','REDPRO')
      END IF
      IF (.NOT.ALLOCATED(REEA_T).AND.NASORD.GE.0) THEN
          ALLOCATE (REEA_T(0:NDREDU,0:NASORD),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REEA_T','REDPRO')
      END IF
      IF (.NOT.ALLOCATED(REES_P)) THEN
          ALLOCATE (REES_P(0:NDREDU),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REES_P','REDPRO')
      END IF
      IF (.NOT.ALLOCATED(INDREE)) THEN
          ALLOCATE (INDREE(NDPROK,0:NDMULR,NDPROK),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('INDREE','REDPRO')
      END IF
      IF (.NOT.ALLOCATED(WAVPRO)) THEN
          ALLOCATE (WAVPRO(0:NDPROK,1:NDPROD,NUISOM),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVPRO','REDPRO')
      END IF
      IF (.NOT.ALLOCATED(WAVLEF)) THEN
          ALLOCATE (WAVLEF(0:NDPROK,1:NDPROD,NUISOM),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVLEF','REDPRO')
      END IF
C
C=======================================================================
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE REDUCED MATRIX ELEMENTS BETWEEN
C         THE K-MIXED STATES.
C         IT IS IMPLEMENTED ONLY IN THE CASE  OF  SOLE  ANGULAR-MOMENTUM
C         PROJECTION.
C=======================================================================
C         ATTENTION: UP TO VERSION 2.77E, ROUTINE "REDPRO" WAS  PRINTING
C                    REAL PARTS OF NON-DIAGONAL MATRIX ELEMENTS  BETWEEN
C                    THE K-MIXED STATES. ALTHOUGH THIS WAS NOT REALLY  A
C                    BUG,  SUCH  MATRIX  ELEMENTS  DEPEND  ON  ARBITRARY
C                    PHASES  OF  THE  K-MIXED  STATES  AND   THUS   HAVE
C                    MEANINGLESS PHASES. THE AXIAL CASE IS AN EXCEPTION,
C                    BECAUSE THEN K IS A GOOD  QUANTUM  NUMBER  AND  THE
C                    K-MIXING HAS NO EFFECT.
C                    THE LOGIC OF PRINTING REDUCED MATRIX  ELEMENTS  WAS
C                    CORRECTED  ON  06/05/2016  IN  VERSION  (2.77H)  BY
C                    ALLOWING ROUTINE "REDPRO" TO  PRINT  ONLY  DIAGONAL
C                    MATRIX ELEMENTS, WHICH HAVE SIGNS OF SOME INTEREST,
C                    OR TO PRINT ALL MATRIX ELEMENTS IN THE AXIAL  CASE.
C                    OTHERWISE, FOR IELPRI=2 ROUTINE "REDPRO" PRINTS THE
C                    REDUCED TRANSITION RATES, WHICH  DEPEND  ON  MODULI
C                    SQUARED  OF  THE  MATRIX  ELEMENTS,  AND  ARE  THUS
C                    PHASE INDEPENDENT.
C         ATTENTION: UP TO VERSION 2.83J, PRINTING FOR THE  NON-DIAGONAL
C                    AXIAL CASE WAS INCORRECTLY NOT  ALLOWED.  THIS  BUG
C                    WAS CORRECTED ON 07/11/2017 IN VERSION (2.83K)
C=======================================================================
C         REDUCED MATRIX ELEMENTS BETWEEN K-MIXED STATES  PROJECTED FROM
C         TWO DIFFERENT REFERENCE STATES ARE  PHASE  DEPENDENT  AND THUS
C         WILL NEVER BE PRINTED
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
C=======================================================================
C
      IF (NUISOM.NE.1)STOP 'REDPRO NOT YET READY FOR ISOSPIN PROJECTION'
C
C=======================================================================
C
      IF (IDIAGO.NE.1.AND.IELPRI.NE.2.AND.IAXIAL.NE.1) GO TO 111
C
C=======================================================================
C
                       CHALF_='  '
      IF (IHALF_.EQ.1) CHALF_='/2'
C
      IEVEN_=2/(IHALF_+1)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
      IF (IDIAGO.NE.1) THEN
C
C=======================================================================
C         READING THE K-MIXING COEFFICIENTS. THE WAVE-FUNCTION FILES
C         WITH NUMBERS "ILFWAV" AND "IRGWAV" MUST CONTAIN PREVIOUSLY
C         SAVED BLOCKS 2.
C=======================================================================
C
          IWRBLO=2
C
          CALL READWF(NFIWAV,IRGWAV,FILWAV,IWRBLO,MINDIK,1,KPLEFT)
C
          WAVPRO=WAVLEF
          NUMPRO=NUMLEF
C
          CALL READWF(NFIWAV,ILFWAV,FILWAV,IWRBLO,MINDIK,1,KPLEFT)
C
C=======================================================================
C       VERIFY CONSITENCY BETWEEN THE LEFT AND RIGHT ANGULAR-MOMENTUM
C       PROJECTIONS
C=======================================================================
C
          IF (LPROJJ.EQ.1.AND.IDIAGO.NE.1.AND.IAXIAL.EQ.1.AND.
     *        IABS(KPLEFT).LT.IABS(KPROJE)) THEN
          WRITE(*,7023)
 7023     FORMAT(1H*,77X,1H*,/,
     *           1H*,2X,'ABS(KPLEFT)<ABS(KPROJE) NOT ALLOWED IN  ',
     *                  'REDPRO, REVERSE LEFT AND RIGHT',5X,1H*,/,
     *           1H*,77X,1H*,/,79(1H*))
          STOP 'ABS(KPLEFT)<ABS(KPROJE) IN REDPRO'
          ENDIF
C
      ELSE
C
C=======================================================================
C         THE K-MIXING COEFFICIENTS OF THE RIGHT STATE  ARE  ASSUMED
C         TO BE CALCULATED PREVIOUSLY.
C=======================================================================
C
          WAVLEF=WAVPRO
          NUMLEF=NUMPRO
C
      END IF
C
C=======================================================================
C
      INDREE(:,:,:)=0
      NUREEU=0
C
      REEQ_P(NUREEU)  =C_ZERO
      REEM_P(NUREEU,:)=C_ZERO
      REES_P(NUREEU)  =C_ZERO
      IF (NASORD.GE.0)
     *REEA_T(NUREEU,:)=C_ZERO
C
      DO IPRRIG=JPROMI,JPROMA,2
C
         DO KRIG=1,NUMPRO(IPRRIG,1)
C
            DO LAMBDA=0,NMURED
C
                                      IMXLEF=IPRRIG
               IF (IDIAGO.NE.1.OR.IALLAM.EQ.1)
     *                                IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
               DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C
                  DO KLEF=1,NUMLEF(IPRLEF,1)
C
                     IF (ILIMAM.NE.1.OR.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
C=======================================================================
C                    CHECKING IF THE LIST OF THE REDUCED MATRIX ELEMENTS
C                    IS NOT TOO LONG
C=======================================================================
C
                         IF (NUREEU.LT.NDREDU) THEN
C
                             NUREEU=NUREEU+1
                         ELSE
                             STOP ' INCREASE NDREDU IN REDPRO'
C
                         END IF
C
C=======================================================================
C
                         REEQ_P(NUREEU)  =C_ZERO
                         REEM_P(NUREEU,:)=C_ZERO
                         REES_P(NUREEU)  =C_ZERO
                         IF (NASORD.GE.0)
     *                   REEA_T(NUREEU,:)=C_ZERO
C
                         INDREE(IND_IN(IPRLEF,KLEF),LAMBDA,
     *                          IND_IN(IPRRIG,KRIG))=NUREEU
C
                         DO KPRRIG=KPRSTA(IPRRIG),KPRSTO(IPRRIG),2
                            DO KPRLEF=LPRSTA(IPRLEF),LPRSTO(IPRLEF),2
C
                            IF (IND_IK(IPRLEF,KPRLEF).GT.MINDIK)
     *                          STOP ' WRONG INDEX IN REDPRO (1)'
                            IF (IND_IK(IPRRIG,KPRRIG).GT.MINDIK)
     *                          STOP ' WRONG INDEX IN REDPRO (2)'
C
                               NUREDU=INDRED(IND_IK(IPRLEF,KPRLEF),
     *                                       LAMBDA,
     *                                       IND_IK(IPRRIG,KPRRIG))
C
                               REEQ_P(NUREEU)=REEQ_P(NUREEU)+CONJG
     *                            (WAVLEF(IND_IK(IPRLEF,KPRLEF),KLEF,1))
     *                                                   *REDQ_P(NUREDU)
     *                            *WAVPRO(IND_IK(IPRRIG,KPRRIG),KRIG,1)
C
                               IF (LAMBDA.GT.0.AND.LAMBDA.LE.NMARED)
     *
     *                         REEM_P(NUREEU,:)=
     *                         REEM_P(NUREEU,:)+CONJG
     *                            (WAVLEF(IND_IK(IPRLEF,KPRLEF),KLEF,1))
     *                                            *REDM_P(NUREDU,:)
     *                            *WAVPRO(IND_IK(IPRRIG,KPRRIG),KRIG,1)
C
                               IF (LAMBDA.GT.0.AND.LAMBDA.LE.NASRED.AND.
     *                             NASORD.GE.0)
     *
     *                         REEA_T(NUREEU,:)=
     *                         REEA_T(NUREEU,:)+CONJG
     *                            (WAVLEF(IND_IK(IPRLEF,KPRLEF),KLEF,1))
     *                                            *REDA_T(NUREDU,:)
     *                            *WAVPRO(IND_IK(IPRRIG,KPRRIG),KRIG,1)
C
                               IF(LAMBDA.GE.NSIMIN.AND.LAMBDA.LE.NSIRED)
     *
     *                         REES_P(NUREEU)=REES_P(NUREEU)+CONJG
     *                            (WAVLEF(IND_IK(IPRLEF,KPRLEF),KLEF,1))
     *                                                   *REDS_P(NUREDU)
     *                            *WAVPRO(IND_IK(IPRRIG,KPRRIG),KRIG,1)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         PRINTING (COMMENT 1 IN REDPRO):
C         REDUCED MATRIX ELEMENTS OF MULTIPOLE OPERATORS  (FOR IELPRI=0)
C         REDUCED MATRIX ELEMENTS OF TRUE ELECTRIC OPERATORS  (IELPRI=1)
C         REDUCED TRANSITION RATES FOR IR->IL ELECTRIC TRNSTS (IELPRI=2)
C         ALIGNED (SPECTROSCOPIC) M-ELS OF TRUE ELECTRIC OPRS (IELPRI=3)
C         ATTENTION: FOR IELPRI=3, THE PREFACTORS  OF  SQRT(4*PI/3)  AND
C                    SQRT(16*PI/5), WHICH CORRESPOND TO MAGNETIC  DIPOLE
C                    AND  ELECTRIC  QUADRUPOLE   MOMENTS,   RESPECTIVELY
C                    (SEE RING&SCHUCK B.31 AND B.32), ARE USED  FOR  THE
C                    CORRESPONDING MOMENTS OF ALL  MULTIPOLARITIES.  THE
C                    ALIGNED (M=I) MOMENTS ARE CALCULATED AS IN  CPC 180
C                   (2009) 2361 EQ. (52).
C         ATTENTION: FOR THE CALCULATION OF SPECTROSCOPIC MOMENTS, I.E.,
C                    FOR IELPRI=3, STARTING WITH  VERSION  (2.95F),  THE
C                    PREFACTORS    OF    SQRT(4*PI/(2*LAMBDA+1))     AND
C                    SQRT(16*PI/(2*LAMBDA+1)), WHICH  CORRESPOND  TO THE
C                    MAGNETIC  AND   ELECTRIC   MOMENTS,   RESPECTIVELY,
C                    (SEE  C. SCHWARTZ  PR97-380),  ARE  USED  FOR   ALL
C                    MULTIPOLARITIES. THIS WAS NOT  REALLY  A  BUG,  BUT
C                    RATHER A CHANGE OF STANDARD, ORIGINALLY IMPLEMENTED
C                    IN VERSION (2.80E). THIS CHANGE AFFECTS ALL MOMENTS
C                    APART  FROM  THE  MAGNETIC  DIPOLE   AND   ELECTRIC
C                    QUADRUPOLE MOMENTS. NOTE THAT  THIS  CHANGE  ALIGNS
C                    THE PRINTED  ELECTRIC  OCTUPOLE  MOMENTS  WITH  THE
C                    STANDARD USED IN SOME PAPERS, e.g., Nature 497, 199
C                    (2013), SEE ALSO REFERENCE [10] IN Phys. Rev. Lett.
C                    121 (2018).
C=======================================================================
C
                       NAMWRK=NAMMUL
      IF (IELPRI.EQ.1) NAMWRK=NAMELE
      IF (IELPRI.EQ.2) NAMWRK=NAMRBE
      IF (IELPRI.EQ.3) NAMWRK=NAMSPE
C
      I_HEAD=0
      I_HALF=0
C
      IVERRM=1
      I_WRRM=0
C
      DO LAMBDA=1,NMURED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
            IF (IPRALL.EQ.1.OR.
     *         (IDIAGO.EQ.1.AND.(IELPRI.GE.2.OR.IAXIAL.EQ.1))) THEN
C
                IMNLEF=MAX(JPROMI,IPRRIG-2*LAMBDA)
                IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
            ELSE
                IMNLEF=IPRRIG
                IMXLEF=IPRRIG
C
            END IF
C
            DO KRIG=1,NUMPRO(IPRRIG,1)
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C
                  IF (IPRALL.EQ.1.OR.
     *               (IDIAGO.EQ.1.AND.(IELPRI.GE.2.OR.IAXIAL.EQ.1)))THEN
C
                      KMNLEF=1
                      KMXLEF=NUMLEF(IPRLEF,1)
                  ELSE
                      KMNLEF=KRIG
                      KMXLEF=KRIG
C
                  END IF
C
                  DO KLEF=KMNLEF,KMXLEF
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (I_WRRM.EQ.0.AND.IWRIRM.EQ.1) THEN
C
                             WRITE (NFIRED,'(I3)') IVERRM
C
                             WRITE (NFIRED,'(5I6/6I6/5I6/2I6/4E14.6)')
     *
     *                              JPROMI,JPROMA,KPROJE,IAXIAL,IHALF_,
     *                       ISCHIF,NMURED,NMARED,NASRED,NSIRED,NSIMIN,
     *                              IDIAGO,IRMPRI,IELPRI,ISLPRI,ISUPRI,
     *                       MINDIK,NUISOM,QMUCUT,QMACUT,QASCUT,QSICUT
C
                             I_WRRM=1
C
                         END IF
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,'(A8,2X,A45)')
     *                       'ELECTRIC',NAMWRK
C
                         IF (IELPRI.LE.1) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||Q||>  '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||Q||>  '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' REDUCED MATRIX ELEMENTS  OF '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                        1H*,1X,'' THE TOTAL NUMBER OF MAT.ELEMS'',
     *                               '' CALCULATED IS ='',I7,
     *                               '' AND NDREDU ='',I8,   2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QMUCUT,NUREEU,NDREDU,
     *                        HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         IF (IELPRI.EQ.2) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR  BE(IR->IL) '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR  BE(IR->IL) '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' REDUCED ELECTRIC TRANSITION '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                       1H*,1X,'' THE TOTAL NUMBER OF MAT.ELEMS'',
     *                              '' CALCULATED IS ='',I7,
     *                              '' AND NDREDU ='',I8,   2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QMUCUT,NUREEU,NDREDU,
     *                       HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         IF (IELPRI.EQ.3) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR   <IL|Q|IR> '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR   <IL|Q|IR> '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' SPECTROSCOPIC ELECTRIC MNTS '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                       1H*,1X,'' THE TOTAL NUMBER OF MAT.ELEMS'',
     *                              '' CALCULATED IS ='',I7,
     *                              '' AND NDREDU ='',I8,   2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QMUCUT,NUREEU,NDREDU,
     *                       HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IND_IN(IPRLEF,KLEF),LAMBDA,
     *                             IND_IN(IPRRIG,KRIG))
C
                     IF (IELPRI.LE.1) REEFIX= REAL(REEQ_P(NUREEU))
                                      REEFIY=AIMAG(REEQ_P(NUREEU))
                     IF (IELPRI.EQ.2) REEFIX=  ABS(REEQ_P(NUREEU))**2
     *                                                       /(IPRRIG+1)
                     IF (IELPRI.EQ.3) REEFIX= REAL(REEQ_P(NUREEU))
     *                               *CGCOEF(IPRRIG,IPRRIG,2*LAMBDA,0,
     *                                       IPRLEF,IPRLEF)
     *                          *SQRT(16.0D0*PI/(2*LAMBDA+1)/(IPRLEF+1))
C
                     IF (IELPRI.EQ.1) REEFIX=REEFIX/QUNITS(LAMBDA,0)
                     IF (IELPRI.EQ.1) REEFIY=REEFIY/QUNITS(LAMBDA,0)
                     IF (IELPRI.EQ.2) REEFIX=REEFIX/QUNITS(LAMBDA,0)**2
                     IF (IELPRI.EQ.3) REEFIX=REEFIX/QUNITS(LAMBDA,0)
C
C=======================================================================
C          ON 28/01/2021, THE CONDITION BELOW RELATED TO IELPRI.EQ.3 HAS
C          BEEN REMOVED, BECAUSE THE CG COEFFICIENT ANYHOW PUTS TO  ZERO
C          THE  HYPOTHETICAL  SPECTROSCOPIC  MATRIX  ELEMENTS  THAT  ARE
C          NON-DIAGONAL IN THE TOTAL ANGULAR MOMENTUM.
C=======================================================================
C
                     IF (IRMPRI.GT.0.AND.
C    *                   (IELPRI.NE.3.OR.IPRRIG.EQ.IPRLEF).AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QMUCUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(IELPRI.LE.1.AND.
     *                      ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KLEF,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KRIG,
     *                      REEFIC,IMAFLA
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,2E14.6)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KLEF,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KRIG,
     *                      REEFIX,REEFIY
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NMURED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1.AND.IWRIRM.EQ.1)
     *           WRITE (NFIRED,'(A8,2X,A3)')
     *          'ELECTRIC','END'
C
         END IF
C
      END DO
C
C=======================================================================
C         PRINTING:
C         REDUCED MATRIX ELEMENTS OF MAGNETIC OPERATORS (FOR IELPRI=0,1)
C         REDUCED TRANSITION RATES FOR IR->IL MAGNETIC TRNSTS (IELPRI=2)
C         ALIGNED (SPECTROSCOPIC) MATRIX ELS OF MAGNETIC OPRS (IELPRI=3)
C=======================================================================
C            ATTENTION: IN VERSIONS FROM 2.77E TO  2.83T,  THE  PRINTING
C                       BELOW WAS  PERFORMED  USING  PARAMETER  "QMUCUT"
C                       INSTEAD OF "QMACUT". THIS BUG WAS  CORRECTED  ON
C                       03/12/2017 IN VERSION (2.83U).
C=======================================================================
C
                       NAMWRK=NAMMAG
      IF (IELPRI.EQ.2) NAMWRK=NAMRBM
      IF (IELPRI.EQ.3) NAMWRK=NAMSPM
C
C=======================================================================
C         LOOP OVER RADIAL MOMENTS NOT INDENTED
C=======================================================================
C
      DO NUMORD=0,NMAORD
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=1,NMARED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
            IF (IPRALL.EQ.1.OR.
     *         (IDIAGO.EQ.1.AND.(IELPRI.GE.2.OR.IAXIAL.EQ.1))) THEN
C
                IMNLEF=MAX(JPROMI,IPRRIG-2*LAMBDA)
                IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
            ELSE
                IMNLEF=IPRRIG
                IMXLEF=IPRRIG
C
            END IF
C
            DO KRIG=1,NUMPRO(IPRRIG,1)
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C
                  IF (IPRALL.EQ.1.OR.
     *               (IDIAGO.EQ.1.AND.IELPRI.GE.2)) THEN
C
                      KMNLEF=1
                      KMXLEF=NUMLEF(IPRLEF,1)
                  ELSE
                      KMNLEF=KRIG
                      KMXLEF=KRIG
C
                  END IF
C
                  DO KLEF=KMNLEF,KMXLEF
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,'(A8,2X,A45)')
     *                       'MAGNETIC',NAMWRK
C
                         IF (IELPRI.LE.1) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||M||>  '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||M||>  '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' REDUCED MATRIX ELEMENTS  OF '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QMACUT,
     *                        HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         IF (IELPRI.EQ.2) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR  BM(IR->IL) '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR  BM(IR->IL) '
C
                             END IF
C
                             IF (NUMORD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' REDUCED MAGNETIC TRANSITION '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QMACUT,
     *                       HAFLIN(1),HAFLIN(1)
C
                             ELSE
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' RADIAL MOMENTS ORDER N='',I1,
     *                                            '' OF '',A45,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          2*NUMORD,NAMMAR,HAFLIN(1),HAFLIN(1)
C
                             END IF
C
                         END IF
C
                         IF (IELPRI.EQ.3) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR   <IL|M|IR> '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR   <IL|M|IR> '
C
                             END IF
C
                             IF (NUMORD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' SPECTROSCOPIC MAGNETIC MNTS '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QMACUT,
     *                       HAFLIN(1),HAFLIN(1)
C
                             ELSE
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' RADIAL MOMENTS ORDER N='',I1,
     *                                            '' OF '',A45,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          2*NUMORD,NAMMAR,HAFLIN(1),HAFLIN(1)
C
                             END IF
C
                         END IF
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IND_IN(IPRLEF,KLEF),LAMBDA,
     *                             IND_IN(IPRRIG,KRIG))
C
                     IF (IELPRI.LE.1)
     *                            REEFIX= REAL(REEM_P(NUREEU,NUMORD))
                                  REEFIY=AIMAG(REEM_P(NUREEU,NUMORD))
                     IF (IELPRI.EQ.2)
     *                            REEFIX=  ABS(REEM_P(NUREEU,NUMORD))**2
     *                                                       /(IPRRIG+1)
                     IF (IELPRI.EQ.3)
     *                            REEFIX= REAL(REEM_P(NUREEU,NUMORD))
     *                           *CGCOEF(IPRRIG,IPRRIG,2*LAMBDA,0,
     *                                   IPRLEF,IPRLEF)
     *                           *SQRT(4.0D0*PI/(2*LAMBDA+1)/(IPRLEF+1))
C
                     IF (IELPRI.EQ.1) REEFIX=REEFIX/AUNITS(LAMBDA,0)
                     IF (IELPRI.EQ.1) REEFIY=REEFIY/AUNITS(LAMBDA,0)
                     IF (IELPRI.EQ.2) REEFIX=REEFIX/AUNITS(LAMBDA,0)**2
                     IF (IELPRI.EQ.3) REEFIX=REEFIX/AUNITS(LAMBDA,0)
C
C=======================================================================
C          ON 28/01/2021, THE CONDITION BELOW RELATED TO IELPRI.EQ.3 HAS
C          BEEN REMOVED, BECAUSE THE CG COEFFICIENT ANYHOW PUTS TO  ZERO
C          THE  HYPOTHETICAL  SPECTROSCOPIC  MATRIX  ELEMENTS  THAT  ARE
C          NON-DIAGONAL IN THE TOTAL ANGULAR MOMENTUM.
C=======================================================================
C
                     IF (IRMPRI.GT.0.AND.
C    *                   (IELPRI.NE.3.OR.IPRRIG.EQ.IPRLEF).AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QMACUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(IELPRI.LE.1.AND.
     *                      ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         IF (NMAORD.EQ.0) THEN
C
                             WRITE(HAFLIN(I_HALF),
     *                           '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                          IPRLEF/IEVEN_,CHALF_,
     *                          KLEF,LAMBDA,
     *                          IPRRIG/IEVEN_,CHALF_,
     *                          KRIG,
     *                          REEFIC,IMAFLA
C
                         ELSE
C
                             WRITE(HAFLIN(I_HALF),
     *                    '(1HM,I1,I2,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                 2*NUMORD,IPRLEF/IEVEN_,CHALF_,
     *                          KLEF,LAMBDA,
     *                          IPRRIG/IEVEN_,CHALF_,
     *                          KRIG,
     *                          REEFIC,IMAFLA
C
                         END IF
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,2E14.6)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KLEF,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KRIG,
     *                      REEFIX,REEFIY
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NMARED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1.AND.IWRIRM.EQ.1)
     *           WRITE (NFIRED,'(A8,2X,A3)')
     *          'MAGNETIC','END'
C
         END IF
C
      END DO
C
      END DO
C
C=======================================================================
C         PRINTING:
C         REDUCED MATRIX ELEMENTS OF SPIN-ASY OPERATORS (FOR IELPRI=0,1)
C         REDUCED TRANSITION RATES FOR IR->IL SPIN-ASY TRNSTS (IELPRI=2)
C         ALIGNED (SPECTROSCOPIC) MATRIX ELS OF SPIN-ASY OPRS (IELPRI=3)
C=======================================================================
C
                       NAMWRK=NAMASM
      IF (IELPRI.EQ.3) NAMWRK=NAMSPA
C
C=======================================================================
C         LOOP OVER RADIAL MOMENTS NOT INDENTED
C=======================================================================
C
      DO NUMORD=0,NASORD
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=1,NASRED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
            IF (IPRALL.EQ.1.OR.
     *         (IDIAGO.EQ.1.AND.(IELPRI.GE.2.OR.IAXIAL.EQ.1))) THEN
C
                IMNLEF=MAX(JPROMI,IPRRIG-2*LAMBDA)
                IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
            ELSE
                IMNLEF=IPRRIG
                IMXLEF=IPRRIG
C
            END IF
C
            DO KRIG=1,NUMPRO(IPRRIG,1)
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C
                  IF (IPRALL.EQ.1.OR.
     *               (IDIAGO.EQ.1.AND.IELPRI.GE.2)) THEN
C
                      KMNLEF=1
                      KMXLEF=NUMLEF(IPRLEF,1)
                  ELSE
                      KMNLEF=KRIG
                      KMXLEF=KRIG
C
                  END IF
C
                  DO KLEF=KMNLEF,KMXLEF
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,'(A8,2X,A45)')
     *                       'SPIN-ASY',NAMWRK
C
                         IF (IELPRI.LE.1) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||A||>  '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||A||>  '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' REDUCED MATRIX ELEMENTS  OF '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QASCUT,
     *                        HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         IF (IELPRI.EQ.3) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR   <IL|A|IR> '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR   <IL|A|IR> '
C
                             END IF
C
                             IF (NUMORD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' SPECTROSCOPIC SPIN-ASY MNTS '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QASCUT,
     *                       HAFLIN(1),HAFLIN(1)
C
                             ELSE
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' RADIAL MOMENTS ORDER N='',I1,
     *                                            '' OF '',A45,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          2*NUMORD,NAMASR,HAFLIN(1),HAFLIN(1)
C
                             END IF
C
                         END IF
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IND_IN(IPRLEF,KLEF),LAMBDA,
     *                             IND_IN(IPRRIG,KRIG))
C
                     IF (IELPRI.EQ.1) THEN
C
                         REEFIX= REAL(REEA_T(NUREEU,NUMORD))
                         REEFIY=AIMAG(REEA_T(NUREEU,NUMORD))
C
                         REEFIX=REEFIX/BUNITS(LAMBDA,0)
                         REEFIY=REEFIY/BUNITS(LAMBDA,0)
C
                     ELSE IF (IELPRI.EQ.3) THEN
C
C=======================================================================
C                        THE FACTOR OF SQRT(16*PI/(2*LAMBDA+3)) FOR  THE
C                        DIPOLE SPIN-ASYMMETRY MOMENT (LAMBDA=1) REMOVES
C                        THE  PREFACTOR  OF  THE  UNDERLYING  QUADRUPOLE
C                        (LAMBDA=2) SPHERICAL HARMONICS AND  TURNS  THAT
C                        QUADRUPOLE MOMENT INTO  ITS  STANDARD  FORM  OF
C                        (2*Z^2-X^2-Y^2).  FOR  HIGHER   MULTIPOLARITIES
C                        LAMBDA SUCH A NORMALIZATION IS QUITE ARBITRARY.
C=======================================================================
                         REEFIX= REAL(REEA_T(NUREEU,NUMORD))
     *                  *CGCOEF(IPRRIG,IPRRIG,2*LAMBDA,0,IPRLEF,IPRLEF)
     *                  *SQRT(16.0D0*PI/(2*LAMBDA+3)/(IPRLEF+1))
C
                         REEFIX=REEFIX/BUNITS(LAMBDA,0)
C
                     ELSE
                         STOP 'INCORRECT IELPRI FOR SPIN-ASY IN REDPRO'
                     END IF
C
                     IF (IRMPRI.GT.0.AND.
     *                   (IELPRI.NE.3.OR.IPRRIG.EQ.IPRLEF).AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QASCUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(IELPRI.LE.1.AND.
     *                      ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         IF (NASORD.EQ.0) THEN
C
                             WRITE(HAFLIN(I_HALF),
     *                           '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                          IPRLEF/IEVEN_,CHALF_,
     *                          KLEF,LAMBDA,
     *                          IPRRIG/IEVEN_,CHALF_,
     *                          KRIG,
     *                          REEFIC,IMAFLA
C
                         ELSE
C
                             WRITE(HAFLIN(I_HALF),
     *                    '(1HA,I1,I2,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                 2*NUMORD,IPRLEF/IEVEN_,CHALF_,
     *                          KLEF,LAMBDA,
     *                          IPRRIG/IEVEN_,CHALF_,
     *                          KRIG,
     *                          REEFIC,IMAFLA
C
                         END IF
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,2E14.6)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KLEF,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KRIG,
     *                      REEFIX,REEFIY
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NASRED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1.AND.IWRIRM.EQ.1)
     *           WRITE (NFIRED,'(A8,2X,A3)')
     *          'SPIN-ASY','END'
C
         END IF
C
      END DO
C
      END DO
C
C=======================================================================
C         PRINTING THE REDUCED MATRIX ELEMENTS OF SURFACE OPERATORS
C=======================================================================
C            ATTENTION: IN VERSIONS FROM 2.77E TO  2.83T,  THE  PRINTING
C                       BELOW WAS  PERFORMED  USING  PARAMETER  "QMUCUT"
C                       INSTEAD OF "QSICUT". THIS BUG WAS  CORRECTED  ON
C                       03/12/2017 IN VERSION (2.83U).
C=======================================================================
C
                       NAMWRK=NAMSUR
      IF (ISCHIF.EQ.1) STOP ' ISCHIF=1 NOT ALLOWED IN REDPRO'
C
C=======================================================================
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=NSIMIN,NSIRED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
            IF (IPRALL.EQ.1.OR.
     *         (IDIAGO.EQ.1.AND.(IELPRI.GE.2.OR.IAXIAL.EQ.1))) THEN
C
                IMNLEF=MAX(JPROMI,IPRRIG-2*LAMBDA)
                IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
            ELSE
                IMNLEF=IPRRIG
                IMXLEF=IPRRIG
C
            END IF
C
            DO KRIG=1,NUMPRO(IPRRIG,1)
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C
                  IF (IPRALL.EQ.1.OR.
     *               (IDIAGO.EQ.1.AND.(IELPRI.GE.2.OR.IAXIAL.EQ.1)))THEN
C
                      KMNLEF=1
                      KMXLEF=NUMLEF(IPRLEF,1)
                  ELSE
                      KMNLEF=KRIG
                      KMXLEF=KRIG
C
                  END IF
C
                  DO KLEF=KMNLEF,KMXLEF
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,'(A8,2X,A45)')
     *                       'SURFACE ',NAMWRK
C
                         IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||S||>  '
C
                         ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||S||>  '
C
                         END IF
C
                         WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' REDUCED MATRIX ELEMENTS  OF '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QSICUT,
     *                        HAFLIN(1),HAFLIN(1)
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IND_IN(IPRLEF,KLEF),LAMBDA,
     *                             IND_IN(IPRRIG,KRIG))
C
                     REEFIX= REAL(REES_P(NUREEU))
                     REEFIY=AIMAG(REES_P(NUREEU))
C
                     IF (IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QSICUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KLEF,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KRIG,
     *                      REEFIC,IMAFLA
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,2E14.6)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KLEF,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KRIG,
     *                      REEFIX,REEFIY
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NSIRED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1.AND.IWRIRM.EQ.1)
     *           WRITE (NFIRED,'(A8,2X,A3)')
     *          'SURFACE ','END'
C
         END IF
C
      END DO
C
C=======================================================================
C         PRINTING THE REDUCED MATRIX ELEMENTS OF THE SCHIFF  OPERATORS.
C         FOR LAMBDA=0, PRINTING OF THE SCHIFF MOMENTS IS BELOW MANUALLY
C         SWITCHED OFF. SINCE THE SCHIFF OPERATOR  INVOLVES  AN  AVERAGE
C         VALUE OF  R^2,  ONLY  ITS  DIAGONAL  MATRIX  ELEMENTS  CAN  BE
C         CALCULATED.
C=======================================================================
C            ATTENTION: IN VERSIONS FROM 2.77E TO  2.83T,  THE  PRINTING
C                       BELOW WAS  PERFORMED  USING  PARAMETER  "QMUCUT"
C                       INSTEAD OF "QSICUT". THIS BUG WAS  CORRECTED  ON
C                       03/12/2017 IN VERSION (2.83U).
C=======================================================================
C
      IF (ISCHIF.NE.2) GO TO 111
C
      NAMWRK=NAMSCH
C
C=======================================================================
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=MAX(NSIMIN,1),NSIRED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
            IMNLEF=IPRRIG
            IMXLEF=IPRRIG
C
            DO KRIG=1,NUMPRO(IPRRIG,1)
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C
                  KMNLEF=KRIG
                  KMXLEF=KRIG
C
                  DO KLEF=KMNLEF,KMXLEF
C
C                    WRITE(NFIPRI,
C    *                     '(I4,A2,I4,2X,I3,I4,A2,I4,4I6)')
C    *                  IPRLEF/IEVEN_,CHALF_,
C    *                  KLEF,LAMBDA,
C    *                  IPRRIG/IEVEN_,CHALF_,
C    *                  KRIG,
C    *                  JPROMI,JPROMA,IMNLEF,IMXLEF
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||S||>  '
C
                         ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||S||>  '
C
                         END IF
C
                         WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' DIAGONAL R.M.ELMS OF PROTON '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QSICUT,
     *                        HAFLIN(1),HAFLIN(1)
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IND_IN(IPRLEF,KLEF),LAMBDA,
     *                             IND_IN(IPRRIG,KRIG))
                     NUREE0=INDREE(IND_IN(IPRLEF,KLEF),     0,
     *                             IND_IN(IPRRIG,KRIG))
C
                     REEFIX= (REAL(REES_P(NUREEU))-5.0D0/3.0D0
     *                                            *REAL(REES_P(NUREE0))
     *                                            /REAL(REEQ_P(NUREE0))
     *                                            *REAL(REEQ_P(NUREEU)))
     *                                            /10.0D0
                     REEFIY=(AIMAG(REES_P(NUREEU))-5.0D0/3.0D0
     *                                            *REAL(REES_P(NUREE0))
     *                                            /REAL(REEQ_P(NUREE0))
     *                                           *AIMAG(REEQ_P(NUREEU)))
     *                                            /10.0D0
C
                     IF (IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QSICUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      KLEF,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      KRIG,
     *                      REEFIC,IMAFLA
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NSIRED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
         END IF
C
      END DO
C
C=======================================================================
C
 111  CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('REDPRO',0)
C
      RETURN
C
      END
C
C=======================================================================
C
      SUBROUTINE REDMUR(JPROMI,JPROMA,KPROJE,IAXIAL,IHALF_,
     *                  ISCHIF,NMURED,NMARED,NASRED,NSIRED,NSIMIN,
     *                         IDIMUR,IRMPRI,IELPRI,ISLPRI,ISUPRI,
     *                                IWRIRM,NFIRED,NMAORD,NASORD,
     *                  MINDIK,NUISOM,QMUCUT,QMACUT,QASCUT,QSICUT)
C
C=======================================================================
C       >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C                        !!!  W A R N I N G !!!
C       THIS SUBROUTINE DOES NOT WORK FOR ISOSPIN PROJECTION YET
C             ALL ISOSPIN INDICES ARE TEMPORARLY SET TO 1
C       >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C=======================================================================
      USE REDMOM
      USE REEMOM
      USE HAMMIX
      USE MURMIX
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHALF_*2,IMAFLA*1
      CHARACTER
     *          NAMMUL*45,NAMELE*45,NAMRBE*45,NAMSPE*45,NAMRBM*45,
     *          NAMSUR*45,NAMSCH*45,NAMMAG*45,NAMMAR*45,NAMSPM*45
      CHARACTER
     *          NAMWRK*45
      CHARACTER
     *          HAFLIN*38
      CHARACTER
     *          REEFIC*11
C
C=======================================================================
      COMPLEX
     *          C_ZERO,WALMUR,WAVMUR
C
      DIMENSION
     *          HAFLIN(2)
      DIMENSION
     *          WALMUR(0:NDPROI,0:NDISOM,NDCONF,NDCONF),
     *          NULMUR(0:NDPROI,0:NDISOM)
C=======================================================================
      COMMON
     *       /ALLMUR/ NUMMUR(0:NDPROI,0:NDISOM)
      COMMON
     *       /COLMUR/ WAVMUR(0:NDPROI,0:NDISOM,NDCONF,NDCONF),
     *                ENEMUR(0:NDPROI,0:NDISOM,NDCONF),
     *                OVEMUR(0:NDPROI,0:NDISOM,NDCONF)
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /IPRIAM/ ILIMAM,IALLAM
      COMMON
     *       /ALLPRI/ IPRALL
C
      DATA
     *       NAMMUL /'MULTIPOLE MOMENTS [UNITS:  (10 FERMI)^LAMBDA]'/,
     *       NAMELE /'TRUE ELECTRIC MOMENTS [UNITS:   FERMI^LAMBDA]'/,
     *       NAMRBE /'RATES BE(IR--->IL) [UNITS:  FERMI^(2*LAMBDA)]'/,
     *       NAMSPE /'CORR ELECTRIC OPERATORS [UNITS: FERMI^LAMBDA]'/,
     *       NAMRBM /'RATES BM(IR--->IL)[UNITS: FERMI^(2*LAMBDA-2)]'/,
     *       NAMSUR /'SURFACE MOMENTS, UNITS: (10 FERMI)^(LAMBDA+2)'/,
     *       NAMSCH /'SCHIFF MOMENTS,  UNITS: (10 FERMI)^(LAMBDA+2)'/,
     *       NAMMAG /'P+N MAGNETIC MOMENTS [MGNTN*FERMI^(LAMBDA-1)]'/,
     *       NAMMAR /'P+N MAGNETIC MOMENTS [MTN*FERMI^(N+LAMBDA-1)]'/,
     *       NAMSPM /'P+N CORR MAG OPERTRS [MGNTN*FERMI^(LAMBDA-1)]'/
C
C=======================================================================
C
      CALL CPUTIM('REDMUR',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (ALLOCATED(REEQ_P)) DEALLOCATE(REEQ_P)
      ALLOCATE (REEQ_P(0:NDREDU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('REEQ_P','REDMUR')
C
      IF (ALLOCATED(REEM_P)) DEALLOCATE(REEM_P)
      ALLOCATE (REEM_P(0:NDREDU,0:NMAORD),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('REEM_P','REDMUR')
C
      IF (ALLOCATED(REEA_T).AND.NASORD.GE.0) DEALLOCATE(REEA_T)
      ALLOCATE (REEA_T(0:NDREDU,0:NASORD),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('REEA_T','REDMUR')
C
      IF (ALLOCATED(REES_P)) DEALLOCATE(REES_P)
      ALLOCATE (REES_P(0:NDREDU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('REES_P','REDMUR')
C
      IF (ALLOCATED(INDREE)) DEALLOCATE (INDREE)
      ALLOCATE (INDREE(0:NDPROI,0:NDMULR,0:NDPROI),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('INDREE','REDMUR')
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE REDUCED MATRIX ELEMENTS BETWEEN
C         THE K-MIXED STATES.
C         IT IS IMPLEMENTED ONLY IN THE CASE  OF  SOLE  ANGULAR-MOMENTUM
C         PROJECTION.
C=======================================================================
C         REDUCED MATRIX ELEMENTS BETWEEN K-MIXED STATES  PROJECTED FROM
C         TWO DIFFERENT REFERENCE STATES ARE  PHASE  DEPENDENT  AND THUS
C         WILL NEVER BE PRINTED
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
      IF (NUISOM.NE.1)STOP 'REDMUR NOT READY FOR ISOSPIN PROJECTION YET'
C
C=======================================================================
C
                       CHALF_='  '
      IF (IHALF_.EQ.1) CHALF_='/2'
C
      IEVEN_=2/(IHALF_+1)
C
C=======================================================================
C
      IF (IDIMUR.NE.1) THEN
C
          STOP 'IDIMUR.NE.1 NOT READY YET IN REDMUR'
C
C=======================================================================
C         READING THE CONFIGURATION-MIXING COEFFICIENTS.
C=======================================================================
C
      ELSE
C
C=======================================================================
C         THE CONFIGURATION-MIXING COEFFICIENTS OF THE RIGHT  STATE  ARE
C         ASSUMED TO BE CALCULATED PREVIOUSLY IN DIAMUR.
C=======================================================================
C
          WALMUR=WAVMUR
          NULMUR=NUMMUR
C
      END IF
C
C=======================================================================
C
      INDREE(:,:,:)=0
      NUREEU=0
C
      REEQ_P(NUREEU)  =C_ZERO
      REEM_P(NUREEU,:)=C_ZERO
      REES_P(NUREEU)  =C_ZERO
      IF (NASORD.GE.0)
     *REEA_T(NUREEU,:)=C_ZERO
C
      DO IPRRIG=JPROMI,JPROMA,2
C
C        ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C        DO IKET=1,NUMMUR(IPRRIG,1)
         DO IKET=1,MIN(1,NUMMUR(IPRRIG,1))
C
            DO LAMBDA=0,NMURED
C
               IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
               DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C
C                 ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C                 DO IBRA=1,NULMUR(IPRLEF,1)
                  DO IBRA=1,MIN(1,NULMUR(IPRLEF,1))
C
                     IF (ILIMAM.NE.1.OR.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
C=======================================================================
C                    CHECKING IF THE LIST OF THE REDUCED MATRIX ELEMENTS
C                    IS NOT TOO LONG
C=======================================================================
C
                         IF (NUREEU.LT.NDREDU) THEN
C
                             NUREEU=NUREEU+1
                         ELSE
                             STOP ' INCREASE NDREDU IN REDMUR'
C
                         END IF
C
C=======================================================================
C
                         REEQ_P(NUREEU)  =C_ZERO
                         REEM_P(NUREEU,:)=C_ZERO
                         REES_P(NUREEU)  =C_ZERO
                         IF (NASORD.GE.0)
     *                   REEA_T(NUREEU,:)=C_ZERO
C
                         INDREE(IPRLEF,LAMBDA,IPRRIG)=NUREEU
C
                         DO INDKET=1,MIXNUM
                            DO INDBRA=1,MIXNUM
C
                               INRWAV=MICONF(INDKET)
                               INLWAV=MICONF(INDBRA)
C
                               LMURMI=LMATMI(IPRLEF,LAMBDA,IPRRIG,
     *                                       INLWAV,INRWAV,1,1)
C
                               IF (LMURMI.GT.0) THEN
C
                                   REEQ_P(NUREEU)=REEQ_P(NUREEU)+
     *                               CONJG(WALMUR(IPRLEF,1,INDBRA,IBRA))
     *                                    *QMRMIX(LMURMI)
     *                                    *WAVMUR(IPRRIG,1,INDKET,IKET)
C
                                   IF (LAMBDA.GT.0.AND.LAMBDA.LE.NMARED)
     *
     *                             REEM_P(NUREEU,:)=REEM_P(NUREEU,:)+
     *                               CONJG(WALMUR(IPRLEF,1,INDBRA,IBRA))
     *                                    *AMRMIX(LMURMI)
     *                                    *WAVMUR(IPRRIG,1,INDKET,IKET)
C
                                   IF (LAMBDA.GT.0.AND.
     *                                 LAMBDA.LE.NASRED.AND.NASORD.GE.0)
     *
     *                             REEA_T(NUREEU,:)=REEA_T(NUREEU,:)+
     *                               CONJG(WALMUR(IPRLEF,1,INDBRA,IBRA))
     *                                    *WMRMIX(LMURMI)
     *                                    *WAVMUR(IPRRIG,1,INDKET,IKET)
C
                                   IF(LAMBDA.GE.NSIMIN.AND.
     *                                LAMBDA.LE.NSIRED)
     *
     *                             REES_P(NUREEU)=REES_P(NUREEU)+
     *                               CONJG(WALMUR(IPRLEF,1,INDBRA,IBRA))
     *                                    *SMRMIX(LMURMI)
     *                                    *WAVMUR(IPRRIG,1,INDKET,IKET)
C
C320j WRITE (*,
C320j*'(''IPRRIG,IKET,LAMBDA,IPRLEF,IBRA,NUREEU,INDBRA,INDKET,'',
C320j*  ''INLWAV,INRWAV,LMURMI'',11I4,/,
C320j*    7X,4(''('',2e10.3,'')''),/,
C320j*    7X,4(''('',2e10.3,'')''))')
C320j*    IPRRIG,IKET,LAMBDA,IPRLEF,IBRA,NUREEU,INDBRA,INDKET,
C320j*    INLWAV,INRWAV,LMURMI,
C320j*  QMRMIX(LMURMI),AMRMIX(LMURMI)  ,WMRMIX(LMURMI)  ,SMRMIX(LMURMI),
C320j*  REEQ_P(NUREEU),REEM_P(NUREEU,0),REEA_T(NUREEU,0),REES_P(NUREEU)
C
                               END IF
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         PRINTING (SEE "COMMENT 1 IN REDPRO"):
C=======================================================================
C
                       NAMWRK=NAMMUL
      IF (IELPRI.EQ.1) NAMWRK=NAMELE
      IF (IELPRI.EQ.2) NAMWRK=NAMRBE
      IF (IELPRI.EQ.3) NAMWRK=NAMSPE
C
      I_HEAD=0
      I_HALF=0
C
      IVERRM=1
      I_WRRM=0
C
      DO LAMBDA=1,NMURED
C320j WRITE (*,'(''LAMBDA,NMURED Q='',2I3)') LAMBDA,NMURED
C
         DO IPRRIG=JPROMI,JPROMA,2
C320j WRITE (*,'(''IPRRIG,JPROMI,JPROMA Q='',3I3)') IPRRIG,JPROMI,JPROMA
C
            IMNLEF=MAX(JPROMI,IPRRIG-2*LAMBDA)
            IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
C           ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C           DO IKET=1,NUMMUR(IPRRIG,1)
            DO IKET=1,MIN(1,NUMMUR(IPRRIG,1))
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C320j WRITE (*,'(''IPRLEF,IMNLEF,IMXLEF Q='',3I3)') IPRLEF,IMNLEF,IMXLEF
C
C                 ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C                 DO IBRA=NULMUR(IPRLEF,1
                  DO IBRA=1,MIN(1,NULMUR(IPRLEF,1))
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (I_WRRM.EQ.0.AND.IWRIRM.EQ.1) THEN
C
                             WRITE (NFIRED,'(I3)') IVERRM
C
                             WRITE (NFIRED,'(5I6/6I6/5I6/2I6/4E14.6)')
     *
     *                              JPROMI,JPROMA,KPROJE,IAXIAL,IHALF_,
     *                       ISCHIF,NMURED,NMARED,NASRED,NSIRED,NSIMIN,
     *                              IDIMUR,IRMPRI,IELPRI,ISLPRI,ISUPRI,
     *                       MINDIK,NUISOM,QMUCUT,QMACUT,QASCUT,QSICUT
C
                             I_WRRM=1
C
                         END IF
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,'(A8,2X,A45)')
     *                       'ELECTRIC',NAMWRK
C
                         IF (IELPRI.LE.1) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||Q||>  '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||Q||>  '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' REDUCED MATRIX ELEMENTS  OF '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                        1H*,1X,'' THE TOTAL NUMBER OF MAT.ELEMS'',
     *                               '' CALCULATED IS ='',I7,
     *                               '' AND NDREDU ='',I8,   2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QMUCUT,NUREEU,NDREDU,
     *                        HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         IF (IELPRI.EQ.2) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR  BE(IR->IL) '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR  BE(IR->IL) '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' REDUCED ELECTRIC TRANSITION '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                       1H*,1X,'' THE TOTAL NUMBER OF MAT.ELEMS'',
     *                              '' CALCULATED IS ='',I7,
     *                              '' AND NDREDU ='',I8,   2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QMUCUT,NUREEU,NDREDU,
     *                       HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         IF (IELPRI.EQ.3) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR   <IL|Q|IR> '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR   <IL|Q|IR> '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' SPECTROSCOPIC ELECTRIC MNTS '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                       1H*,1X,'' THE TOTAL NUMBER OF MAT.ELEMS'',
     *                              '' CALCULATED IS ='',I7,
     *                              '' AND NDREDU ='',I8,   2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QMUCUT,NUREEU,NDREDU,
     *                       HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IPRLEF,LAMBDA,IPRRIG)
C320j WRITE (*,'(''NUREEU,IPRLEF,IMNLEF,IMXLEF Q='',4I3)')
C320j*             NUREEU,IPRLEF,IMNLEF,IMXLEF
C320j WRITE (*,
C320j*'(''NUREEU,IPRLEF,LAMBDA,IPRRIG'',4I4,/,
C320j*    7X,4(''('',2e10.3,'')''))')
C320j*    NUREEU,IPRLEF,LAMBDA,IPRRIG,
C320j*  REEQ_P(NUREEU),REEM_P(NUREEU,0),REEA_T(NUREEU,0),REES_P(NUREEU)
C
                     IF (IELPRI.LE.1) REEFIX= REAL(REEQ_P(NUREEU))
                                      REEFIY=AIMAG(REEQ_P(NUREEU))
                     IF (IELPRI.EQ.2) REEFIX=  ABS(REEQ_P(NUREEU))**2
     *                                                       /(IPRRIG+1)
                     IF (IELPRI.EQ.3) REEFIX= REAL(REEQ_P(NUREEU))
     *                               *CGCOEF(IPRRIG,IPRRIG,2*LAMBDA,0,
     *                                       IPRLEF,IPRLEF)
     *                          *SQRT(16.0D0*PI/(2*LAMBDA+1)/(IPRLEF+1))
C
                     IF (IELPRI.EQ.1) REEFIX=REEFIX/QUNITS(LAMBDA,0)
                     IF (IELPRI.EQ.1) REEFIY=REEFIY/QUNITS(LAMBDA,0)
                     IF (IELPRI.EQ.2) REEFIX=REEFIX/QUNITS(LAMBDA,0)**2
                     IF (IELPRI.EQ.3) REEFIX=REEFIX/QUNITS(LAMBDA,0)
C320j WRITE (*,'(''IELPRI Q='',I3)') IELPRI
C
C=======================================================================
C          ON 28/01/2021, THE CONDITION BELOW RELATED TO IELPRI.EQ.3 HAS
C          BEEN REMOVED, BECAUSE THE CG COEFFICIENT ANYHOW PUTS TO  ZERO
C          THE  HYPOTHETICAL  SPECTROSCOPIC  MATRIX  ELEMENTS  THAT  ARE
C          NON-DIAGONAL IN THE TOTAL ANGULAR MOMENTUM.
C=======================================================================
C
                     IF (IRMPRI.GT.0.AND.
C    *                   (IELPRI.NE.3.OR.IPRRIG.EQ.IPRLEF).AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QMUCUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(IELPRI.LE.1.AND.
     *                      ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      IBRA,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      IKET,
     *                      REEFIC,IMAFLA
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,2E14.6)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      IBRA,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      IKET,
     *                      REEFIX,REEFIY
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NMURED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1.AND.IWRIRM.EQ.1)
     *           WRITE (NFIRED,'(A8,2X,A3)')
     *          'ELECTRIC','END'
C
         END IF
C
      END DO
C
C=======================================================================
C         PRINTING:
C         REDUCED MATRIX ELEMENTS OF MAGNETIC OPERATORS (FOR IELPRI=0,1)
C         REDUCED TRANSITION RATES FOR IR->IL MAGNETIC TRNSTS (IELPRI=2)
C         ALIGNED (SPECTROSCOPIC) MATRIX ELS OF MAGNETIC OPRS (IELPRI=3)
C=======================================================================
C
                       NAMWRK=NAMMAG
      IF (IELPRI.EQ.2) NAMWRK=NAMRBM
      IF (IELPRI.EQ.3) NAMWRK=NAMSPM
C
C=======================================================================
C         LOOP OVER RADIAL MOMENTS NOT INDENTED
C=======================================================================
C
      DO NUMORD=0,NMAORD
C320j WRITE (*,'(''NUMORD,NMAORD='',I3)') NUMORD,NMAORD
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=1,NMARED
C
         DO IPRRIG=JPROMI,JPROMA,2
C320j WRITE (*,'(''IPRRIG,JPROMI,JPROMA M='',3I3)') IPRRIG,JPROMI,JPROMA
C
            IMNLEF=MAX(JPROMI,IPRRIG-2*LAMBDA)
            IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
C           ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C           DO IKET=1,NUMMUR(IPRRIG,1)
            DO IKET=1,MIN(1,NUMMUR(IPRRIG,1))
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C320j WRITE (*,'(''IPRLEF,IMNLEF,IMXLEF M='',3I3)') IPRLEF,IMNLEF,IMXLEF
C
C                 ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C                 DO IBRA=NULMUR(IPRLEF,1
                  DO IBRA=1,MIN(1,NULMUR(IPRLEF,1))
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,'(A8,2X,A45)')
     *                       'MAGNETIC',NAMWRK
C
                         IF (IELPRI.LE.1) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||M||>  '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||M||>  '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' REDUCED MATRIX ELEMENTS  OF '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QMACUT,
     *                        HAFLIN(1),HAFLIN(1)
C
                         END IF
C
                         IF (IELPRI.EQ.2) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR  BM(IR->IL) '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR  BM(IR->IL) '
C
                             END IF
C
                             IF (NUMORD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' REDUCED MAGNETIC TRANSITION '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QMACUT,
     *                       HAFLIN(1),HAFLIN(1)
C
                             ELSE
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' RADIAL MOMENTS ORDER N='',I1,
     *                                            '' OF '',A45,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          2*NUMORD,NAMMAR,HAFLIN(1),HAFLIN(1)
C
                             END IF
C
                         END IF
C
                         IF (IELPRI.EQ.3) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR   <IL|M|IR> '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR   <IL|M|IR> '
C
                             END IF
C
                             IF (NUMORD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                       1H*,1X,'' SPECTROSCOPIC MAGNETIC MNTS '',
     *                                                  A45,2X,1H*,/,
     *                       1H*,1X,'' ONLY RESULTS WITH ABSOLUTE'',
     *                              '' VALUES LARGER THAN'',1PE10.3,
     *                              '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                               79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                         1H*,A38,1H*,A38,1H*,/,
     *                                         1H*,38X,1H*,38X,1H*)')
     *
     *                       NAMWRK,QMACUT,
     *                       HAFLIN(1),HAFLIN(1)
C
                             ELSE
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                          1H*,1X,'' RADIAL MOMENTS ORDER N='',I1,
     *                                            '' OF '',A45,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                  79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                            1H*,A38,1H*,A38,1H*,/,
     *                                            1H*,38X,1H*,38X,1H*)')
     *                          2*NUMORD,NAMMAR,HAFLIN(1),HAFLIN(1)
C
                             END IF
C
                         END IF
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IPRLEF,LAMBDA,IPRRIG)
C320j WRITE (*,'(''NUREEU,IPRLEF,IMNLEF,IMXLEF M='',4I3)')
C320j*             NUREEU,IPRLEF,IMNLEF,IMXLEF
C
                     IF (IELPRI.LE.1)
     *                            REEFIX= REAL(REEM_P(NUREEU,NUMORD))
                                  REEFIY=AIMAG(REEM_P(NUREEU,NUMORD))
                     IF (IELPRI.EQ.2)
     *                            REEFIX=  ABS(REEM_P(NUREEU,NUMORD))**2
     *                                                       /(IPRRIG+1)
                     IF (IELPRI.EQ.3)
     *                            REEFIX= REAL(REEM_P(NUREEU,NUMORD))
     *                           *CGCOEF(IPRRIG,IPRRIG,2*LAMBDA,0,
     *                                   IPRLEF,IPRLEF)
     *                           *SQRT(4.0D0*PI/(2*LAMBDA+1)/(IPRLEF+1))
C
                     IF (IELPRI.EQ.1) REEFIX=REEFIX/AUNITS(LAMBDA,0)
                     IF (IELPRI.EQ.1) REEFIY=REEFIY/AUNITS(LAMBDA,0)
                     IF (IELPRI.EQ.2) REEFIX=REEFIX/AUNITS(LAMBDA,0)**2
                     IF (IELPRI.EQ.3) REEFIX=REEFIX/AUNITS(LAMBDA,0)
C320j WRITE (*,'(''IELPRI M='',I3)') IELPRI
C
C=======================================================================
C          ON 28/01/2021, THE CONDITION BELOW RELATED TO IELPRI.EQ.3 HAS
C          BEEN REMOVED, BECAUSE THE CG COEFFICIENT ANYHOW PUTS TO  ZERO
C          THE  HYPOTHETICAL  SPECTROSCOPIC  MATRIX  ELEMENTS  THAT  ARE
C          NON-DIAGONAL IN THE TOTAL ANGULAR MOMENTUM.
C=======================================================================
C
                     IF (IRMPRI.GT.0.AND.
C    *                   (IELPRI.NE.3.OR.IPRRIG.EQ.IPRLEF).AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QMACUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(IELPRI.LE.1.AND.
     *                      ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         IF (NMAORD.EQ.0) THEN
C
                             WRITE(HAFLIN(I_HALF),
     *                           '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                          IPRLEF/IEVEN_,CHALF_,
     *                          IBRA,LAMBDA,
     *                          IPRRIG/IEVEN_,CHALF_,
     *                          IKET,
     *                          REEFIC,IMAFLA
C
                         ELSE
C
                             WRITE(HAFLIN(I_HALF),
     *                    '(1HM,I1,I2,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                 2*NUMORD,IPRLEF/IEVEN_,CHALF_,
     *                          IBRA,LAMBDA,
     *                          IPRRIG/IEVEN_,CHALF_,
     *                          IKET,
     *                          REEFIC,IMAFLA
C
                         END IF
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,2E14.6)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      IBRA,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      IKET,
     *                      REEFIX,REEFIY
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NMARED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1.AND.IWRIRM.EQ.1)
     *           WRITE (NFIRED,'(A8,2X,A3)')
     *          'MAGNETIC','END'
C
         END IF
C
      END DO
C
      END DO
C
C=======================================================================
C         ATTENTION: NASORD HERE NOT YET IMPLEMENTED
C=======================================================================
C
C=======================================================================
C         PRINTING THE REDUCED MATRIX ELEMENTS OF SURFACE OPERATORS
C=======================================================================
C            ATTENTION: IN VERSIONS FROM 2.77E TO  2.83T,  THE  PRINTING
C                       BELOW WAS  PERFORMED  USING  PARAMETER  "QMUCUT"
C                       INSTEAD OF "QSICUT". THIS BUG WAS  CORRECTED  ON
C                       03/12/2017 IN VERSION (2.83U).
C=======================================================================
C
                       NAMWRK=NAMSUR
      IF (ISCHIF.EQ.1) STOP ' ISCHIF=1 NOT ALLOWED IN REDMUR'
C
C=======================================================================
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=NSIMIN,NSIRED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
            IMNLEF=MAX(JPROMI,IPRRIG-2*LAMBDA)
            IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
C           ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C           DO IKET=1,NUMMUR(IPRRIG,1)
            DO IKET=1,MIN(1,NUMMUR(IPRRIG,1))
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C
C                 ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C                 DO IBRA=NULMUR(IPRLEF,1
                  DO IBRA=1,MIN(1,NULMUR(IPRLEF,1))
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,'(A8,2X,A45)')
     *                       'SURFACE ',NAMWRK
C
                         IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||Q||>  '
C
                         ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||Q||>  '
C
                         END IF
C
                         WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' REDUCED MATRIX ELEMENTS  OF '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QSICUT,
     *                        HAFLIN(1),HAFLIN(1)
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IPRLEF,LAMBDA,IPRRIG)
C
                     REEFIX= REAL(REES_P(NUREEU))
                     REEFIY=AIMAG(REES_P(NUREEU))
C
                     IF (IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QSICUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      IBRA,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      IKET,
     *                      REEFIC,IMAFLA
C
                         IF (IWRIRM.EQ.1) WRITE (NFIRED,
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,2E14.6)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      IBRA,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      IKET,
     *                      REEFIX,REEFIY
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NSIRED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1.AND.IWRIRM.EQ.1)
     *           WRITE (NFIRED,'(A8,2X,A3)')
     *          'SURFACE ','END'
C
         END IF
C
      END DO
C
C=======================================================================
C         PRINTING THE REDUCED MATRIX ELEMENTS OF THE SCHIFF  OPERATORS.
C         FOR LAMBDA=0, PRINTING OF THE SCHIFF MOMENTS IS BELOW MANUALLY
C         SWITCHED OFF. SINCE THE SCHIFF OPERATOR  INVOLVES  AN  AVERAGE
C         VALUE OF  R^2,  ONLY  ITS  DIAGONAL  MATRIX  ELEMENTS  CAN  BE
C         CALCULATED.
C=======================================================================
C            ATTENTION: IN VERSIONS FROM 2.77E TO  2.83T,  THE  PRINTING
C                       BELOW WAS  PERFORMED  USING  PARAMETER  "QMUCUT"
C                       INSTEAD OF "QSICUT". THIS BUG WAS  CORRECTED  ON
C                       03/12/2017 IN VERSION (2.83U).
C=======================================================================
C
      IF (ISCHIF.NE.2) GO TO 111
C
      NAMWRK=NAMSCH
C
C=======================================================================
C
      I_HEAD=0
      I_HALF=0
C
      DO LAMBDA=MAX(NSIMIN,1),NSIRED
C
         DO IPRRIG=JPROMI,JPROMA,2
C
            IMNLEF=IPRRIG
            IMXLEF=IPRRIG
C
C           ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C           DO IKET=1,NUMMUR(IPRRIG,1)
            DO IKET=1,MIN(1,NUMMUR(IPRRIG,1))
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C
C                 ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C                 DO IBRA=NULMUR(IPRLEF,1
                  DO IBRA=1,MIN(1,NULMUR(IPRLEF,1))
C
C                    WRITE(NFIPRI,
C    *                     '(I4,A2,I4,2X,I3,I4,A2,I4,4I6)')
C    *                  IPRLEF/IEVEN_,CHALF_,
C    *                  IBRA,LAMBDA,
C    *                  IPRRIG/IEVEN_,CHALF_,
C    *                  IKET,
C    *                  JPROMI,JPROMA,IMNLEF,IMXLEF
C
                     IF (I_HEAD.EQ.0.AND.IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR    <||S||>  '
C
                         ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR    <||S||>  '
C
                         END IF
C
                         WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,'' DIAGONAL R.M.ELMS OF PROTON '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' ONLY REAL PARTS WITH ABSOLUTE'',
     *                               '' VALUES LARGER THAN'',1PE7.0,
     *                               '' ARE PRINTED BELOW'', 2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,QSICUT,
     *                        HAFLIN(1),HAFLIN(1)
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IPRLEF,LAMBDA,IPRRIG)
                     NUREE0=INDREE(IPRLEF,     0,IPRRIG)
C
                     REEFIX= (REAL(REES_P(NUREEU))-5.0D0/3.0D0
     *                                            *REAL(REES_P(NUREE0))
     *                                            /REAL(REEQ_P(NUREE0))
     *                                            *REAL(REEQ_P(NUREEU)))
     *                                            /10.0D0
                     REEFIY=(AIMAG(REES_P(NUREEU))-5.0D0/3.0D0
     *                                            *REAL(REES_P(NUREE0))
     *                                            /REAL(REEQ_P(NUREE0))
     *                                           *AIMAG(REEQ_P(NUREEU)))
     *                                            /10.0D0
C
                     IF (IRMPRI.GT.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI.AND.
     *                   ABS(REEFIX).GT.QSICUT) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(REEFIX).GE.1E-2.AND.
     *                       ABS(REEFIX).LT.1E+3) THEN
C
                             WRITE(REEFIC,'(F11.5)')     REEFIX
                         ELSE
                             WRITE(REEFIC,'((1PE11.3))') REEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(ABS(REEFIX).LT.1.0E10*ABS(REEFIY))IMAFLA='#'
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      IBRA,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      IKET,
     *                      REEFIC,IMAFLA
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
C
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
         IF (LAMBDA.EQ.NSIRED) THEN
C
             IF (I_HALF.EQ.1)
     *           WRITE(NFIPRI,'(1H*,A38,1H*,38X,1H*)') HAFLIN(1)
C
             IF (IRMPRI.GT.0.AND.I_HEAD.EQ.1)
     *           WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
         END IF
C
      END DO
C
C=======================================================================
C
 111  CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('REDMUR',0)
C
      RETURN
C
      END
C
C=======================================================================
C
      SUBROUTINE COUMUR(JPROMI,JPROMA,KPROJE,IAXIAL,IHALF_,
     *                                       ICOUMD,ICOUMX,
     *                  IDIMUR,IRMPRI,IELPRI,ISLPRI,ISUPRI,
     *                                       MINDIK,NUISOM)
C
C=======================================================================
C       >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C                        !!!  W A R N I N G !!!
C       THIS SUBROUTINE DOES NOT WORK FOR ISOSPIN PROJECTION YET
C             ALL ISOSPIN INDICES ARE TEMPORARLY SET TO 1
C       >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C=======================================================================
      USE MURMIX
      USE REEMOM
      USE COUMOM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHALF_*2,IMAFLA*1
      CHARACTER
     *          NAMCOD*45,NAMCOX*45
      CHARACTER
     *          NAMWRK*45
      CHARACTER
     *          HAFLIN*38
      CHARACTER
     *          CEEFIC*11
C
C=======================================================================
      COMPLEX
     *          C_ZERO,WALMUR,WAVMUR
C
      DIMENSION
     *          HAFLIN(2)
      DIMENSION
     *          WALMUR(0:NDPROI,0:NDISOM,NDCONF,NDCONF),
     *          NULMUR(0:NDPROI,0:NDISOM)
C=======================================================================
      COMMON
     *       /ALLMUR/ NUMMUR(0:NDPROI,0:NDISOM)
      COMMON
     *       /COLMUR/ WAVMUR(0:NDPROI,0:NDISOM,NDCONF,NDCONF),
     *                ENEMUR(0:NDPROI,0:NDISOM,NDCONF),
     *                OVEMUR(0:NDPROI,0:NDISOM,NDCONF)
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /IPRIAM/ ILIMAM,IALLAM
      COMMON
     *       /ALLPRI/ IPRALL
C
      DATA
     *       NAMCOD /'DIRECT COULOMB MATRIX ELEMENTS  [UNITS:  MEV]'/,
     *       NAMCOX /'EXCHANGE COULOMB MATRIX ELEMENTS [UNITS: MEV]'/
C
C=======================================================================
C
      CALL CPUTIM('COUMUR',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(CEED_P)) THEN
          ALLOCATE (CEED_P(0:NDREDU),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('CEED_P','COUMUR')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(CEEX_P)) THEN
          ALLOCATE (CEEX_P(0:NDREDU),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('CEEX_P','COUMUR')
      END IF
C=======================================================================
      IF (ALLOCATED(INDREE)) DEALLOCATE (INDREE)
      ALLOCATE (INDREE(0:NDPROI,0:NDMULR,0:NDPROI),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('INDREE','COUMUR')
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE COULOMB MATRIX ELEMENTS BETWEEN
C         THE K-MIXED STATES.
C         IT IS IMPLEMENTED ONLY IN THE CASE  OF  SOLE  ANGULAR-MOMENTUM
C         PROJECTION.
C=======================================================================
C         COULOMB MATRIX ELEMENTS BETWEEN K-MIXED STATES  PROJECTED FROM
C         TWO DIFFERENT REFERENCE STATES ARE  PHASE  DEPENDENT  AND THUS
C         WILL NEVER BE PRINTED
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
      IF (NUISOM.NE.1)STOP 'COUMUR NOT READY FOR ISOSPIN PROJECTION YET'
C
C=======================================================================
C
                       CHALF_='  '
      IF (IHALF_.EQ.1) CHALF_='/2'
C
      IEVEN_=2/(IHALF_+1)
C
C=======================================================================
C
      IF (IDIMUR.NE.1) THEN
C
          STOP 'IDIMUR.NE.1 NOT READY YET IN COUMUR'
C
C=======================================================================
C         READING THE CONFIGURATION-MIXING COEFFICIENTS.
C=======================================================================
C
      ELSE
C
C=======================================================================
C         THE CONFIGURATION-MIXING COEFFICIENTS OF THE RIGHT  STATE  ARE
C         ASSUMED TO BE CALCULATED PREVIOUSLY IN DIAMUR.
C=======================================================================
C
          WALMUR=WAVMUR
          NULMUR=NUMMUR
C
      END IF
C
C=======================================================================
C
      INDREE(:,:,:)=0
      NUREEU=0
C
      CEED_P(NUREEU)=C_ZERO
      CEEX_P(NUREEU)=C_ZERO
C
      DO IPRRIG=JPROMI,JPROMA,2
C
C        ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C        DO IKET=1,NUMMUR(IPRRIG,1)
         DO IKET=1,MIN(1,NUMMUR(IPRRIG,1))
C
            DO LAMBDA=0,0
C
               IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
               DO IPRLEF=MAX(JPROMI,IPRRIG-2*LAMBDA),IMXLEF,2
C
C                 ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C                 DO IBRA=1,NULMUR(IPRLEF,1)
                  DO IBRA=1,MIN(1,NULMUR(IPRLEF,1))
C
                     IF (ILIMAM.NE.1.OR.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
C=======================================================================
C                    CHECKING IF THE LIST OF THE REDUCED MATRIX ELEMENTS
C                    IS NOT TOO LONG
C=======================================================================
C
                         IF (NUREEU.LT.NDREDU) THEN
C
                             NUREEU=NUREEU+1
                         ELSE
                             STOP ' INCREASE NDREDU IN COUMUR'
C
                         END IF
C
C=======================================================================
C
                         CEED_P(NUREEU)=C_ZERO
                         CEEX_P(NUREEU)=C_ZERO
C
                         INDREE(IPRLEF,LAMBDA,IPRRIG)=NUREEU
C
                         DO INDKET=1,MIXNUM
                            DO INDBRA=1,MIXNUM
C
                               INRWAV=MICONF(INDKET)
                               INLWAV=MICONF(INDBRA)
C
                               LMURMI=LMATMI(IPRLEF,LAMBDA,IPRRIG,
     *                                       INLWAV,INRWAV,1,1)
C
                               IF (LMURMI.GT.0) THEN
C
                                   IF (ICOUMD.GE.1)
     *                             CEED_P(NUREEU)=CEED_P(NUREEU)+
     *                               CONJG(WALMUR(IPRLEF,1,INDBRA,IBRA))
     *                                    *DMRMIX(LMURMI)
     *                                    *WAVMUR(IPRRIG,1,INDKET,IKET)
C
                                   IF (ICOUMX.GE.1)
     *                             CEEX_P(NUREEU)=CEEX_P(NUREEU)+
     *                               CONJG(WALMUR(IPRLEF,1,INDBRA,IBRA))
     *                                    *XMRMIX(LMURMI)
     *                                    *WAVMUR(IPRRIG,1,INDKET,IKET)
C
C320j WRITE (*,
C320j*'(''IPRRIG,IKET,LAMBDA,IPRLEF,IBRA,NUREEU,INDBRA,INDKET,'',
C320j*  ''INLWAV,INRWAV,LMURMI'',11I4,/,
C320j*    7X,4(''('',2e10.3,'')''),/,
C320j*    7X,4(''('',2e10.3,'')''))')
C320j*    IPRRIG,IKET,LAMBDA,IPRLEF,IBRA,NUREEU,INDBRA,INDKET,
C320j*    INLWAV,INRWAV,LMURMI,
C320j*  DMRMIX(LMURMI),XMRMIX(LMURMI)
C
                               END IF
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         PRINTING (SEE "COMMENT 1 IN REDPRO"):
C=======================================================================
C       HERE STARTS THE LOOP OVER TWO PASSES CORRESPONDING TO THE DIRECT
C       AND EXCHANGE COULOMB ENERGIES.
C       ATTAENTION: THE LOOPS INSIDE NOT IDENTENT.
C=======================================================================
C
      DO I_PASS=1,2
C
      IF (I_PASS.EQ.1.AND.ICOUMD.LT.1) GO TO 2834
      IF (I_PASS.EQ.2.AND.ICOUMX.LT.1) GO TO 2834
C
      IF (I_PASS.EQ.1) NAMWRK=NAMCOD
      IF (I_PASS.EQ.2) NAMWRK=NAMCOX
C
      I_HEAD=0
      I_HALF=0
C
      IVERRM=1
C
      DO LAMBDA=0,0
C
         DO IPRRIG=JPROMI,JPROMA,2
C
            IMNLEF=MAX(JPROMI,IPRRIG-2*LAMBDA)
            IMXLEF=MIN(JPROMA,IPRRIG+2*LAMBDA)
C
C           ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C           DO IKET=1,NUMMUR(IPRRIG,1)
            DO IKET=1,MIN(1,NUMMUR(IPRRIG,1))
C
               DO IPRLEF=IMNLEF,IMXLEF,2
C
C                 ONLY THE LOWEST STATE IMPLEMENTED,INDREE NOT READY YET
C                 DO IBRA=NULMUR(IPRLEF,1
                  DO IBRA=1,MIN(1,NULMUR(IPRLEF,1))
C
                     IF (I_HEAD.EQ.0.AND.
     *                   IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                             IF (IEVEN_.EQ.1) THEN
C
                      HAFLIN(1)='    IL  NL    L    IR  NR   <COULOMB> '
C
                             ELSE
C
                      HAFLIN(1)='  IL    NL    L  IR    NR   <COULOMB> '
C
                             END IF
C
                             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                        1H*,1X,''                             '',
     *                                                   A45,2X,1H*,/,
     *                        1H*,1X,'' IMAGINARY PARTS LARGER THAN'',
     *                               '' 10^-10 OF THE REAL PARTS ARE'',
     *                               '' FLAGGED WITH "#"'', 2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                        1H*,1X,'' THE TOTAL NUMBER OF MAT.ELEMS'',
     *                               '' CALCULATED IS ='',I7,
     *                               '' AND NDREDU ='',I8,   2X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                79(1H*),/,1H*,38X,1H*,38X,1H*,/,
     *                                          1H*,A38,1H*,A38,1H*,/,
     *                                          1H*,38X,1H*,38X,1H*)')
     *
     *                        NAMWRK,NUREEU,NDREDU,
     *                        HAFLIN(1),HAFLIN(1)
C
                         I_HEAD=1
C
                     END IF
C
                     NUREEU=INDREE(IPRLEF,LAMBDA,IPRRIG)
C320j WRITE (*,'(''NUREEU,IPRLEF,IMNLEF,IMXLEF Q='',4I3)')
C320j*             NUREEU,IPRLEF,IMNLEF,IMXLEF
C320j WRITE (*,
C320j*'(''NUREEU,IPRLEF,LAMBDA,IPRRIG'',4I4,/,
C320j*    7X,4(''('',2e10.3,'')''))')
C320j*    NUREEU,IPRLEF,LAMBDA,IPRRIG,
C320j*  CEED_P(NUREEU),CEEX_P(NUREEU,0)
C
                     IF (I_PASS.EQ.1) CEEFIX= REAL(CEED_P(NUREEU))
                     IF (I_PASS.EQ.1) CEEFIY=AIMAG(CEED_P(NUREEU))
                     IF (I_PASS.EQ.2) CEEFIX= REAL(CEEX_P(NUREEU))
                     IF (I_PASS.EQ.2) CEEFIY=AIMAG(CEEX_P(NUREEU))
C320j WRITE (*,'(''IELPRI Q='',I3)') IELPRI
C
C=======================================================================
C          ON 28/01/2021, THE CONDITION BELOW RELATED TO IELPRI.EQ.3 HAS
C          BEEN REMOVED, BECAUSE THE CG COEFFICIENT ANYHOW PUTS TO  ZERO
C          THE  HYPOTHETICAL  SPECTROSCOPIC  MATRIX  ELEMENTS  THAT  ARE
C          NON-DIAGONAL IN THE TOTAL ANGULAR MOMENTUM.
C=======================================================================
C
                     IF (IPRRIG.GE.ISLPRI.AND.IPRRIG.LE.ISUPRI.AND.
     *                   IPRLEF.GE.ISLPRI.AND.IPRLEF.LE.ISUPRI) THEN
C
                         I_HALF=I_HALF+1
C
                         IF (ABS(CEEFIX).GE.1E-2.AND.
     *                       ABS(CEEFIX).LT.1E+3) THEN
C
                             WRITE(CEEFIC,'(F11.5)')     CEEFIX
                         ELSE
                             WRITE(CEEFIC,'((1PE11.3))') CEEFIX
C
                         END IF
C
                                                              IMAFLA=' '
                         IF(ABS(CEEFIX).LT.1.0E10*ABS(CEEFIY))IMAFLA='#'
C
                         WRITE(HAFLIN(I_HALF),
     *                         '(I4,A2,I4,2X,I3,I4,A2,I4,A11,A1,1X)')
     *                      IPRLEF/IEVEN_,CHALF_,
     *                      IBRA,LAMBDA,
     *                      IPRRIG/IEVEN_,CHALF_,
     *                      IKET,
     *                      CEEFIC,IMAFLA
C
                         IF (I_HALF.EQ.2) THEN
C
                             I_HALF=0
C
                             WRITE(NFIPRI,'(1H*,A38,1H*,A38,1H*)')
     *                                                          HAFLIN
                         END IF
C
                     END IF
C
                  END DO
               END DO
C
            END DO
         END DO
C
      END DO
C
 2834 CONTINUE

      END DO
C
C=======================================================================
C
      CALL CPUTIM('COUMUR',0)
C
      RETURN
C
      END
C
C=======================================================================
C
      SUBROUTINE SAVEWF(NFIWAV,IACWAV,FILWAV,IWRBLO,
     *                                MINDIK,NUISOM,
     *                         KPROJE,ISIQTY,ISIMPY,
     *                  IDSIQN,IDSIQP,IDSIZN,IDSIZP)
C=======================================================================
      USE SAVRIG
      USE HAMMIX
      USE BLOSAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      CHARACTER
     *          FILWAV*68,FILACT*72
      CHARACTER
     *          FILLEF*68,FILRIG*68
C
C=======================================================================
C
      DIMENSION
     *          IDSIZN(1:NDBLOC),IDSIZP(1:NDBLOC)
      DIMENSION
     *          IDSIQN(1:NDBLOC),IDSIQP(1:NDBLOC)
C
C=======================================================================
C
      COMMON
     *       /ALLPRO/ NUMPRO(0:NDPROI,0:NDISOM)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /KERNAM/ FILLEF(NDCONF),FILRIG(NDCONF),NUCONF,NAMKER
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      IF (IWRBLO.NE.1.AND.IWRBLO.NE.2) STOP ' WRONG IWRBLO IN SAVEWF'
C
C=======================================================================
C         THIS SUBROUTINE SAVES ON DISC THE WAVE FUNCTIONS
C         FOR CALCULATION OF THE GCM KERNELS
C=======================================================================
C
      IF (NAMKER.EQ.1) THEN
C
          WRITE(FILACT(1:3),'(I3)') IACWAV
C
          IF (FILACT(1:1).EQ.' ') FILACT(1:1)='0'
          IF (FILACT(2:2).EQ.' ') FILACT(2:2)='0'
C
          FILACT(4:4)='-'
C
          FILACT(5:72)=FILWAV
C
      ELSE
C
          FILACT=TRIM(FILLEF(IACWAV))//'.wfn'
C
      END IF
C
      OPEN(NFIWAV,FILE=FILACT,STATUS='UNKNOWN',FORM='UNFORMATTED')
C
      IF (IWRBLO.EQ.1) THEN
C
          IVERWF=6
C
          WRITE(NFIWAV) IVERWF
C
          WRITE(NFIWAV) KPROJE
C
          DO ICHARG=0,NDISOS
C
             LSTATE=LDTOTS(ICHARG)
C
             WRITE(NFIWAV) LSTATE,LDBASE
C
             WRITE(NFIWAV) (((SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1),
     *                      ISPIN=0,NDSPIN),IBASE=1,LDBASE),
     *                      ISTATE=1,LSTATE)
C
          END DO
C
          WRITE(NFIWAV) IPRODD
C
          IF (IPRODD.EQ.1) THEN
C
             DO ICHARG=0,NDISOS
C
                IF (ISIQTY.EQ.0.AND.ISIMPY.EQ.0) THEN
                    IF (ICHARG.EQ.0) IDBLOR=SUM(ABS(IDSIZN(1:NDBLOC)))
                    IF (ICHARG.EQ.1) IDBLOR=SUM(ABS(IDSIZP(1:NDBLOC)))
C
                ELSE IF (ISIQTY.EQ.1.AND.ISIMPY.EQ.0) THEN
                    IF (ICHARG.EQ.0) IDBLOR=SUM(ABS(IDSIQN(1:NDBLOC)))
                    IF (ICHARG.EQ.1) IDBLOR=SUM(ABS(IDSIQP(1:NDBLOC)))
                ELSE
                    STOP ' WRONG SYMMETRY IN SAVEWF'
                END IF
C
                WRITE(NFIWAV) LPRODR(ICHARG),IDBLOR
C
                WRITE(NFIWAV) (WLABBR(ICHARG,NUBLOC),NUBLOC=1,NDBLOC)
                WRITE(NFIWAV) (WLABAR(ICHARG,NUBLOC),NUBLOC=1,NDBLOC)
C
             END DO
C
          END IF
C
          WRITE(NFIWAV) IWRBLO
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *           1H*,1X,'' THE FILE WITH WAVE FUNCTIONS HAS BEEN'',
     *                  '' SAVED (BLOCK 1)               '', 7X,1H*,/,
     *           1H*,2X,A72,                                 3X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *
     *        FILACT
C
          CLOSE(NFIWAV)
C
      END IF
C
      IF (IWRBLO.EQ.2) THEN
C
          READ (NFIWAV)
          READ (NFIWAV)
C
          DO ICHARG=0,NDISOS
C
             READ (NFIWAV)
             READ (NFIWAV)
C
          END DO
C
          READ (NFIWAV)
C
          IF (IPRODD.EQ.1) THEN
C
             DO ICHARG=0,NDISOS
C
                READ (NFIWAV)
                READ (NFIWAV)
                READ (NFIWAV)
C
             END DO
C
          END IF
C
          WRITE(NFIWAV) IWRBLO
C
          WRITE(NFIWAV) MINDIK,NDPROD,NUISOM,NDPROI
C
          WRITE(NFIWAV) (((WAVPRO(IDPROK,IDPROD,IDISOM),
     *                    IDPROK=1,MINDIK),IDPROD=1,NDPROD),
     *                    IDISOM=1,NUISOM)
C
          WRITE(NFIWAV)  ((NUMPRO(IDPROI,IDISOM),
     *                    IDPROI=0,NDPROI),IDISOM=0,NUISOM)
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *           1H*,1X,'' THE FILE WITH K-MIXING AMPLITUDES HAS BEEN'',
     *                  '' SAVED (BLOCK 2)               '', 2X,1H*,/,
     *           1H*,2X,A72,                                 3X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                       79(1H*))')
     *
     *        FILACT
C
          CLOSE(NFIWAV)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE READWF(NFIWAV,IACWAV,FILWAV,IWRBLO,MINDIK,
     *                                       NUISOM,KPLEFT)
C=======================================================================
      USE SAVLEF
      USE HAMMIX
      USE BLOSAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      CHARACTER
     *          FILWAV*68,FILACT*72
      CHARACTER
     *          FILLEF*68,FILRIG*68
C
C=======================================================================
C
      COMMON
     *       /ALLLEF/ NUMLEF(0:NDPROI,0:NDISOM)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /KERNAM/ FILLEF(NDCONF),FILRIG(NDCONF),NUCONF,NAMKER
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      IF (IWRBLO.NE.1.AND.IWRBLO.NE.2) STOP ' WRONG IWRBLO IN READWF'
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(SALEFT)) THEN
          ALLOCATE (SALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN,0:NDISOS),
     *              STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SALEFT','READWF')
      END IF
      IF (.NOT.ALLOCATED(WAVLEF)) THEN
          ALLOCATE (WAVLEF(0:NDPROK,1:NDPROD,NUISOM),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVLEF','READWF')
      END IF
C=======================================================================
C         THIS SUBROUTINE READS FROM DISC THE WAVE FUNCTIONS
C         FOR CALCULATION OF THE GCM KERNELS
C=======================================================================
C
      IF (NAMKER.EQ.1) THEN
C
          WRITE(FILACT(1:3),'(I3)') IACWAV
C
          IF (FILACT(1:1).EQ.' ') FILACT(1:1)='0'
          IF (FILACT(2:2).EQ.' ') FILACT(2:2)='0'
C
          FILACT(4:4)='-'
C
          FILACT(5:72)=FILWAV
C
      ELSE
C
          FILACT=TRIM(FILLEF(IACWAV))//'.wfn'
C
      END IF
C
      OPEN(NFIWAV,FILE=FILACT,STATUS='OLD',ERR=9,FORM='UNFORMATTED')
C
      GO TO 1009
C
    9 WRITE(NFIPRI,'(/,1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                 2X,26(1H/),/,
     *                 1X, 3(1H/),2X,68X,                  2X, 3(1H/),/,
     *                 1X, 1(1H/),2X,A72,                  2X, 1(1H/),/,
     *                 1X, 3(1H/),2X,68X,                  2X, 3(1H/),/,
     *                 1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                 2X,26(1H/))')
     *             FILACT
C
      STOP ' FILE FILWAV NOT FOUND ON DISC'
C
 1009 CONTINUE
C
      IF (IWRBLO.EQ.1) THEN
C
          READ (NFIWAV) IVERWF
C
          IF (IVERWF.NE.3.AND.IVERWF.NE.5.AND.IVERWF.NE.6) THEN
C
              WRITE(NFIPRI,'(/,1X,10(1H/),
     *         ''  CANNOT READ THE OLD WAVE-FUNCTION FILE VERSION:'',
     *              I3,2X,10(1H/),/,
     *                 1X, 1(1H/),2X,A72,                  2X, 1(1H/),/,
     *                 1X,10(1H/),
     *         ''  RESAVE THIS FILE USING CURRENT VERSION OF THE CODE'',
     *                 2X,10(1H/),/)') IVERWF,FILACT
C
              STOP '  WRONG IVERWF IN READWF'
C
          END IF
C
          IF (IVERWF.GE.5) READ (NFIWAV) KPLEFT
C
          DO ICHARG=0,NDISOS
C
             READ (NFIWAV) MSTATE,MDBASE
C
             IF (LDTOTS(ICHARG).NE.MSTATE) THEN
C
                 WRITE(NFIPRI,'(/,1X,10(1H/),2X,
     *         ''INCOMPATIBLE NUMBERS OF STATES FOUND ON THE WFN FILE'',
     *               2X,10(1H/),/,1X,10(1H/),2X,
     *         ''FOR ICHARG='',I1,'', LSTATE='',I5,
     *         '' WHEREAS IT SHOULD BE'',I5,
     *               2X,10(1H/),/,1X,10(1H/),2X,
     *         ''RERUN THE CALCULATIONS BY SAVING THE WFN  FILE  WITH'',
     *               2X,10(1H/),/,1X,10(1H/),2X,
     *         ''KEYWORDS NUMBCUTSIZ OR NUMBCUTSIQ USED IN THE  INPUT'',
     *               2X,10(1H/),/)') ICHARG,MSTATE,LDTOTS(ICHARG)
C
                 STOP ' WRONG LSTATE IN READWF'
C
             END IF
C
             IF (LDBASE.NE.MDBASE) THEN
C
                 WRITE(NFIPRI,'(/,1X,10(1H/),2X,
     *         ''INCOMPATIBLE SIZE OF THE BASIS FOUND ON THE WFN FILE'',
     *               2X,10(1H/),/,1X,10(1H/),2X,
     *         ''VALUE READ IS LDBASE='',I5,
     *         '' WHEREAS IT SHOULD BE'',I5,
     *               2X,10(1H/),/,1X,10(1H/),2X,
     *         ''RERUN THE CALCULATIONS BY SAVING THE WFN  FILE  WITH'',
     *               2X,10(1H/),/,1X,10(1H/),2X,
     *         ''THE CONSISTENT SIZES OF THE BASIS.                  '',
     *               2X,10(1H/),/)') MDBASE,LDBASE
C
                 STOP ' WRONG LDBASE IN READWF'
C
             END IF
C
             READ  (NFIWAV) (((SALEFT(IBASE,ISTATE,ISPIN,ICHARG),
     *                      ISPIN=0,NDSPIN),IBASE=1,MDBASE),
     *                      ISTATE=1,MSTATE)
C
          END DO
C
          READ (NFIWAV) MPRODD
C
          IF (MPRODD.EQ.1) THEN
C
             CALL INIADD
C
             DO ICHARG=0,NDISOS
C
                READ (NFIWAV) LPRODL(ICHARG),LDBLOL(ICHARG)
C
                READ (NFIWAV) (WLABBL(ICHARG,NUBLOC),
     *                                          NUBLOC=1,NDBLOC)
                READ (NFIWAV) (WLABAL(ICHARG,NUBLOC),
     *                                          NUBLOC=1,NDBLOC)
C
             END DO
C
          END IF
C
          CLOSE(NFIWAV)
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *           1H*,1X,'' THE FILE WITH WAVE FUNCTIONS HAS BEEN'',
     *                  '' READ (BLOCK 1)                '', 7X,1H*,/,
     *           1H*,2X,A72,                                 3X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *
     *        FILACT
C
      END IF
C
      IF (IWRBLO.EQ.2) THEN
C
          READ (NFIWAV) IVERWF
          IF (IVERWF.GE.5) READ (NFIWAV)
C
          DO ICHARG=0,NDISOS
C
             READ (NFIWAV)
             READ (NFIWAV)
C
          END DO
C
          IF (IVERWF.GE.6) THEN
C
              READ (NFIWAV) MPRODD
C
              IF (MPRODD.EQ.1) THEN
C
                 DO ICHARG=0,NDISOS
C
                    READ (NFIWAV)
                    READ (NFIWAV)
                    READ (NFIWAV)
C
                 END DO
C
              END IF
C
          END IF
C
          READ (NFIWAV) MWRBLO
C
          IF (MWRBLO.NE.2) THEN
C
              WRITE(NFIPRI,'(/,1X,12(1H/),
     *         ''  CANNOT READ THE WAVE-FUNCTION FILE VERSION:'',
     *              I3,6X,12(1H/),/,
     *                 1X, 1(1H/),2X,A72,                  2X, 1(1H/),/,
     *                 1X,12(1H/),
     *         ''  BLOCK 2 NOT FOUND ON THE FILE              '',
     *                 7X,12(1H/),/)') IVERWF,FILACT
C
              STOP '  MISSING BLOCK 2 IN READWF'
C
          END IF
C
          IF (IVERWF.EQ.3) THEN
C
              READ (NFIWAV) MDPROK,MDPROD,MDISOM,MDPROI
C
              IF (MDPROK.NE.NDPROK) STOP ' WRONG NDPROK IN READWF'
              IF (MDPROD.NE.NDPROD) STOP ' WRONG NDPROD IN READWF'
              IF (MDISOM.NE.NDISOM) STOP ' WRONG NDISOM IN READWF'
              IF (MDPROI.NE.NDPROI) STOP ' WRONG NDPROI IN READWF'
C
              READ (NFIWAV) (((WAVLEF(IDPROK,IDPROD,IDISOM),
     *               IDPROK=1,NDPROK),IDPROD=1,NDPROD),IDISOM=1,NDISOM)
C
              READ (NFIWAV)  ((NUMLEF(IDPROI,IDISOM),
     *                        IDPROI=0,NDPROI),IDISOM=0,NDISOM)
C
          END IF
C
          IF (IVERWF.GE.4) THEN
C
              READ (NFIWAV) MJNDIK,MDPROD,MUISOM,MDPROI
C
              IF (MJNDIK.NE.MINDIK) STOP ' WRONG MINDIK IN READWF'
              IF (MDPROD.NE.NDPROD) STOP ' WRONG NDPROD IN READWF'
              IF (MUISOM.NE.NUISOM) STOP ' WRONG NUISOM IN READWF'
              IF (MDPROI.NE.NDPROI) STOP ' WRONG NDPROI IN READWF'
C
              READ (NFIWAV) (((WAVLEF(IDPROK,IDPROD,IDISOM),
     *               IDPROK=1,MINDIK),IDPROD=1,NDPROD),IDISOM=1,NUISOM)
C
              READ (NFIWAV)  ((NUMLEF(IDPROI,IDISOM),
     *                        IDPROI=0,NDPROI),IDISOM=0,NUISOM)
C
          END IF
C
          CLOSE(NFIWAV)
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *           1H*,1X,'' THE FILE WITH K-MIXING AMPLITUDES HAS BEEN'',
     *                  '' READ (BLOCK 2)                '', 2X,1H*,/,
     *           1H*,2X,A72,                                 3X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                       79(1H*))')
     *
     *        FILACT
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAV_WF(NFIWAV,IACKER,IACWAV,FILWAV,
     *                  ISOMIR,ISOMAR,ISOTZR)
C=======================================================================
      USE SAVRIG
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      CHARACTER
     *          FILWAV*68,FILACT*76
C
      COMPLEX
     *          F_KT_R
C
      COMMON
     *       /FERMIR/ F_KT_R(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_R,IDIM_R,IIFERR,ITFERR,ISFERR
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE SAVES ON DISC THE WAVE FUNCTIONS
C         FOR CALCULATION OF THE GCM KERNELS
C=======================================================================
C
      WRITE(FILACT(1:3),'(I3)') IACKER
C
      IF (FILACT(1:1).EQ.' ') FILACT(1:1)='0'
      IF (FILACT(2:2).EQ.' ') FILACT(2:2)='0'
C
      FILACT(4:4)='-'
C
      WRITE(FILACT(5:7),'(I3)') IACWAV
C
      IF (FILACT(5:5).EQ.' ') FILACT(5:5)='0'
      IF (FILACT(6:6).EQ.' ') FILACT(6:6)='0'
C
      FILACT(8:8)='-'
C
      FILACT(9:76)=FILWAV
C
      OPEN(NFIWAV,FILE=FILACT,STATUS='UNKNOWN',FORM='UNFORMATTED')
C
      IVERWF=2
C
      WRITE(NFIWAV) IVERWF
C
      DO ICHARG=0,NDISOS
C
         LSTATE=LDSTAT(ICHARG)
         LUPPER=LDUPPE(ICHARG)
         LTIMUP=LDTIMU(ICHARG)
C
         WRITE(NFIWAV) LSTATE,LUPPER,LTIMUP
C
         WRITE(NFIWAV) (((SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1),
     *                  ISPIN=0,NDSPIN),IBASE=1,LDBASE),ISTATE=1,LSTATE)
C
      END DO
C
         WRITE(NFIWAV)  ISOMIR,ISOMAR,ISOTZR,IDIM_R,IIFERR,ITFERR,
     *                  ISFERR
C
         DO KPROJB=-IIFERR,IIFERR,2
         WRITE(NFIWAV)  (F_KT_R(KPROJB,IT,0),IT=1,IDIM_R)
         END DO
C
         WRITE(NFIWAV)   EIGE_R
C
      CLOSE (NFIWAV)
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE FILE WITH WAVE FUNCTION THAT HAS BEEN'',
     *               '' SAVED:                         '',    2X,1H*,/,
     *        1H*,2X,A72,                                     3X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *
     *    FILACT
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE REA_WL(NFIWAV,IACKER,IACWAV,FILWAV,
     *                  ISOMIL,ISOMAL,ISOTZL)
C=======================================================================
      USE SAVLEF
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          FILWAV*68,FILACT*76
C
      COMPLEX
     *          F_KT_L
C
      COMMON
     *       /FERMIL/ F_KT_L(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_L,IDIM_L,IIFERL,ITFERL,ISFERL
C
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
      IF (.NOT.ALLOCATED(SALEFT)) THEN
          ALLOCATE (SALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN,0:NDISOS),
     *              STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SALEFT','REA_WL')
      END IF
C=======================================================================
C=======================================================================
C         THIS SUBROUTINE READS FROM DISC THE WAVE FUNCTIONS
C           FOR CALCULATION OF THE FERMI SUPERALLOWED M.E.
C=======================================================================
C
      WRITE(FILACT(1:3),'(I3)') IACKER
C
      IF (FILACT(1:1).EQ.' ') FILACT(1:1)='0'
      IF (FILACT(2:2).EQ.' ') FILACT(2:2)='0'
C
      FILACT(4:4)='-'
C
      WRITE(FILACT(5:7),'(I3)') IACWAV
C
      IF (FILACT(5:5).EQ.' ') FILACT(5:5)='0'
      IF (FILACT(6:6).EQ.' ') FILACT(6:6)='0'
C
      FILACT(8:8)='-'
C
      FILACT(9:76)=FILWAV
C
      OPEN(NFIWAV,FILE=FILACT,STATUS='OLD',ERR=9,FORM='UNFORMATTED')
C
      GO TO 1009
C
    9 WRITE(NFIPRI,'(/,1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                 2X,26(1H/),/,
     *                 1X, 3(1H/),2X,68X,                  2X, 3(1H/),/,
     *                 1X, 1(1H/),2X,A72,                  2X, 1(1H/),/,
     *                 1X, 3(1H/),2X,68X,                  2X, 3(1H/),/,
     *                 1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                 2X,26(1H/))')
     *             FILACT
C
      STOP ' FILE FILWAV NOT FOUND ON DISC'
C
 1009 CONTINUE
C
      READ (NFIWAV) IVERWF
C
      IF (IVERWF.NE.2) THEN
C
          WRITE(NFIPRI,'(/,1X,10(1H/),
     *              ''  CANNOT READ THE WAVE-FUNCTION FILE VERSION:'',
     *              I3,2X,10(1H/),/)') IVERWF
C
          STOP '  WRONG IVERWF IN READWF'
C
      END IF
C
      DO ICHARG=0,NDISOS
C
         READ (NFIWAV) LSTATE,LUPPER,LTIMUP
C
         LDSTAT(ICHARG)=LSTATE
         LDUPPE(ICHARG)=LUPPER
         LDTIMU(ICHARG)=LTIMUP
C
         READ  (NFIWAV) (((SALEFT(IBASE,ISTATE,ISPIN,ICHARG),
     *                  ISPIN=0,NDSPIN),IBASE=1,LDBASE),ISTATE=1,LSTATE)
C
      END DO
C
         READ  (NFIWAV)  ISOMIL,ISOMAL,ISOTZL,IDIM_L,IIFERL,ITFERL,
     *                   ISFERL
C
C         WRITE(*,77) ISOMIL,ISOMAL,ISOTZL,IDIM_L,IIFERL,ITFERL,
C     *               ISFERL
C 77      FORMAT (2X,7I3)
C
         DO KPROJB=-IIFERL,IIFERL,2
         READ  (NFIWAV)  (F_KT_L(KPROJB,IT,0),IT=1,IDIM_L)
         END DO
C
         READ  (NFIWAV)   EIGE_L
C
         REWIND NFIWAV
C
         CLOSE (NFIWAV)
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE FILE WITH WAVE FUNCTION THAT HAS BEEN'',
     *               '' READ:                          '',    2X,1H*,/,
     *        1H*,2X,A72,                                     3X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                                                        79(1H*))')
     *
     *    FILACT
C
C=======================================================================
C
      RETURN
      END
C
      SUBROUTINE REA_WR(NFIWAV,IACKER,IACWAV,FILWAV,
     *                  ISOMIR,ISOMAR,ISOTZR)
C=======================================================================
      USE SAVRIG
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          FILWAV*68,FILACT*76
C
      COMPLEX
     *          F_KT_R
C
      COMMON
     *       /FERMIR/ F_KT_R(-NDPROI:NDPROI,0:NDPROT,-NDPROT:NDPROT),
     *                EIGE_R,IDIM_R,IIFERR,ITFERR,ISFERR
C
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
      IF (.NOT.ALLOCATED(SARIGH)) THEN
          ALLOCATE (SARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN,0:NDISOS,
     *                                                  1:NDTWCE),
     *              STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SARIGH','REA_WR')
      END IF
C=======================================================================
C=======================================================================
C         THIS SUBROUTINE READS FROM DISC THE WAVE FUNCTIONS
C           FOR CALCULATION OF THE FERMI SUPERALLOWED M.E.
C=======================================================================
C
      WRITE(FILACT(1:3),'(I3)') IACKER
C
      IF (FILACT(1:1).EQ.' ') FILACT(1:1)='0'
      IF (FILACT(2:2).EQ.' ') FILACT(2:2)='0'
C
      FILACT(4:4)='-'
C
      WRITE(FILACT(5:7),'(I3)') IACWAV
C
      IF (FILACT(5:5).EQ.' ') FILACT(5:5)='0'
      IF (FILACT(6:6).EQ.' ') FILACT(6:6)='0'
C
      FILACT(8:8)='-'
C
      FILACT(9:76)=FILWAV
C
      OPEN(NFIWAV,FILE=FILACT,STATUS='OLD',ERR=9,FORM='UNFORMATTED')
C
      GO TO 1009
C
    9 WRITE(NFIPRI,'(/,1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                 2X,26(1H/),/,
     *                 1X, 3(1H/),2X,68X,                  2X, 3(1H/),/,
     *                 1X, 1(1H/),2X,A72,                  2X, 1(1H/),/,
     *                 1X, 3(1H/),2X,68X,                  2X, 3(1H/),/,
     *                 1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                 2X,26(1H/))')
     *             FILACT
C
      STOP ' FILE FILWAV NOT FOUND ON DISC'
C
 1009 CONTINUE
C
      READ (NFIWAV) IVERWF
C
      IF (IVERWF.NE.2) THEN
C
          WRITE(NFIPRI,'(/,1X,10(1H/),
     *              ''  CANNOT READ THE WAVE-FUNCTION FILE VERSION:'',
     *              I3,2X,10(1H/),/)') IVERWF
C
          STOP '  WRONG IVERWF IN READWF'
C
      END IF
C
      DO ICHARG=0,NDISOS
C
         READ (NFIWAV) LSTATE,LUPPER,LTIMUP
C
         LDSTAT(ICHARG)=LSTATE
         LDUPPE(ICHARG)=LUPPER
         LDTIMU(ICHARG)=LTIMUP
C
         READ  (NFIWAV) (((SARIGH(IBASE,ISTATE,ISPIN,ICHARG,1),
     *                  ISPIN=0,NDSPIN),IBASE=1,LDBASE),ISTATE=1,LSTATE)
C
      END DO
C
         READ  (NFIWAV)  ISOMIR,ISOMAR,ISOTZR,IDIM_R,IIFERR,ITFERR,
     *                   ISFERR
C
C         WRITE(*,77) ISOMIR,ISOMAR,ISOTZR,IDIM_R,IIFERR,ITFERR,
C     *               ISFERR
C 77      FORMAT (2X,7I3)
C
         DO KPROJB=-IIFERR,IIFERR,2
         READ  (NFIWAV)  (F_KT_R(KPROJB,IT,0),IT=1,IDIM_R)
         END DO
C
         READ  (NFIWAV)   EIGE_R
C
         REWIND NFIWAV
C
         CLOSE (NFIWAV)
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE FILE WITH WAVE FUNCTION THAT HAS BEEN'',
     *               '' READ:                          '',    2X,1H*,/,
     *        1H*,2X,A72,                                     3X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                                                        79(1H*))')
     *
     *    FILACT
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFBIN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /NEWBIN/ IBINOM(0:NDMULT,0:NDMULT)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C     THIS SUBROUTINE DEFINES THE NEWTON BINOMIAL INTEGER COEFFICIENTS:
C     IBINOM(N,K)=N!/(K!(N-K)!)
C     COEFFICIENTS ARE SYMMETRIZED IN ORDER TO FILL IN ALL  THE MEMORY
C     LOCATIONS
C=======================================================================
C
      IBINOM(0,0)=1
      IBINOM(1,0)=1
      IBINOM(0,1)=1
      IBINOM(1,1)=1
C
      DO N=2,NDMULT
C
         IBINOM(N,0)=1
         IBINOM(0,N)=1
C
         DO K=1,N-1
C
            IBINOM(N,K)=IBINOM(N-1,K-1)+IBINOM(N-1,K)
            IBINOM(K,N)=IBINOM(N,K)
C
            IF (IBINOM(N,K).LT.0) THEN
C
                WRITE(NFIPRI,'(/,
     *                     1X,24(1H/),2X,''INTEGER OVERFLOW IN DEFBIN'',
     *                                                     2X,24(1H/),/,
     *                     1X,24(1H/),2X,''IBINOM MATRIX HAS NOT BEEN'',
     *                                                     2X,24(1H/),/,
     *                     1X,24(1H/),2X,''CALCULATED FOR N='',I3,
     *                                                 '' K='',I3,
     *                                                     2X,24(1H/),/,
     *                     1X,24(1H/),2X,''DECREASE  NDMULT PARAMETER'',
     *                                                     2X,24(1H/))')
     *          N,K
C
                STOP ' INTEGER OVERFLOW IN DEFBIN, NDMULT TOO LARGE'
C
            END IF
C
C           PRINT *,N,K,IBINOM(N,K)
C
         END DO
C
         IBINOM(N,N)=1
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFBIR
C=======================================================================
      USE hfodd_sizes
C=======================================================================
#if(SWITCH_QUAD==1)
      REAL*16
     *          RBINOM
#endif
C
      COMMON
     *       /NEWBIR/ RBINOM(0:NDBINO,0:NDBINO)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C     THIS SUBROUTINE DEFINES THE NEWTON BINOMIAL REAL  COEFFICIENTS:
C     RBINOM(N,K)=N!/(K!(N-K)!)
C     COEFFICIENTS ARE SYMMETRIZED IN ORDER TO FILL IN ALL THE MEMORY
C     LOCATIONS
C=======================================================================
C
      RBINOM(0,0)=1
      RBINOM(1,0)=1
      RBINOM(0,1)=1
      RBINOM(1,1)=1
C
      DO N=2,NDBINO
C
         RBINOM(N,0)=1
         RBINOM(0,N)=1
C
         DO K=1,N-1
C
            RBINOM(N,K)=RBINOM(N-1,K-1)+RBINOM(N-1,K)
            RBINOM(K,N)=RBINOM(N,K)
C
            IF (RBINOM(N,K).LT.0) THEN
C
                WRITE(NFIPRI,'(/,
     *                     1X,24(1H/),2X,''REAL  OVERFLOW  IN  DEFBIR'',
     *                                                     2X,24(1H/),/,
     *                     1X,24(1H/),2X,''RBINOM MATRIX HAS NOT BEEN'',
     *                                                     2X,24(1H/),/,
     *                     1X,24(1H/),2X,''CALCULATED FOR N='',I3,
     *                                                 '' K='',I3,
     *                                                     2X,24(1H/),/,
     *                     1X,24(1H/),2X,''DECREASE  NDMAIN PARAMETER'',
     *                                                     2X,24(1H/))')
     *          N,K
C
                STOP ' REAL OVERFLOW IN DEFBIR, NDMAIN TOO LARGE'
C
            END IF
C
C           PRINT *,N,K,RBINOM(N,K)
C
         END DO
C
         RBINOM(N,N)=1
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFFAC
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /MUFACR/ NUFACR
C=======================================================================
C        DIMENSIONS BELOW TAKE INTO ACCOUNT THE OPTION TO TREAT FULL
C        REGULARIZED POTENTIALS UP TO N3LO (14/07/2013)
C=======================================================================
C
      NUFACR=MAX(2*NDOSCI+7,NDGAUS)
C
      IALLOC=0
C
      IF (ALLOCATED(FACTOR)) DEALLOCATE(FACTOR)
      IF (.NOT.ALLOCATED(FACTOR)) THEN
          ALLOCATE (FACTOR(0:NUFACR),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FACTOR','DEFFAC')
      END IF
C
      IF (ALLOCATED(FACTOE)) DEALLOCATE(FACTOE)
      IF (.NOT.ALLOCATED(FACTOE)) THEN
          ALLOCATE (FACTOE(0:NUFACR),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FACTOE','DEFFAC')
      END IF
C
      IF (ALLOCATED(FACTOO)) DEALLOCATE(FACTOO)
      IF (.NOT.ALLOCATED(FACTOO)) THEN
          ALLOCATE (FACTOO(0:NUFACR),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FACTOO','DEFFAC')
      END IF
C
C=======================================================================
C     THIS SUBROUTINE DEFINES FACTORIALS
C=======================================================================
C
C=======================================================================
C            ATTENTION: IN VERSIONS FROM 2.31L TO 2.32E, THE  DIMENSIONS
C                       ABOVE DID NOT DEPEND ON THE  PARAMETER  "NDGAUS"
C                       AND THUS NOT ON "NDXHRM,NDYHRM,NDZHRM". THIS BUG
C                       WAS CORRECTED ON 31/01/2008 IN VERSION  (2.32F).
C=======================================================================
C
      FACTOR(0)=1.0D0
      FACTOE(0)=1.0D0
      FACTOO(0)=1.0D0
C
      DO I=1,NUFACR
C
         FACTOR(I)=FACTOR(I-1)*REAL(I)
         FACTOE(I)=FACTOE(I-1)*REAL(2*I)
         FACTOO(I)=FACTOO(I-1)*REAL(2*I-1)
C
         IF (FACTOR(I).LT.0.OR.FACTOE(I).LT.0.OR.FACTOO(I).LT.0) THEN
C
             WRITE(NFIPRI,'(/,
     *                  1X,24(1H/),2X,''REAL  OVERFLOW  IN  DEFFAC'',
     *                                                  2X,24(1H/),/,
     *                  1X,24(1H/),2X,''FACTORIALS MATRIX HAVE NOT'',
     *                                                  2X,24(1H/),/,
     *                  1X,24(1H/),2X,''BEEN CALCULATED FOR I ='',I3,
     *                                                  2X,24(1H/),/,
     *                  1X,24(1H/),2X,''FACTOR(I) = '',E14.7,
     *                                                  2X,24(1H/),/,
     *                  1X,24(1H/),2X,''FACTOE(I) = '',E14.7,
     *                                                  2X,24(1H/),/,
     *                  1X,24(1H/),2X,''FACTOO(I) = '',E14.7,
     *                                                  2X,24(1H/),/,
     *                  1X,24(1H/),2X,''DECREASE NDOSCI OR NDGAUS.'',
     *                                                  2X,24(1H/))')
     *       I,FACTOR(I),FACTOE(I),FACTOO(I)
C
             STOP ' REAL OVERFLOW IN DEFFAC, NDMAIN TOO LARGE'
C
         END IF
C
C        PRINT *,I,FACTOR(I),FACTOE(I),FACTOO(I)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFGAU
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /INTGAU/ GAUINT(0:2*NDMULT),
     *                GAUMUL(0:NDMULT)
C
C=======================================================================
C     THIS ROUTINE CALCULATES THE INTEGRALS  X**I * EXP(-X**2)
C     IN THE RANGE (-INF,INF) AND  STORES  THEM  IN  GAUINT(I)
C     IT ALSO CALCULATES THE INTEGRALS R**(2*L+2) * EXP(-R**2)
C     IN THE  RANGE  (0,INF)  AND  STORES  THEM  IN  GAUMUL(L)
C=======================================================================
C
      GAUINT(0)=SQRT(4.0D0*ATAN(1.0D0))
      GAUINT(1)=0.0D0
C
      DO I=2,2*NDMULT
C
         GAUINT(I)=0.5D0*(I-1)*GAUINT(I-2)
C
      END DO
C
C=======================================================================
C
      GAUMUL(0)=SQRT(4.0D0*ATAN(1.0D0))/4.0D0
C
      DO L=1,NDMULT
C
         GAUMUL(L)=0.5D0*(2*L+1)*GAUMUL(L-1)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CNVRGE(ESTABN,EPSITE,IS_YES,ITERUN,NULAST,
     *                                EPSCON,IS_CON,NUCONS)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /KOUNTG/ STABIT(1:NDITER+1)
C
C=======================================================================
C        THIS ROUTINE IS HELPING TO ACHIEVE  THE  PRESCRIBED ACCURACY
C        IN TERMS OF THE "FUNCTIONAL-S.P.SUMM" CRITERION.
C
C        THE PRINCIPLE: IF THE ABSOLUTE VALUE OF THE ABOVE DIFFERENCE
C        IS SMALLER THAN THE PRESCRIBED VALUE (EPSITE), THEN THE NEXT
C        ITERATION IS IN PRINCIPLE UNNECESSARY. IN "PRACTICE" HOWEVER
C        THE ABOVE DIFERENCE  MAY FLUCTUATE AS A FUNCTION OF THE ITE-
C        RATION NUMBER,  AND THUS  THE SIMPLE CUTTING  THE ITERATIONS
C        WOULD BE PREMATURE.  THIS ROUTINE SHOULD THEREFORE CHECK, IF
C        THE ABOVE DIFFERENCE IS SMALLER  THAN "EPSITE" OVER "NULAST"
C        CONSECUTIVE ITERATIONS. "NULAST" IS READ FROM THE INPUT.
C=======================================================================
C
      STABIT(ITERUN)=ESTABN
C
      IF (ITERUN.GE.NULAST.AND.EPSITE.GT.0.0) THEN
C
          IS_YES=1
C
          DO I=ITERUN,ITERUN-NULAST+1,-1
C
             IF (ABS(STABIT(I)).GT.EPSITE) IS_YES=0
C
          END DO
C
      ELSE
C
          IS_YES=0
C
      END IF
C
      IF (ITERUN.GE.NUCONS.AND.EPSITE.GT.0.0.AND.NUCONS.GT.0) THEN
C
          IS_CON=1
C
          DO I=ITERUN,ITERUN-NUCONS+1,-1
C
             IF (ABS(STABIT(I)-STABIT(ITERUN)).GT.EPSCON*EPSITE)IS_CON=0
C
          END DO
C
      ELSE
C
          IS_CON=0
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PINGPO(EPSPNG,IS_PIN,ITERUN,NUPING)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /KOUNTG/ STABIT(1:NDITER+1)
C
C=======================================================================
C        THIS ROUTINE IS CHECKING WHETHER THE ITERATION JUMPS BACK
C        AND FORTH BETWEEN TWO SOLUTIONS (PING-PONG CONDITION).
C=======================================================================
C
      IF (ITERUN.GE.2*NUPING.AND.EPSPNG.GT.0.0) THEN
C
          IS_PIN=0
C
          AVREVE=0.0D0
          AVRODD=0.0D0
          DISEVE=0.0D0
          DISODD=0.0D0
C
          DO I=ITERUN,ITERUN-2*NUPING+1,-2
C
             AVREVE=AVREVE+STABIT(I)
             AVRODD=AVRODD+STABIT(I-1)
C
          END DO
C
          AVREVE=AVREVE/NUPING
          AVRODD=AVRODD/NUPING
C
          DO I=ITERUN,ITERUN-2*NUPING+1,-2
C
             DISEVE=DISEVE+(STABIT(I)  -AVREVE)**2
             DISODD=DISODD+(STABIT(I-1)-AVRODD)**2
C
          END DO
C
          DISEVE=SQRT(DISEVE/NUPING)
          DISODD=SQRT(DISODD/NUPING)
C
          IF (DISEVE.LT.EPSPNG*ABS(AVREVE-AVRODD).AND.
     *        DISODD.LT.EPSPNG*ABS(AVREVE-AVRODD)     ) IS_PIN=1
C
      ELSE
C
          IS_PIN=0
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CHAODI(IS_CHA,ITERUN,NUCHAO)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /KOUNTG/ STABIT(1:NDITER+1)
C
C=======================================================================
C        THIS ROUTINE IS CHECKING WHETHER THE ITERATION DIVERGES
C        BY JUMPING CHAOTICALLY.
C=======================================================================
C
      IF (ITERUN.GE.2.AND.NUCHAO.GT.0) THEN
C
          IS_CHA=0
          I_INCR=0
          NUMAXI=-1
          STAMAX=0.0
C
          DO I=2,ITERUN
C
             IF (I_INCR.EQ.0) THEN
C
                 IF (ABS(STABIT(I)).GT.ABS(STABIT(I-1))) I_INCR=1
C
             ELSE
C
                 IF (ABS(STABIT(I)).LT.ABS(STABIT(I-1))) THEN
C
                     IF (ABS(STABIT(I-1)).GT.STAMAX) NUMAXI=NUMAXI+1
C
                     IF (NUMAXI.GE.NUCHAO) IS_CHA=1
C
                     STAMAX=ABS(STABIT(I-1))
C
                     I_INCR=0
C
                 END IF
C
             END IF
C
         END DO
C
      ELSE
C
          IS_CHA=0
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INFPRI(IN_FIX,IZ_FIX,
     *                         NUMCOU,NUMETA,FURMAX,
     *                         ICOTYP,ICOUDI,ICOUEX,
     *                  PIMASS,PNMASS,IYUTYP,I_YUKA,
     *                  YUKAGT,YUKAG0,YUKAG1,YUKAG2,
     *                                I_GOGA,IGOGPA,
     *                                I_REGA,IREGPA,
     *                                I_SEPA,ISEPPA,
     *                                I_COUA,ICOUPA,
     *                         N3LORD,N3SERD,IDOTHC,
     *           NUCHAO,NUPING,EPSPNG,EPSITE,EPSCON,
     *                         NOITER,NULAST,NUCONS,
     *                  DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                  FERFIN,FERFIP,IFEFIN,IFEFIP,
     *                  FE2FIN,FE2FIP,IF2FIN,IF2FIP,
     *                  FERALN,FERALP,IFERAN,IFERAP,
     *                                       NUQEVE,
     *                  INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *                  INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                         INSIMN,IRSIMN,IDSIMN,
     *                         INSIMP,IRSIMP,IDSIMP,
     *                         INSIQN,IPSIQN,IDSIQN,
     *                         INSIQP,IPSIQP,IDSIQP,
     *                                INSIZN,IDSIZN,
     *                                INSIZP,IDSIZP,
     *                                IFIBLN,INIBLN,
     *                                IFIBLP,INIBLP,
     *                         ECUTOF,LIMQUA,LAMCUT,
     *                  ISPHER,ISIMPY,ISIGNY,ISIQTY,
     *                         ISIMTX,JSIMTY,ISIMTZ,
     *                  ISYMDE,INIROT,INIINV,INIKAR,
     *                         IRENMA,IRENIN,IDOGOA,
     *                         ITWOLI,JETACM,KETA_R,
     *                                       NOZEPA,
     *                                KETAJ2,KETAT2,
     *                                JETA_T,JETAPA,
     *                         IFRWAV,ITOWAV,IWRWAV,
     *                         IONISH,ISAKER,ICHKER,
     *                         IPRGCM,IPROMI,IPROMA,
     *                         NUAKNO,NUBKNO,KPROJE,
     *                         NATKNO,NBTKNO,ISOSTZ,
     *                  NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *                  ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *                  IPAKER,IPAK3D,IPAALL,KFIKER,
     *                  NUASTA,NUASTO,NUGSTA,NUGSTO,
     *                  NATSTA,NATSTO,NGTSTA,NGTSTO,
     *                  NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *                                ISLPRI,ISUPRI,
     *                         IENPRI,ISRPRI,IMIPRI,
     *                         IKEPRI,IRMPRI,IELPRI,
     *                  QMUCUT,QMACUT,QASCUT,QSICUT,
     *                  IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                         IPRSTA,IPRMID,IPRSTO,
     *                  IDESTA,IDEMID,IDESTO,IDEDIS,
     *                                INTRIP,IVIPRI,
     *                         IPRI_N,IPRI_P,IPRI_T,
     *           IPAIRI,IPAHFB,ITWOBA,JPABCS,IMFHFB,
     *                                       IPNMIX,
     *                                LIPKIN,LIPKIP,
     *                                LIPNON,LIPNOP,
     *                                IQUNIL,NILXYZ,
     *                         IROTAT,ITIREP,IQPSTA,
     *                         NMUCON,NMUCOU,NMUPRI,
     *                  ISCHIF,NSIMAX,NSICON,NSIPRI,
     *                                       IDOPLM,
     *                  NMAMAX,NMACON,NMAPRI,NMAORD,
     *                  NASMAX,NASCON,NASPRI,NASORD,
     *                                       NRAORD,
     *                  NMURED,NMARED,NASRED,NSIRED,
     *                  SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                         ICONTI,IPCONT,IOCONT,
     *                         ISCONT,ITCONT,IACONT,
     *                  IYCONT,IGCONT,IGPCON,IECONT,
     *           ILCONT,IFCONT,IMCONT,IRCONT,IBCONT,
     *                                       IPOTHO,
     *                         BOUCOU,IFSHEL,IF_RPA,
     *                                I_SLOW,SLOWAL,
     *                  SLOWLD,SLOWTP,SLOWRP,SLOWLM,
     *                  NLSIGN,NLSIMN,NLSIQN,NLSIZN,
     *                  NLSIGP,NLSIMP,NLSIQP,NLSIZP,
     *                         IAXIAP,KAPASY,INUNIL,
     *                                       IADBAT,
     *                                NEWGOG,NEWCOU,
     *                                       ITWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDF2BC=5)
      PARAMETER (NDFANL=2)
      PARAMETER (NDFSTA=3)
C=======================================================================
C
      CHARACTER
     *          NONYES(0:1)*3,NO_YES(0:2)*3,EPSITC*8,KARDIR(3)*1
      CHARACTER
     *          NOORYE*3
      CHARACTER
     *          IFTIMR(-1:1)*26
      CHARACTER
     *          LPROMI*5,LPROMA*5,LPROJE*5
      CHARACTER
     *          NAMINV(0:3,0:3)*43
      CHARACTER
     *          FFRGCM*3,FTOGCM*3
      CHARACTER
     *          YUKACT*7,YUKAC0*7,YUKAC1*7,YUKAC2*7
      CHARACTER
     *          N3LONA(4)*6
      CHARACTER
     *          NUMERN*6,NUMERP*6,NUMMQN*6,NUMMQP*6,NUM_GN*6,NUM_GP*6
      CHARACTER
     *          MINPLU(-1:1)*1
      CHARACTER
     *          FILLEF*68,FILRIG*68
      CHARACTER
     *          TACONF*1
C
      LOGICAL
     *          DOSYMM,do_symmetrize
C
      DIMENSION
     *          INSIZN(1:NDBLOC),IDSIZN(1:NDBLOC),
     *          INSIZP(1:NDBLOC),IDSIZP(1:NDBLOC)
      DIMENSION
     *          INSIQN(1:NDBLOC),IPSIQN(1:NDBLOC),IDSIQN(1:NDBLOC),
     *          INSIQP(1:NDBLOC),IPSIQP(1:NDBLOC),IDSIQP(1:NDBLOC)
C=======================================================================
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VCNSTR/ STIFFV(0:NDMULT,-NDMULT:NDMULT),
     *                VASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SCNSTR/ STIFFS(0:NDMULT,-NDMULT:NDMULT),
     *                SASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /GCNSTR/ STIFFG(0:NDMULT),
     *                GASKED(0:NDMULT),
     *                IFLAGG(0:NDMULT)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /ICNSTR/ STIFFI(1:NDKART),
     *                ASKEDI(1:NDKART),
     *                IFLAGI(1:NDKART)
      COMMON
     *       /ICNTTR/ STIFTI(1:NDKART),
     *                ASKETI(1:NDKART),
     *                IFTAGI(1:NDKART)
      COMMON
     *       /TCNSTR/ STIFFT(1:NDKART),
     *                ASKEDT(1:NDKART),
     *                IFLAGT(1:NDKART)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /ACNSTR/ STIFFA,ASKEDA,IFLAGA
      COMMON
     *       /PAIINI/ FERINI(0:NDISOS),DELINI(0:NDISOS),FE2INI(0:NDISOS)
      COMMON
     *       /ISOFER/ FERISO(0:NDKART)
      COMMON
     *       /ISOFE_/ FE_RAD,FE_THE,FE_PHI,FE_OFF
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /OMEGAS/ OMEGAX,OMEGAY,OMEGAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /IANGLE/ ALPINI,BETINI,GAMINI
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /DISTAN/ DISTAX,DISTAY,DISTAZ
      COMMON
     *       /ROTATT/ ROTATX,ROTATY,ROTATZ
      COMMON
     *       /RINORM/ HBMRIN(NDKART)
      COMMON
     *       /RINROT/ ROTRIN(NDKART)
      COMMON
     *       /IKETRA/ IKEINV,IKEKAR
      COMMON
     *       /NEWIGN/ NEWWIG
      COMMON
     *       /CFIPRI/ NFIPRI
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
      COMMON
     *       /STRUTI_PARAMS/ GSTRUN,GSTRUP,HOMFAC,EPSRTN
     *       /STRUTI_POLYNO/ NPOLYN
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMIX/ ALPHAM,BROTRI
     *       /BROMAT/ NOIINP,MIXMAT
C
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /GCTEMP/ TEMP_T
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
     *       /NCKFLA/ IFNECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /QUOCCU/ PARACC,CORLIM,DERLIM,OCCLIM,MAXQUA,IPQBCS
      COMMON
     *       /JPA2HF/ DEL2HF(0:NDISOS),IPA2HF(0:NDISOS)
      COMMON
     *       /IDENTU/ IDENSU,JDENSU
      COMMON
     *       /FRASYM/ DOSYMM,do_symmetrize
      COMMON
     *       /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME
      COMMON
     *       /IPRIAM/ ILIMAM,IALLAM
      COMMON
     *       /ALLPRI/ IPRALL
      COMMON
     *       /GYROSC/ GYRORP,GYRSPN,GYRSPP,IGYROS
      COMMON
     *       /CUSIZN/ NCUSIZ(0:NDISOS)
      COMMON
     *       /CUSIQN/ NCUSIQ(0:NDISOS,0:NDPARI)
      COMMON
     *       /KERNAM/ FILLEF(NDCONF),FILRIG(NDCONF),NUCONF,NAMKER
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /DIQ_GA/ DIQCOD,DIQCOE,DIQCOP,IDIQGA
      COMMON
     *       /ADBRUN/ IABNTE,IABCOL,IABICH,IABMOD,IFAMON
      COMMON
     *       /ADBPRC/ DABPRS,ETAFAM,XCHIMX
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /FORANL/ MAGANL(NDFANL)
      COMMON
     *       /GEF2BC/ GIN2BC,GSA2BC,IGY2BC
      COMMON
     *       /GEFANL/ GJ2ANL,GSQANL,IGYANL
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /FRCONS/ FRGSTF(0:NDISOS,1:NDTWCE),
     *                FRGASK(0:NDISOS,1:NDTWCE),
     *                IFLFRG(0:NDISOS,1:NDTWCE),
     *                CLMFRA(0:NDISOS,1:NDTWCE),
     *                AVEFRA(0:NDISOS,1:NDTWCE)
      COMMON
     *       /QTWCNS/ STQTWC(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QTWCAS(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                IFLQTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                GALMTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
C
      DATA
     *       NONYES /'NON','   '/,
     *       NO_YES /' NO','YES','YES'/
      DATA
     *       IFTIMR /'(TIME-REVERSED STATE USED)',
     *               '                          ',
     *               '                          '/
      DATA
     *       KARDIR /'X','Y','Z'/
      DATA
     *       NAMINV /'                                           ',
     *               ' SPATIAL INVERSION OF ALL 3 COORDINATE AXES',
     *               ' TIME-REVERSAL (CC. PLUS INVERSION OF SPIN)',
     *               ' TIME-REVERSAL TIMES  THE SPATIAL INVERSION',
     *
     *               ' ROTATION BY PI ABOUT X AXIS  (X-SIGNATURE)',
     *               ' REFLECTION WRT THE  Y-Z  PLANE (X-SIMPLEX)',
     *               ' TIME-REVERSAL TIMES RX(PI) (X-SIGNATURE-T)',
     *               ' TIME-REVERSAL TIMES Y-Z REFL (X-SIMPLEX-T)',
     *
     *               ' ROTATION BY PI ABOUT Y AXIS  (Y-SIGNATURE)',
     *               ' REFLECTION WRT THE  X-Z  PLANE (Y-SIMPLEX)',
     *               ' TIME-REVERSAL TIMES RY(PI) (Y-SIGNATURE-T)',
     *               ' TIME-REVERSAL TIMES X-Z REFL (Y-SIMPLEX-T)',
     *
     *               ' ROTATION BY PI ABOUT Z AXIS  (Z-SIGNATURE)',
     *               ' REFLECTION WRT THE  X-Y  PLANE (Z-SIMPLEX)',
     *               ' TIME-REVERSAL TIMES RZ(PI) (Z-SIGNATURE-T)',
     *               ' TIME-REVERSAL TIMES X-Y REFL (Z-SIMPLEX-T)'/
      DATA
     *       N3LONA /'( LO )',' (NLO)','(N2LO)','(N3LO)'/
      DATA
     *       MINPLU /'-',' ','+'/
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                         1H*,77X,1H*,/,
     *                 1H*,1X,''NUCLIDE: N ='',I4,2X,''Z ='',I4,2X,
     *                        ''NUMBER OF ITERATIONS ='',I5,3X,
     *                        ''CONTINUATION? ='',I2,        2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *
     *    IN_FIX,IZ_FIX,NOITER,ICONTI
C
C=======================================================================
C
      IF (IN_FIX.EQ.0) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''ATTENTION! THIS RUN IS PERFORMED '',
     *                        ''WITHOUT ANY CALCULATIONS FOR '',
     *                        ''**NEUTRONS**'',2X,1H*,/,
     *                                                  1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IZ_FIX.EQ.0) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''ATTENTION!! THIS RUN IS PERFORMED '',
     *                        ''WITHOUT ANY CALCULATIONS FOR '',
     *                        ''**PROTONS**'',2X,1H*,/,
     *                                                  1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IBCONT.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''THE BASIS DEFORMATIONS READ '',
     *                        ''FROM THE BASIS FILE        '',
     *                        ''                   '',2X,1H*,/,
     *                                                  1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IPOTHO.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''HARMONIC-OSCILLATOR POTENTIAL IS '',
     *                        ''INCLUDED AS AN EXTERNAL FIELD '',
     *                        ''IN THIS RUN'',2X,1H*,/,
     *                                                  1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (EPSITE.GT.0.0) THEN
C
          IF (EPSITE.GE.1E-6.AND.EPSITE.LT.10) THEN
C
              WRITE(EPSITC,'(F8.6)')     EPSITE
          ELSE
              WRITE(EPSITC,'((1PE8.1))') EPSITE
C
          END IF
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''ITERATIONS WILL STOP WHEN THE '',
     *                        ''STABILITY BECOMES LOWER THAN EPSITE='',
     *                                                    A8,2X,1H*,/,
     *                 1H*,1X,''                              '',
     *                        ''             FOR'',I5,
     *                        '' CONSECUTIVE ITERATIONS'',   2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *
     *    EPSITC,NULAST
C
      END IF
C
C=======================================================================
C
      IF (NUCONS.GT.0) THEN
C
          IF (EPSCON.GE.1E-6.AND.EPSCON.LT.10) THEN
C
              WRITE(EPSITC,'(F8.6)')     EPSCON
          ELSE
              WRITE(EPSITC,'((1PE8.1))') EPSCON
C
          END IF
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''ITERATIONS WILL STOP WHEN '',
     *                        ''STABILITY STAYS CONSTANT WITHIN  '',
     *                                        A8,''*EPSITE'',2X,1H*,/,
     *                 1H*,1X,''                              '',
     *                        ''             FOR'',I5,
     *                        '' CONSECUTIVE ITERATIONS'',   2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *
     *    EPSITC,NUCONS
C
      END IF
C
C=======================================================================
C
      IF (EPSPNG.GT.0.0) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''ITERATIONS WILL STOP WHEN THE '',
     *                        ''PING-PONG DIVERGENCE OCCURS FOR '',
     *                        ''EPSPNG='',F5.3,2X,1H*,/,
     *                 1H*,1X,''                              '',
     *                        '' DURING'',I5,'' PAIRS OF'',
     *                        '' CONSECUTIVE ITERATIONS'',   2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *
     *    EPSPNG,NUPING
C
      END IF
C
C=======================================================================
C
      IF (NUCHAO.GT.0) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''ITERATIONS WILL STOP FOR '',
     *                        ''CHAOTIC-DIVERGENCE CONDITION OCCURING'',
     *                                        I5,''  TIMES'',2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *
     *    NUCHAO
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *                 1H*,1X,''SLOW-DOWN PARAMETERS: '',54X,1H*,/,
     *                 1H*,1X,''TIME-EVEN ='',    F5.2,3X,
     *                        ''TIME-ODD ='',     F5.2,3X,
     *                        ''PAIRING ='',      F5.2,3X,
     *                        ''LIPKIN-NOGAMI ='',F5.2,2X,   1H*,/,
     *                 1H*,1X,''DENSITY LN='',    F5.2,3X,
     *                        ''LIP-MASS ='',     F5.2,3X,
     *                        ''LIP-MOI ='',      F5.2,3X,
     *                        ''DENS MASS-MOI ='',F5.2,2X,   1H*,/,
     *                                               1H*,77X,1H*)')
     *
     *    SLOWEV,SLOWOD,SLOWPA,SLOWLI,SLOWLD,SLOWTP,SLOWRP,SLOWLM
C
C=======================================================================
C
      IF (I_SLOW.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''ALL MEAN FIELDS WILL BE SLOWED DOWN '',
     *                        ''SIMULTANEOUSLY, WITH THE FACTOR ='',
     *                                                  F5.2,2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *
     *    SLOWAL
C
      END IF
C
C=======================================================================
C
      IF (IBROYD.EQ.0) THEN
C
          WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *             ''* BROYDEN METHOD IS:  OFF'',53X,''*'',/,
     *             ''*'',77X,''*'',/,
     *             ''*    ITERATIONS WILL PROCEED BY STANDARD '',
     *             ''LINEAR MIXING WITH SLOWING FACTORS   *'',/,
     *             ''*    DISPLAYED EARLIER                         '',
     *             ''                               *'',/,
     *             ''*'',77X,''*'')')
C
      END IF
C
      IF (IBROYD.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *             ''* BROYDEN METHOD IS:  ON'',54X,''*'',/,
     *             ''*'',77X,''*'',/,''*    TRIGGERED ONLY WHEN '',
     *             ''STABILITY IS LOWER THAN : '',F9.3,
     *             '' MEV              *'',/,
     *             ''*    INITIAL SLOWING FACTOR (BEFORE TRIGGER)'',
     *             ''     :   '',F6.2,'' (=SLOWEV)         *'',/,
     *             ''*    BROYDEN SLOWING FACTOR (AFTER  TRIGGER)'',
     *             ''     :   '',F6.2,'' (=1-ALPHAM)       *'',/,
     *             ''*    NUMBER OF ITERATIONS RETAINED IN MEMORY'',
     *             ''     :    '',I2,''                      *'',/
     *             ''*'',77X,''*'')')
     *
     *               BROTRI,SLOWEV,1.0-ALPHAM,N_ITER
C
      END IF
C
      IF (MIXMAT.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *          1H*,'' MIXING OF MATRIX ELEMENTS OF HFB MATRIX'',
     *                                                  37X,1H*,/,
     *                                              1H*,77X,1H*)')
C
C=======================================================================
C
      IF (TEMP_T.GT.0.0)
     *    WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          1H*,'' CALCULATIONS WILL BE PERFORMED AT FINITE '',
     *              ''TEMPERATURE T = '',F6.3,'' MEV'',9X,''*'',/,
     *                                          ''*'',77X,''*'')')
     *                TEMP_T
C
C=======================================================================
C
      IF (IFNECK.EQ.2)
     *    WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *              ''* CALCULATIONS WILL BE PERFORMED WITH A '',
     *              ''CONSTRAINT ON THE SIZE OF THE NECK    *'',/,
     *              ''* THE NUMBER OF PARTICLES IN THE NECK '',
     *              ''IS SET TO: '',F8.4,21X,''*'',/,
     *                                          ''*'',77X,''*'')')
     *                Q0NECK
C
C=======================================================================
C
      IF (ICOUDI.EQ.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *          1H*,'' DIRECT COULOMB TERMS NEGLECTED IN THIS RUN'',
     *                                                  34X,1H*,/,
     *                                              1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ICOUDI.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *          1H*,'' DIRECT COULOMB TERMS SOLVED BY GREEN FUNCTION'',
     *              '' AND FOURIER TRANSFORM METHOD'',2X,1H*,/,
     *          1H*,'' COULOMB PARAMETERS:'',
     *          ''  NUMCOU ='',I3,  ''  NUMETA ='',I3,
     *          ''  BOUCOU ='',F5.1,''  FURMAX ='',F4.2, 2X,1H*,/,
     *                                              1H*,77X,1H*)')
     *
     *          NUMCOU,NUMETA,BOUCOU,FURMAX
C
C=======================================================================
C
      IF (ICOUDI.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *          1H*,'' DIRECT   COULOMB TERMS SOLVED BY EXPANDING'',
     *              '' POTENTIAL 1/R INTO'',I3,'' GAUSSIANS'',2X,1H*)')
     *
     *          IABS(ICOTYP)
C
          IF (ICOTYP.GT.0) THEN
C
              WRITE(NFIPRI,'(
     *          1H*,'' EXPANSION PARAMETERS CALCULATED BY USING '',
     *              '' THE  GAUSS-LEGENDRE  INTEGRATION'',2X,1H*,/,
     *                                               1H*,77X,1H*)')
          ELSE
              WRITE(NFIPRI,'(
     *          1H*,'' EXPLICIT EXPANSION PARAMETERS USED       '',
     *              ''                                 '',2X,1H*,/,
     *                                            1H*,77X,1H*)')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ICOUEX.EQ.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *          1H*,'' EXCHANGE COULOMB TERMS NEGLECTED IN THIS RUN'',
     *                                                  32X,1H*,/,
     *                                              1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ICOUEX.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *          1H*,'' EXCHANGE COULOMB TERMS TREATED BY THE'',
     *              '' SLATER APPROXIMATION'',          18X,1H*,/,
     *                                              1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ICOUEX.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *          1H*,'' EXCHANGE COULOMB TERMS SOLVED BY EXPANDING'',
     *              '' POTENTIAL 1/R INTO'',I3,'' GAUSSIANS'',2X,1H*)')
     *
     *          IABS(ICOTYP)
C
          IF (ICOTYP.GT.0) THEN
C
              WRITE(NFIPRI,'(
     *          1H*,'' EXPANSION PARAMETERS CALCULATED BY USING '',
     *              '' THE  GAUSS-LEGENDRE  INTEGRATION'',2X,1H*,/,
     *                                               1H*,77X,1H*)')
          ELSE
              WRITE(NFIPRI,'(
     *          1H*,'' EXPLICIT EXPANSION PARAMETERS USED       '',
     *              ''                                 '',2X,1H*,/,
     *                                            1H*,77X,1H*)')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (I_YUKA.GE.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGE VALUES OF THE TIME-REVERSAL-VIOLATING'',
     *             1X,'' YUKAWA  INTERACTION WILL BE'',        2X,1H*,/,
     *        1H*,13X,''CALCULATED USING THE PION MASS OF'',F8.4,
     *             1X,''FM^(-1),'',
     *             1X,''AND TYPE ='',I1,                       2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          PIMASS,IYUTYP
C
C=======================================================================
C
      IF (I_YUKA.GE.2) THEN
C
          IF (ABS(YUKAGT).GE.1E-4.OR.YUKAGT.EQ.0.0) THEN
              WRITE(YUKACT,'(''='',F6.4)') YUKAGT
          ELSE
              WRITE(YUKACT,'(A7)')        '<0.0001'
          END IF
C
          IF (ABS(YUKAG0).GE.1E-4.OR.YUKAG0.EQ.0.0) THEN
              WRITE(YUKAC0,'(''='',F6.4)') YUKAG0
          ELSE
              WRITE(YUKAC0,'(A7)')        '<0.0001'
          END IF
C
          IF (ABS(YUKAG1).GE.1E-4.OR.YUKAG1.EQ.0.0) THEN
              WRITE(YUKAC1,'(''='',F6.4)') YUKAG1
          ELSE
              WRITE(YUKAC1,'(A7)')        '<0.0001'
          END IF
C
          IF (ABS(YUKAG2).GE.1E-4.OR.YUKAG2.EQ.0.0) THEN
              WRITE(YUKAC2,'(''='',F6.4)') YUKAG2
          ELSE
              WRITE(YUKAC2,'(A7)')        '<0.0001'
          END IF
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''TIME-REVERSAL-VIOLATING YUKAWA  INTERACTION'',
     *             1X,''WILL BE ADDED BEFORE VARIATION'',      2X,1H*,/,
     *         1H*,1X,''FOR THE PION MASS OF'',F8.4,'','',
     *             1X,''NUCLEON MASS OF'',F8.4,'' FM^(-1),'',
     *             1X,''AND TYPE ='',I1,                       2X,1H*,/,
     *         1H*,1X,''TOGETHER WITH COUPLING CONSTANTS OF G'',A7,
     *                                                  '' G0'',A7,
     *                                                  '' G1'',A7,
     *                                                  '' G2'',A7,
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          PIMASS,PNMASS,IYUTYP,YUKACT,YUKAC0,YUKAC1,YUKAC2
C
          IF (I_YUKA.EQ.3)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE DIRECT TERMS OF THE YUKAWA'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',     10X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_YUKA.EQ.4)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE EXCHANGE TERMS OF THE YUKAWA'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      8X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IYCONT.EQ.1.AND.IFCONT.NE.1.AND.I_YUKA.GE.2)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''YUKAWA MEAN FIELDS WILL BE READ FROM DISC '',
     *             1X,''IN ORDER TO CONTINUE ITERATIONS'',    2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IYCONT.NE.1.AND.IFCONT.NE.1.AND.I_YUKA.GE.2)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''YUKAWA MEAN FIELDS WILL BE ZEROED BEFORE '',
     *             1X,''STARTING ITERATIONS FOR THIS RUN'',    2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IGCONT.EQ.1.AND.I_GOGA.GE.2.AND.NEWGOG.EQ.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''GOGNY  MEAN FIELDS WILL BE READ FROM DISC '',
     *             1X,''IN ORDER TO CONTINUE ITERATIONS'',    2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IGCONT.NE.1.AND.I_GOGA.GE.2.AND.NEWGOG.EQ.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''GOGNY  MEAN  FIELD WILL BE ZEROED BEFORE '',
     *             1X,''STARTING ITERATIONS FOR THIS RUN'',    2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IGPCON.EQ.1.AND.IGOGPA.GE.2.AND.NEWGOG.EQ.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''GOGNY PAIRING FIELD WILL BE READ FROM DISC '',
     *                ''IN ORDER TO CONTINUE ITERATIONS'',    1X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IGPCON.NE.1.AND.IGOGPA.GE.2.AND.NEWGOG.EQ.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''GOGNY PAIRING FIELD WILL BE ZEROED BEFORE'',
     *             1X,''STARTING ITERATIONS FOR THIS RUN'',    2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IECONT.EQ.1.AND.(I_REGA.GE.2.OR.I_GOGA.GE.2.AND.NEWGOG.EQ.1))
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''REGUL/GOGNY FIELDS WILL BE READ FROM DISC '',
     *             1X,''IN ORDER TO CONTINUE ITERATIONS'',    2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IECONT.NE.1.AND.(I_REGA.GE.2.OR.I_GOGA.GE.2.AND.NEWGOG.EQ.1))
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''REGUL/GOGNY FIELDS WILL BE ZEROED BEFORE '',
     *             1X,''STARTING ITERATIONS FOR THIS RUN'',    2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IFCONT.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''MEAN-FIELD MATRIX ELEMENTS WILL BE  READ '',
     *             1X,''FROM DISC TO CONTINUE ITERATIONS'',   2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IMCONT.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''THE AVERAGE LINEAR MOMENTA WILL BE  READ '',
     *             1X,''FROM DISC TO CONTINUE ITERATIONS'',   2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IRCONT.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''THE AVERAGE ANGULAR MOMENTA WILL BE READ '',
     *             1X,''FROM DISC TO CONTINUE ITERATIONS'',   2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (NEWCOU.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *      1H*,1X,''NEW IMPLEMENTATION OF CALCULATIONS WITH '',
     *             '' COULOMB  INTERACTION WILL BE USED'',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (I_COUA.EQ.1.AND.NEWCOU.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGE VALUES OF THE PARTICLE-HOLE COUL.'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      4X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (I_COUA.GE.2.AND.NEWCOU.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-HOLE COUL. INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',          11X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_COUA.EQ.3.AND.NEWCOU.EQ.1)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE DIRECT TERMS OF THE P-H COUL.'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',     7X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_COUA.EQ.4.AND.NEWCOU.EQ.1)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE EXCHANGE TERMS OF THE P-H COUL.'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      5X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (ICOUPA.EQ.1.AND.NEWCOU.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGES OF THE PARTICLE-PARTICLE COUL.'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      6X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ICOUPA.EQ.2.AND.NEWCOU.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-PARTICLE COUL. INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',           7X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (NEWGOG.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *      1H*,1X,''NEW IMPLEMENTATION OF CALCULATIONS WITH '',
     *             ''THE GOGNY INTERACTION WILL BE USED'',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (I_GOGA.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGE VALUES OF THE PARTICLE-HOLE GOGNY'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      4X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (I_GOGA.GE.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-HOLE GOGNY INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',          11X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_GOGA.EQ.3)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE DIRECT TERMS OF THE P-H GOGNY'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',     7X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_GOGA.EQ.4)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE EXCHANGE TERMS OF THE P-H GOGNY'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      5X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IGOGPA.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGES OF THE PARTICLE-PARTICLE GOGNY'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      6X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IGOGPA.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-PARTICLE GOGNY INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',           7X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IGOGPA.GE.3) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-PARTICLE GOGNY INTERACTION'',
     *             1X,''CALCULATED BY AN ALTERNATIVE METHOD'', 5X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (I_REGA.GE.1) THEN
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''REGULARIZED FINITE-RANGE INTERACTION WILL BE'',
     *             1X,''USED UP TO ORDER'',I2,1X,A6,    6X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *    2*ABS(N3LORD),N3LONA(ABS(N3LORD)+1)
C
          IF (N3LORD.LT.0)
     *        WRITE(NFIPRI,'(
     *        1H*, 1X,''THE COMPLETE FINITE-RANGE PSEUDOPOTENTIAL'',
     *             1X,''WILL BE USED'',                       22X,1H*,/,
     *                                                    1H*,77X,1H*)')
      END IF
C
C=======================================================================
C
      IF (I_REGA.GE.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-HOLE REGULARIZED INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',           5X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_REGA.EQ.3)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE DIRECT TERMS OF P-H REGULARIZED'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',     5X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_REGA.EQ.4)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE EXCHANGE TERMS OF P-H REGULARIZED'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      3X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IREGPA.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGES OF PARTICLE-PARTICLE REGULARIZED'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      4X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IREGPA.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-PARTICLE REGULARIZED INTERACTION'',
     *             1X,''WILL BE TREATED SELF-CONSISTENTLY'',   1X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (I_SEPA.GE.1) THEN
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''SEPARABLE  FINITE-RANGE  INTERACTION WILL BE'',
     *             1X,''USED UP TO ORDER'',I2,1X,A6,    6X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *    2*ABS(N3SERD),N3LONA(ABS(N3SERD)+1)
C
      END IF
C
C=======================================================================
C
      IF (I_SEPA.GE.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-HOLE  SEPARABLE  INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',           5X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_SEPA.EQ.3)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE DIRECT TERMS OF P-H  SEPARABLE '',
     *             1X,''INTERACTION WILL BE CONSIDERED'',     5X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          IF (I_SEPA.EQ.4)
     *
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE EXCHANGE TERMS OF P-H  SEPARABLE '',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      3X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (ISEPPA.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGES OF PARTICLE-PARTICLE  SEPARABLE '',
     *             1X,''INTERACTION WILL BE CALCULATED'',      4X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ISEPPA.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-PARTICLE  SEPARABLE  INTERACTION'',
     *             1X,''WILL BE TREATED SELF-CONSISTENTLY'',   1X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (I_FSTA(1).GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGE VALUES OF THE PARTICLE-HOLE FR-SO'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      4X,1H*)')
C
          IF (I_FSTA(1).GE.2) THEN
C
              WRITE(NFIPRI,'(                             1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-HOLE FR-SO INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',          11X,1H*)')
C
              IF (I_FSTA(1).EQ.3)
     *        WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE DIRECT TERMS OF THE P-H FR-SO'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      7X,1H*)')
C
              IF (I_FSTA(1).EQ.4)
     *        WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE EXCHANGE TERMS OF THE P-H FR-SO'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      5X,1H*)')
C
          END IF
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IFSTPA(1).GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGES OF THE PARTICLE-PARTICLE FR-SO'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      6X,1H*)')
C
          IF (IFSTPA(1).EQ.2)
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''PARTICLE-PARTICLE FR-SO INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',           7X,1H*)')
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (I_FSTA(2).GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGE VALUES OF THE PARTICLE-HOLE FR-TO'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      4X,1H*)')
C
          IF (I_FSTA(2).GE.2) THEN
C
              WRITE(NFIPRI,'(                             1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-HOLE FR-TO INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',          11X,1H*)')
C
              IF (I_FSTA(2).EQ.3)
     *        WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE DIRECT TERMS OF THE P-H FR-TO'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      7X,1H*)')
C
              IF (I_FSTA(2).EQ.4)
     *        WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE EXCHANGE TERMS OF THE P-H FR-TO'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      5X,1H*)')
C
          END IF
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IFSTPA(2).GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGES OF THE PARTICLE-PARTICLE FR-TO'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      6X,1H*)')
C
          IF (IFSTPA(2).EQ.2)
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''PARTICLE-PARTICLE FR-TO INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',           7X,1H*)')
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (I_FSTA(3).GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGE VALUES OF THE PARTICLE-HOLE FR-TE'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      4X,1H*)')
C
          IF (I_FSTA(3).GE.2) THEN
C
              WRITE(NFIPRI,'(                             1H*,77X,1H*,/,
     *         1H*,1X,''PARTICLE-HOLE FR-TE INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',          11X,1H*)')
C
              IF (I_FSTA(3).EQ.3)
     *        WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE DIRECT TERMS OF THE P-H FR-TE'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      7X,1H*)')
C
              IF (I_FSTA(3).EQ.4)
     *        WRITE(NFIPRI,'(
     *         1H*,1X,''ONLY THE EXCHANGE TERMS OF THE P-H FR-TE'',
     *             1X,''INTERACTION WILL BE CONSIDERED'',      5X,1H*)')
C
          END IF
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IFSTPA(3).GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *        1H*, 1X,''AVERAGES OF THE PARTICLE-PARTICLE FR-TE'',
     *             1X,''INTERACTION WILL BE CALCULATED'',      6X,1H*)')
C
          IF (IFSTPA(3).EQ.2)
     *    WRITE(NFIPRI,'(
     *         1H*,1X,''PARTICLE-PARTICLE FR-TE INTERACTION WILL BE'',
     *             1X,''TREATED SELF-CONSISTENTLY'',           7X,1H*)')
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IDIQGA.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''GAUSSIAN FORCES IN THE   DIRECT CHANNEL '',
     *             1X,''CUT AT EIGENVALUES LAMBDA >'',(1PE8.1),1X,1H*,/,
     *         1H*,1X,''GAUSSIAN FORCES IN THE EXCHANGE CHANNEL '',
     *             1X,''CUT AT EIGENVALUES LAMBDA >'',(1PE8.1),1X,1H*,/,
     *         1H*,1X,''GAUSSIAN FORCES IN THE  PAIRING CHANNEL '',
     *             1X,''CUT AT EIGENVALUES LAMBDA >'',(1PE8.1) 1X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *    DIQCOD,DIQCOE,DIQCOP
C
      END IF
C
C=======================================================================
C
      IF (IDOTHC.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''THE TENSOR HYPERCONTRACTION METHOD WILL BE '',
     *             1X,''USED TO TREAT FINITE RANGE'',          6X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                           1H*,77X,1H*,/,
     *          1H*, 1X,''MAXIMUM NUMBERS OF MULTIPOLE MOMENTS USED'',
     *               1X,''FOR THE CONSTRAINTS,    NMUCON='',I1,2X,1H*,/,
     *          1H*,43X,''FOR THE COULOMB FIELD,  NMUCOU='',I1,2X,1H*,/,
     *          1H*,43X,''FOR THE OUTPUT INFO,    NMUPRI='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          NMUCON,NMUCOU,NMUPRI
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLAGQ(LAMBDA,MIU).EQ.1) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''MULTIPOLE CONSTRAINTS: '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,QASKED(LAMBDA,MIU),STIFFQ(LAMBDA,MIU)
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(1H*,1X,''                       '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,QASKED(LAMBDA,MIU),STIFFQ(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLAGV(LAMBDA,MIU).EQ.1) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''ISOVECT. MULT. CONSTR. '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,VASKED(LAMBDA,MIU),STIFFV(LAMBDA,MIU)
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(1H*,1X,''                       '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,VASKED(LAMBDA,MIU),STIFFV(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IABS(IFLAGQ(LAMBDA,MIU)).EQ.1.AND.INPOME.EQ.7) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''MULTIPL. FOR HO BASIS: '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,QASKED(LAMBDA,MIU),STIFFQ(LAMBDA,MIU)
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(1H*,1X,''                       '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,QASKED(LAMBDA,MIU),STIFFQ(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALQ(LAMBDA,MIU).EQ.-1) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''LINEAR MULTIPOLE CONSTRAINTS: '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PAR. '',
     *                           ''USED='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,QLINEA(LAMBDA,MIU)
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(
     *                    1H*,1X,''                              '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PAR. '',
     *                           ''USED='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,QLINEA(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
C=======================================================================
C            ATTENTION: IN VERSIONS FROM 2.49N TO 2.66A,  THE  CONDITION
C                       BELOW WAS DEPENDING  ON  "ICONTI"  AND  NOT   ON
C                       "IACONT" AND THUS FOR ICONTI=1 AND IACONT=0  THE
C                       INITIALIZED LAGRANGE PARAMETERS WERE NOT PRINTED
C                       THIS BUG WAS CORRECTED ON 30/07/2013 IN  VERSION
C                       (2.66B).
C=======================================================================
C
            IF (IFLALQ(LAMBDA,MIU).EQ.1.AND.IACONT.NE.1) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''AUGMENTED MULTIPOLE CONSTRAINTS: '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''INIT. LAGR. '',
     *                           ''PAR='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,QLINEA(LAMBDA,MIU)
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(
     *                    1H*,1X,''                                 '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''INIT. LAGR. '',
     *                           ''PAR='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,QLINEA(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALV(LAMBDA,MIU).EQ.-1) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''LINEAR ISOV MULT CONSTRAINTS: '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PAR. '',
     *                           ''USED='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,VLINEA(LAMBDA,MIU)
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(
     *                    1H*,1X,''                              '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PAR. '',
     *                           ''USED='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,VLINEA(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALV(LAMBDA,MIU).EQ.1.AND.IACONT.NE.1) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''AUGMENTED ISOV MULT CONSTRAINTS: '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''INIT. LAGR. '',
     *                           ''PAR='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,VLINEA(LAMBDA,MIU)
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(
     *                    1H*,1X,''                                 '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''INIT. LAGR. '',
     *                           ''PAR='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,VLINEA(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IF_RPA.EQ.1) THEN
          WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *            ''* THE LAGRANGE PARAMETERS OF THE LINEAR '',
     *            ''CONSTRAINTS ARE RE-ADJUSTED AT EACH   *'',/,
     *            ''* ITERATION BY USING THE CRANKING APPROXIMATION'',
     *            '' OF THE RPA MATRIX             *'',/,
     *            ''*'',77X,''*'')')
      END IF
C
C=======================================================================
C
      IF (IACONT.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''THE LAG. LINEAR CONSTRAINTS WILL BE READ '',
     *             1X,''FROM DISC TO CONTINUE ITERATIONS'',   2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ISCONT.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''THE LAGRA. SPIN CONSTRAINTS WILL BE READ '',
     *             1X,''FROM DISC TO CONTINUE ITERATIONS'',   2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ITCONT.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *         1H*,1X,''THE LAG ISOSPIN CONSTRAINTS WILL BE READ '',
     *             1X,''FROM DISC TO CONTINUE ITERATIONS'',   2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (NSIMAX.GT.0) THEN
C
          IF (ISCHIF.GE.1) THEN
C
              IF (ISCHIF.EQ.1)
     *        WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *          1H*, 1X,''MAXIMUM NUMBERS OF SCHIFF MOMENTS USED:  '',
     *               1X,''FOR THE CONSTRAINTS,    NSICON='',I1,2X,1H*,/,
     *          1H*,43X,''FOR THE OUTPUT INFO,    NSIPRI='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          NSICON,NSIPRI
C
              IF (ISCHIF.EQ.2)
     *        WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *          1H*, 1X,''MAXIMUM NUMBERS OF SCHIFF MOMENTS USED:  '',
     *               1X,''FOR PROJECTED STATES,   NSIPRI='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          NSIPRI
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *          1H*, 1X,''MAXIMUM NUMBERS OF SURFACE MOMENTS USED: '',
     *               1X,''FOR THE CONSTRAINTS,    NSICON='',I1,2X,1H*,/,
     *          1H*,43X,''FOR THE OUTPUT INFO,    NSIPRI='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          NSICON,NSIPRI
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (NSIMAX.GT.0.AND.IDOPLM.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *          1H*, 1X,''MAXIMUM NUMBERS OF PENSURFACE MOMENTS USED:'',
     *               1X,''FOR THE OUTPUT INFO,  NSIPRI='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          NSIPRI
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NSICON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLAGS(LAMBDA,MIU).GT.0) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
                    IF (IFLAGS(LAMBDA,MIU).EQ.2)
     *                  WRITE(NFIPRI,'(1H*,1X,
     *                           ''FOR NEUTRONS WE USE:'')')
C
                    IF (IFLAGS(LAMBDA,MIU).EQ.3)
     *                  WRITE(NFIPRI,'(1H*,1X,
     *                           ''FOR PROTONS WE USE:'')')
C
                    IF (ISCHIF.EQ.1) THEN
C
                        WRITE(NFIPRI,'(1H*,1X,
     *                           ''SCHIFF  CONSTRAINTS:   '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *                  LAMBDA,MIU,SASKED(LAMBDA,MIU),STIFFS(LAMBDA,MIU)
C
                    ELSE
C
                        WRITE(NFIPRI,'(1H*,1X,
     *                           ''SURFACE CONSTRAINTS:   '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *                  LAMBDA,MIU,SASKED(LAMBDA,MIU),STIFFS(LAMBDA,MIU)
C
                    END IF
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(1H*,1X,''                       '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''MOMENT='',F7.3,2X,
     *                           ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,SASKED(LAMBDA,MIU),STIFFS(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NSICON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALS(LAMBDA,MIU).LT.0) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
                    IF (IFLALS(LAMBDA,MIU).EQ.-2)
     *                  WRITE(NFIPRI,'(1H*,1X,
     *                           ''FOR NEUTRONS WE USE:'')')
C
                    IF (IFLALS(LAMBDA,MIU).EQ.-3)
     *                  WRITE(NFIPRI,'(1H*,1X,
     *                           ''FOR PROTONS WE USE:'')')
C
                    IF (ISCHIF.EQ.1) THEN
C
                        WRITE(NFIPRI,'(1H*,1X,
     *                           ''LINEAR SCHIFF  CONSTRAINTS:   '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PAR. '',
     *                           ''USED='',F6.3,     2X,1H*)')
     *
     *                  LAMBDA,MIU,SLINEA(LAMBDA,MIU)
C
                    ELSE
C
                        WRITE(NFIPRI,'(1H*,1X,
     *                           ''LINEAR SURFACE CONSTRAINTS:   '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PAR. '',
     *                           ''USED='',F6.3,     2X,1H*)')
     *
     *                  LAMBDA,MIU,SLINEA(LAMBDA,MIU)
C
                    END IF
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(1H*,1X,
     *                       ''                              '',
     *                       ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                       ''LAGRANGE PAR. '',
     *                       ''USED='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,SLINEA(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NSICON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALS(LAMBDA,MIU).GT.0) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
                    IF (IFLALS(LAMBDA,MIU).EQ.2)
     *                  WRITE(NFIPRI,'(1H*,1X,
     *                           ''FOR NEUTRONS WE USE:'')')
C
                    IF (IFLALS(LAMBDA,MIU).EQ.3)
     *                  WRITE(NFIPRI,'(1H*,1X,
     *                           ''FOR PROTONS WE USE:'')')
C
                    IF (ISCHIF.EQ.1) THEN
C
                        WRITE(NFIPRI,'(1H*,1X,
     *                           ''AUGMENTED SCHIFF  CONSTRAINTS:   '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''INIT. LAGR. '',
     *                           ''PAR='',F6.3,     2X,1H*)')
     *
     *                  LAMBDA,MIU,SLINEA(LAMBDA,MIU)
C
                    ELSE
C
                        WRITE(NFIPRI,'(1H*,1X,
     *                           ''AUGMENTED SURFACE CONSTRAINTS:   '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''INIT. LAGR. '',
     *                           ''PAR='',F6.3,     2X,1H*)')
     *
     *                  LAMBDA,MIU,SLINEA(LAMBDA,MIU)
C
                    END IF
C
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(1H*,1X,
     *                       ''                                 '',
     *                       ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                       ''INIT. LAGR. '',
     *                       ''PAR='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,SLINEA(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
C
         IF (IFLAGG(LAMBDA).EQ.1) THEN
C
             IF (ITITLE.EQ.0) THEN
C
                 WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                 1H*,1X,''SCALAR MULTIPOLE CONSTRAINTS:  '',
     *                        ''LAMBDA='',I2,2X,
     *                        ''MOMENT='',F7.3,2X,
     *                        ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *           LAMBDA,GASKED(LAMBDA),STIFFG(LAMBDA)
C
                 ITITLE=1
C
             ELSE
C
                 WRITE(NFIPRI,'(
     *                 1H*,1X,''                               '',
     *                        ''LAMBDA='',I2,2X,
     *                        ''MOMENT='',F7.3,2X,
     *                        ''STIFFNESS='',F6.3,     2X,1H*)')
     *
     *           LAMBDA,GASKED(LAMBDA),STIFFG(LAMBDA)
C
             END IF
C
         END IF
C
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      IF (NMAMAX.GT.0) THEN
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *          1H*, 1X,''MAXIMUM NUMBERS OF MAGNETIC MOMENTS USED:'',
     *               1X,''FOR THE CONSTRAINTS,    NMACON='',I1,2X,1H*,/,
     *          1H*,43X,''FOR THE OUTPUT INFO,    NMAPRI='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          NMACON,NMAPRI
C
          IF (NMAORD.GT.0)
     *        WRITE(NFIPRI,'(
     *          1H*, 1X,''RADIAL MOMENTS OF MAGNETIC MOMENTS EVALUAT'',
     *                  ''ED UP TO THE ORDER OF 2*NMAORD='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          2*NMAORD
C
          IF (MAXVAL(MAG2BC).GE.1) THEN
C
              IF (PIMASS.LT.100) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,1H*,1X,
     *              ''TWO-BODY-CURRENT CONTRIBUTIONS TO THE MAGNETIC '',
     *              ''MOMENTS FOR PIMASS='',F8.4             ,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *            PIMASS
              ELSE
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,1H*,1X,
     *              ''TWO-BODY-CURRENT CONTRIBUTIONS TO THE MAGNETIC '',
     *              ''MOMENTS FOR PIMASS='',(1PE8.1)         ,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *            PIMASS
C
              END IF
C
              DO IFO2BC=1,NDF2BC
C
                 IF (MAG2BC(IFO2BC).EQ.1) THEN
                     NOORYE=NO_YES(1)
                 ELSE
                     NOORYE=NO_YES(0)
                 END IF
C
                 IF (IFO2BC.LE.2) THEN

                     WRITE(NFIPRI,'(
     *               1H*,11X,''FORMFACTOR NUMBER'',I2,'' (INTRINSIC'',
     *                      '' TERM) EXCHANGE TERM= '',A3,11X,1H*)')
     *               IFO2BC,NOORYE
                 ELSE
                     WRITE(NFIPRI,'(
     *               1H*,11X,''FORMFACTOR NUMBER'',I2,'' (SACHS    '',
     *                      '' TERM) EXCHANGE TERM= '',A3,11X,1H*)')
     *               IFO2BC,NOORYE
C
                 END IF

              END DO
C
              WRITE(NFIPRI,'(1H*,77X,1H*)')
C
          END IF

      END IF
C
C=======================================================================
C
      IF (MAXVAL(MAGANL).GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
          DO IFOANL=1,NDFANL
C
             IF (MAGANL(IFOANL).EQ.1) THEN
C
                 IF (IFOANL.EQ.1) WRITE(NFIPRI,'(
     *               1H*,1X,''THE R^2*J-TERM OF THE ANAPOLE MOMENT '',
     *                      ''WILL BE CALCULATED FOR THE G FACTOR OF'',
     *                        F6.3,1X)')
     *               GJ2ANL
C
                 IF (IFOANL.EQ.2) WRITE(NFIPRI,'(
     *               1H*,1X,''THE SPINQ-TERM OF THE ANAPOLE MOMENT '',
     *                      ''WILL BE CALCULATED FOR THE G FACTOR OF'',
     *                        F6.3,1X)')
     *               GSQANL
C
             END IF

          END DO
C
          WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      END IF

C=======================================================================
C
      IF (NASMAX.GT.0) THEN
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *          1H*, 1X,''MAXIMUM NUMBERS OF SPIN-ASYMM MOMTS USED:'',
     *               1X,''FOR THE CONSTRAINTS,    NASCON='',I1,2X,1H*,/,
     *          1H*,43X,''FOR THE OUTPUT INFO,    NASPRI='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          NASCON,NASPRI
C
          IF (NASORD.GE.0)
     *        WRITE(NFIPRI,'(
     *          1H*, 1X,''RADIAL MOMENTS OF SPIN-ASYMM MOMTS EVALUAT'',
     *                  ''ED UP TO THE ORDER OF 2*NASORD='',I1,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          2*NASORD
C
      END IF
C
C=======================================================================
C
      IF (NRAORD.GT.0)
     *    WRITE(NFIPRI,'(
     *      1H*, 1X,''HIGHER MOMENTS OF  RADII  WILL  BE EVALUAT'',
     *              ''ED UP TO THE ORDER OF 2*NRAORD='',I1,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *      2*NRAORD
C
C=======================================================================
C
      IF (IGYROS.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*, 1X,''EFFECTIVE GYROSCOPIC FACTORS USED: '',
     *                  '' ORBIT_P='',F4.2,
     *                  ''  SPIN_N='',F4.2,
     *                  ''  SPIN_P='',F4.2,                   2X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *          GYRORP,GYRSPN,GYRSPP
C
C=======================================================================
C
      IF (IGY2BC.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*, 1X,''TWO-BODY-CURRENT EFFECTIVE GYROSCOPIC '',
     *                  '' FACTORS: INTRINSIC='',F4.2,
     *                  ''   SACHS='',F4.2,                   2X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *          GIN2BC,GSA2BC
C
C=======================================================================
C
      IF (IRENMA.GE.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*, 1X,''NUCLEON MASS RENORMALIZED IRENMA='',I2,
     *                  ''  DISTAX='',F4.2,
     *                  ''  DISTAY='',F4.2,
     *                  ''  DISTAZ='',F4.2,                   2X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *          IRENMA,DISTAX,DISTAY,DISTAZ
C
C=======================================================================
C
      IF (IRENIN.GE.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*, 1X,''NUCLEAR INERTIA RENORMLZD IRENIN='',I2,
     *                  ''  ROTATX='',F4.2,
     *                  ''  ROTATY='',F4.2,
     *                  ''  ROTATZ='',F4.2,                   2X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *          IRENIN,ROTATX,ROTATY,ROTATZ
C
C=======================================================================
C
      IF (JETACM.EQ.2) THEN
C
          IF (IMCONT.EQ.1.AND.IRENMA.GE.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *         1H*,1X,''RENORMALIZED NUCLEON MASS WILL BE  READ  '',
     *             1X,''FROM DISC TO CONTINUE ITERATIONS'',   2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *          1H*,'' NUCLEON MASS RENORMALIZATION'',
     *              '' INITIALIZED WITH FACTORS'',
     *              '' X='',F4.2,
     *              '' Y='',F4.2,
     *              '' Z='',F4.2,                             2X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *          (HBMRIN(KARTEZ),KARTEZ=1,NDKART)
C
          END IF
C
          IF (ABS(ITWOLI).NE.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,'' TWO-BODY TRANSLATIONAL CORRECTION'',
     *              '' WILL BE INCLUDED WITHOUT LINEAR TERMS'',
     *                                                        5X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          IF (ITWOLI.EQ.-1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,'' TWO-BODY TRANSLATIONAL CORRECTION'',
     *              '' INCLUDED IRRESPECTIVE OF SYMMETRIES'',
     *                                                        7X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
      END IF
C=======================================================================
C
      IF ((IRENMA.GE.1.OR.IRENIN.GE.1).AND.IDOGOA.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,'' THE GAUSSIAN-OVERLAP APPROXIMATION'',
     *              '' WILL BE USED                 '',
     *                                                       12X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
C=======================================================================
C
      IF (KETA_R.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,'' TWO-BODY ROTATIONAL CORRECTION'',
     *              '' WILL BE INCLUDED AFTER VARIATION'',
     *                                                       13X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
      IF (KETA_R.EQ.2)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,'' TWO-BODY ROTATIONAL CORRECTION'',
     *              '' WILL BE INCLUDED BEFORE VARIATION'',
     *                                                       12X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
C=======================================================================
C
      IF (KETA_R.EQ.2) THEN
C
          IF (IRCONT.EQ.1.AND.IRENIN.GE.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *         1H*,1X,''RENORMALIZED NUCLEAR INERT. WILL BE READ '',
     *             1X,''FROM DISC TO CONTINUE ITERATIONS'',   2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *          1H*,'' NUCLEAR INERTIA RENORMALIZATION'',
     *              '' INITLZED WITH FACTORS'',
     *              '' X='',F4.2,
     *              '' Y='',F4.2,
     *              '' Z='',F4.2,                             2X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *          (ROTRIN(KARTEZ),KARTEZ=1,NDKART)
C
          END IF
C
          IF (ABS(ITWOLI).NE.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,'' TWO-BODY ROTATIONAL CORRECTION'',
     *              '' WILL BE INCLUDED WITHOUT LINEAR TERMS'',
     *                                                        8X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          IF (ITWOLI.EQ.-1)
     *    WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,'' TWO-BODY ROTATIONAL CORRECTION'',
     *              '' INCLUDED IRRESPECTIVE OF SYMMETRIES'',
     *                                                       10X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
      END IF
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING THE RESULTS FOR THE FOLLOWING '',
     *                    ''ITERATIONS:'',9X,
     *                           ''THE  FIRST: '',A3,      2X,1H*,/,
     *            1H*,60X,       ''THE MIDDLE: '',A3,      2X,1H*,/,
     *            1H*,53X,''AND/OR THE   LAST: '',A3,      2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *    NO_YES(IPRSTA),NO_YES(IPRMID),NO_YES(IPRSTO)
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING THE MOMENTS, RADII, AND DEFORM'',
     *                    ''ATIONS FOR:'',11X,
     *                             ''NEUTRONS: '',A3,      2X,1H*,/,
     *            1H*,62X,         ''PROTONS : '',A3,      2X,1H*,/,
     *            1H*,62X,         ''MASS    : '',A3,      2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *    NO_YES(IPRI_N),NO_YES(IPRI_P),NO_YES(IPRI_T)
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING THE MOMENTS, MOMENTA AND DEFORM'',
     *                    ''ATIONS IN THE INTRINSIC FRAME: '',A3,
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *    NO_YES(INTRIP)
C
C=======================================================================
C
      IF (IVIPRI.EQ.1) WRITE(NFIPRI,'(79(1H*),/,      1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING INTEGRALS OF SCALAR SYMMETRY-V'',
     *                    ''IOLATING TERMS:                 YES'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IVIPRI.EQ.2) WRITE(NFIPRI,'(79(1H*),/,      1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING INTEGRALS OF SCALAR AND VECTOR '',
     *                    ''SYMMETRY-VIOLATING TERMS:      YES'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                           1H*,77X,1H*,/,
     *      1H*,1X,''NILSSON LABELS OF SINGLE-PARTICLE STATES '',
     *             ''SHOWN WITH RESPECT TO THE: '',A1,''-AXIS'',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *      KARDIR(NILXYZ)
C
C=======================================================================
C
      IF (IQUNIL.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *      1H*,1X,''NILSSON LABELS OF SINGLE-QUASIPARTICLE STATES '',
     *             ''PRINTED NEXT TO THE SPECTRUM'',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (INUNIL.GT.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *      1H*,1X,''NILSSON LABELS OF SINGLE-PARTICLE STATES '',
     *             ''SHOWN FOR'',I4,''  LARGEST COMPONENTS'',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *      INUNIL
C
C=======================================================================
C
      IF (IPAHFB.LT.1.OR.ITWOBA.EQ.1.OR.IMFHFB.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *            1H*, 1X,''NUMBERS OF LEVELS IN TIME-REVERSAL/CH'',
     *                    ''ARGE  BLOCKS:     TIME-UP   TIME-DOWN'',
     *                                                     2X,1H*,/,
     *            1H*,42X,       ''NEUTRONS:'',5X,I5,6X,I5,5X,1H*,/,
     *            1H*,42X,       '' PROTONS:'',5X,I5,6X,I5,5X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *    ((NUMBSP(IREVER,ICHARG),IREVER=0,NDREVE),
     *                            ICHARG=0,NDISOS)
C
C=======================================================================
C
      IF (IADBAT.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *      1H*,1X,''THE ADIABATIC METHOD WILL BE USED        '',
     *             ''                                 '',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ITWCEN.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *      1H*,1X,''SINGLE CENTER BASIS WILL BE USED         '',
     *             ''                                 '',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
      IF (ITWCEN.EQ.2)
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *      1H*,1X,''TWO-CENTER BASIS WILL BE USED            '',
     *             ''                                 '',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      IF (ITWCEN.EQ.2) THEN
C
          DO ICHARG=1,NDISOS
             DO LTWCEN=1,NDTWCE
C
                IF (ITITLE.EQ.0) THEN
C
                    IF (IFLFRG(ICHARG,LTWCEN).EQ.1.OR.
     *                  IFLFRG(ICHARG,LTWCEN).EQ.3) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *      1H*,1X,''BASES ADAPTED TO THE REQUESTED DISTRIBUTION'',
     *             ''                               '',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
                        ITITLE=1
C
                    END IF
C
                END IF
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      ITITLE=0
C
      IF (ITWCEN.EQ.2) THEN
C
          DO ICHARG=0,NDISOS
             DO LTWCEN=1,NDTWCE
C
                 IF (IFLFRG(ICHARG,LTWCEN).EQ.1.OR.
     *               IFLFRG(ICHARG,LTWCEN).EQ.2) THEN
C
                     IF (ITITLE.EQ.0) THEN
C
                         WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                 1H*,1X,''PARTICLE DISTRIBUTION CONSTR:  '',
     *                        ''MCHARG='',I2,2X,
     *                        ''REQUESTED='',F6.3,2X,
     *                        ''FRAGMENT='',I2,     5X,1H*)')
     *
     *                   ICHARG,FRGASK(ICHARG,LTWCEN),LTWCEN
C
                         ITITLE=1
C
                     ELSE
C
                         WRITE(NFIPRI,'(
     *                     1H*,1X,''                               '',
     *                        ''MCHARG='',I2,2X,
     *                        ''REQUESTED='',F6.3,2X,
     *                        ''FRAGMENT='',I2,     5X,1H*)')
     *
     *                   ICHARG,FRGASK(ICHARG,LTWCEN),LTWCEN
C
                     END IF
C
                 END IF
C
             END DO
          END DO
C
      END IF
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      IF (ITWCEN.EQ.2) THEN
C
          DO LTWCEN=1,NDTWCE
             DO LAMBDA=1,NMUCON
                DO MIU=-LAMBDA,LAMBDA
C
                   IF (IFLQTW(LAMBDA,MIU,LTWCEN).EQ.1) THEN
C
                   IF (ITITLE.EQ.0) THEN
C
                       WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                       1H*,1X,''FRAGMENT MULTIP CONST: '',
     *                              ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                              ''MOMENT='',F7.3,2X,
     *                              ''FRAGMENT ='',I2,     6X,1H*)')
     *
     *                 LAMBDA,MIU,QTWCAS(LAMBDA,MIU,LTWCEN),LTWCEN
C
                       ITITLE=1
C
                   ELSE
C
                       WRITE(NFIPRI,'(1H*,2X,''                      '',
     *                              ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                              ''MOMENT='',F7.3,2X,
     *                              ''FRAGMENT ='',I2,     6X,1H*)')
     *
     *                 LAMBDA,MIU,QTWCAS(LAMBDA,MIU,LTWCEN),LTWCEN
C
                   END IF
C
                   END IF
C
                END DO
             END DO
          END DO
C
      END IF
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH THE PN MIXING FOR '',
     *                        ''THE ISOVECTOR FERMI ENERGIES OF:'',
     *                                                     8X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,1X,''FE_RAD='',F10.6,
     *                     2X,''FE_THE='',F10.6,
     *                     2X,''FE_PHI='',F10.6,
     *                     2X,''FE_OFF='',F10.6,           2X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,1X,''FERMIX='',F10.6,
     *                     2X,''FERMIY='',F10.6,
     *                     2X,''FERMIZ='',F10.6,
     *                     2X,''FERMI ='',F10.6,           2X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,1X,''AND THE ISOSCALAR FERMI ENERGY OF:'',
     *                    23X,''FERMI0='',F10.6,           2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *    FE_RAD,FE_THE,FE_PHI,FE_OFF,
     *    FERISO(1),FERISO(2),FERISO(3),
     *    SQRT(FERISO(1)**2+FERISO(2)**2+FERISO(3)**2),
     *    FERISO(0)
C
          IF (IPAHFB.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH THE PN MIXING AND '',
     *                        ''PAIRING CORRELATIONS INCLUDED   '',
     *                                                1H*,77X,1H*)')
          END IF
C
          IF (IFLAGT(1).NE.0.OR.IFLAGT(2).NE.0.OR.IFLAGT(3).NE.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*,1X,''CALCULATIONS WITH QUADRATIC '',
     *                       ''CONSTRAINT ON ISOSPIN:'',  26X,1H*,/,
     *                                                1H*,77X,1H*)')
              IF (IFLAGT(1).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''X-DIRECT: ISOSPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKEDT(1),STIFFT(1)
C
              IF (IFLAGT(2).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Y-DIRECT: ISOSPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKEDT(2),STIFFT(2)
C
              IF (IFLAGT(3).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Z-DIRECT: ISOSPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKEDT(3),STIFFT(3)
C
              WRITE(NFIPRI,'(                         1H*,77X,1H*)')
C
          END IF
C
          IF (IFLALT(1).EQ.1.OR.IFLALT(2).EQ.1.OR.IFLALT(3).EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*,1X,''CALCULATIONS WITH AUGMENTED '',
     *                       ''CONSTRAINT ON ISOSPIN:'',  26X,1H*,/,
     *                                                1H*,77X,1H*)')
              IF (IFLALT(1).EQ.1.AND.ITCONT.NE.1)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''X-DIRECTION: INITIAL CORRECTION '',
     *                       ''TO THE ISOVECTOR FERMI ENERGY IS:'',
     *                                                F9.5,2X,1H*)')
     *            DALISO(1)
C
              IF (IFLALT(2).EQ.1.AND.ITCONT.NE.1)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Y-DIRECTION: INITIAL CORRECTION '',
     *                       ''TO THE ISOVECTOR FERMI ENERGY IS:'',
     *                                                F9.5,2X,1H*)')
     *            DALISO(2)
C
              IF (IFLALT(3).EQ.1.AND.ITCONT.NE.1)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Z-DIRECTION: INITIAL CORRECTION '',
     *                       ''TO THE ISOVECTOR FERMI ENERGY IS:'',
     *                                                F9.5,2X,1H*)')
     *            DALISO(3)
C
              IF (ITCONT.NE.1)
     *            WRITE(NFIPRI,'(                     1H*,77X,1H*)')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IPAIRI.EQ.1) THEN
C
          IF (IPAHFB.GE.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH THE HFB PAIRING '',
     *                        ''CORRELATIONS'',           30X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              IF (IPA2HF(0).EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH THE HFB PAIRING DOW'',
     *                    ''NGRADED TO THE HF METHOD FOR:        '',
     *                                                     2X,1H*,/,
     *            1H*,62X,             ''NEUTRONS:'',1X,A3,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            NO_YES(IPA2HF(0))
C
              END IF
C
              IF (IPA2HF(1).EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH THE HFB PAIRING DOW'',
     *                    ''NGRADED TO THE HF METHOD FOR:        '',
     *                                                     2X,1H*,/,
     *            1H*,62X,             '' PROTONS:'',1X,A3,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            NO_YES(IPA2HF(1))
C
              END IF
C
              IF (IPA2HF(0).EQ.2) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH THE HFB PAIRING DOW'',
     *                    ''NGRADED TO THE HF METHOD FOR:        '',
     *                                                     2X,1H*,/,
     *            1H*,47X,''NEUTRONS WITH GAP<'',F5.3,'':'',1X,A3,
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            DEL2HF(0),NO_YES(IPA2HF(0))
C
              END IF
C
              IF (IPA2HF(1).EQ.2) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH THE HFB PAIRING DOW'',
     *                    ''NGRADED TO THE HF METHOD FOR:        '',
     *                                                     2X,1H*,/,
     *            1H*,47X,'' PROTONS WITH GAP<'',F5.3,'':'',1X,A3,
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            DEL2HF(1),NO_YES(IPA2HF(1))
C
              END IF
C
              IF (IPQBCS.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''NUMERICAL PARAMETERS OF THE QUABCS '',
     *                        ''ROUTINE HAVE BEEN READ, '',
     *                        ''         '',               8X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,1X,''AND READ:'',4(1PE10.2),I5,
     *                                                    23X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *                 PARACC,CORLIM,DERLIM,OCCLIM,MAXQUA
C
              END IF
C
              IF (NOZEPA.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''CONTRIBUTIONS OF THE ZERO-RANGE '',
     *                        ''FORCES TO PAIRING WERE '',
     *                        ''REMOVED'',                14X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (KAPASY.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''THE HFB PAIRING TENSOR WILL BE '',
     *                        ''ANTISYMMETRIZED'',
     *                        ''           '',            19X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (IPAHFB.EQ.2) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''THE HFB EQUATIONS WILL BE SOLVED '',
     *                        ''IN THE CANONICAL BASIS '',
     *                        ''           '',             9X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (ITWOBA.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''THE HFB EQUATIONS SOLVED IN THE '',
     *                        ''BASIS OF MF EIGENSTATES '',
     *                        ''(TWO-BASIS METHOD)'',      2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (ICONTI.NE.1.OR.(ICONTI.EQ.1.AND.IPCONT.NE.1)) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*, 1X,''INITIAL VALUES OF PAIRING PROPERTIES:'',
     *                        ''         FERMI ENERGY    PAIRING GAP '',
     *                                                         2X,1H*,/,
     *                1H*,29X, ''NEUTRONS:'',        3X,2F15.4,6X,1H*,/,
     *                1H*,29X, '' PROTONS:'',        3X,2F15.4,6X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *            (FERINI(ICHARG),DELINI(ICHARG),ICHARG=0,NDISOS)
C
              END IF
C
              IF (IFEFIN.EQ.1.OR.IFEFIP.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH FIXED VALUES OF THE'',
     *                    '' FERMI ENERGY:      VALUE       FIXED'',
     *                                                     2X,1H*,/,
     *            1H*,42X,       ''NEUTRONS:'',F13.5,7X,A3,3X,1H*,/,
     *            1H*,42X,       '' PROTONS:'',F13.5,7X,A3,3X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            FERFIN,NO_YES(IFEFIN),
     *            FERFIP,NO_YES(IFEFIP)
C
              END IF
C
              IF (IDEFIN.EQ.1.OR.IDEFIP.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH FIXED VALUES OF THE'',
     *                    '' PAIRING GAP:       VALUE       FIXED'',
     *                                                     2X,1H*,/,
     *            1H*,42X,       ''NEUTRONS:'',F13.5,7X,A3,3X,1H*,/,
     *            1H*,42X,       '' PROTONS:'',F13.5,7X,A3,3X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            DELFIN,NO_YES(IDEFIN),
     *            DELFIP,NO_YES(IDEFIP)
C
              END IF
C
              IF (LIPKIN.EQ.1.OR.LIPKIP.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH THE LIPKIN-NOGAMI '',
     *                    ''CORRECTIONS INCLUDED FOR '',
     *                                 ''NEUTRONS:'',1X,A3,2X,1H*,/,
     *            1H*,62X,             '' PROTONS:'',1X,A3,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            NO_YES(LIPKIN),
     *            NO_YES(LIPKIP)
C
                  WRITE(NFIPRI,'(79(1H*),/,             1H*,77X,1H*,/,
     *                     1H*, 1X,''THE LIPKIN-NOGAMI PAIRING-'',
     *                             ''STRENGTHS SCALING FACTORS: '',3X,
     *                             ''NEUTRONS='',F9.6,       2X,1H*,/,
     *                     1H*,57X,'' PROTONS='',F9.6,       2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *            FACTGN,FACTGP
C
                  IF (IPCONT.NE.1.OR.(IPCONT.EQ.1.AND.ILCONT.EQ.0)) THEN
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                1H*, 1X,''INITIAL VALUES OF THE LIPKIN-NOGAMI '',
     *                        ''LAMBDA2 FOR NEUTRONS: '',F12.4,6X,1H*,/,
     *                1H*,49X,            '' PROTONS: '',F12.4,6X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *                (FE2INI(ICHARG),ICHARG=0,NDISOS)
C
                  END IF
C
                  IF (IF2FIN.EQ.1.OR.IF2FIP.EQ.1) THEN
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                1H*, 1X,''CALCULATIONS WITH FIXED VALUES OF THE'',
     *                        '' LIPKIN LAMBDA2:    VALUE       FIXED'',
     *                                                         2X,1H*,/,
     *                1H*,45X,       ''NEUTRONS:'',F10.5,7X,A3,3X,1H*,/,
     *                1H*,45X,       '' PROTONS:'',F10.5,7X,A3,3X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *                FE2FIN,NO_YES(IF2FIN),
     *                FE2FIP,NO_YES(IF2FIP)
C
                  END IF
C
                  IF (IFCONT.NE.1) THEN
C
                      IF (ILCONT.EQ.1) THEN
C
                          WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *                   1H*,1X,''DENSITY MATRICES WILL BE  READ  '',
     *                          ''FROM DISC  IN ORDER TO CONTINUE '',
     *                          ''LIPKIN RUN'',                2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
                      ELSE
C
                          WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *                   1H*,1X,''DENSITY MATRICES WILL BE ZEROED '',
     *                          ''BEFORE  SOLVING LIPKIN-NOGAMI '',
     *                          ''FOR THIS RUN'',              2X,1H*,/,
     *                                                    1H*,77X,1H*)')
                      END IF
C
                  END IF
C
                  IF (LIPNON.EQ.1.OR.LIPNOP.EQ.1) THEN
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                1H*, 1X,''BLOCKED ORBITAL EXCLUDED FROM '',
     *                        ''LIPKIN-NOGAMI CORRECTIONS FOR  '',
     *                                     ''NEUTRONS:'',1X,A3,2X,1H*,/,
     *                1H*,62X,             '' PROTONS:'',1X,A3,2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *                NO_YES(LIPNON),
     *                NO_YES(LIPNOP)
C
                  END IF
C
              END IF
C
              IF (IDEFIN.EQ.0.OR.IDEFIP.EQ.0) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CONTACT PAIRING INTERACTION:     V0  '',
     *                    ''      V1       RHO-SAT      POWER    '',
     *                                                     2X,1H*,/,
     *            1H*,20X, ''NEUTRONS:'',3F10.3,F14.7,     4X,1H*,/,
     *            1H*,20X, '' PROTONS:'',3F10.3,F14.7,     4X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            PRHO_N,PRHODN,PRHOSN,POWERN,
     *            PRHO_P,PRHODP,PRHOSP,POWERP
C
              END IF
C
              IF (IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1) THEN
C
                  IF (INIBLN.EQ.1) THEN
                      WRITE (NUMERN,'(I6)')  INSIGN
                      WRITE (NUMMQN,'(I6)')  IPSIGN
                      WRITE (NUM_GN,'(I6)')  ISSIGN
                  ELSE
                      WRITE (NUMERN,'(A6)') '  FILE'
                      WRITE (NUMMQN,'(A6)') '  FILE'
                      WRITE (NUM_GN,'(A6)') '  FILE'
                  END IF
C
                  IF (INIBLP.EQ.1) THEN
                      WRITE (NUMERP,'(I6)')  INSIGP
                      WRITE (NUMMQP,'(I6)')  IPSIGP
                      WRITE (NUM_GP,'(I6)')  ISSIGP
                  ELSE
                      WRITE (NUMERP,'(A6)') '  FILE'
                      WRITE (NUMMQP,'(A6)') '  FILE'
                      WRITE (NUM_GP,'(A6)') '  FILE'
                  END IF
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''BLOCKING OF QUASIPARTICLES THAT HAVE '',
     *                    ''LARGEST OVERLAP WITH PARTICLE STATES:'',
     *                                                     2X,1H*,/,
     *            1H*, 1X,''                                     '',
     *                    ''        NUMBER PARITY SIGNATURE      '',
     *                                                     2X,1H*)')
                  IF (IABS(IDSIGN).EQ.1)
     *                WRITE(NFIPRI,'(
     *                1H*,9X,A26,1X,''NEUTRONS:'',A6,2A7,7X,A3,2X,1H*)')
     *
     *                IFTIMR(IDSIGN),
     *                NUMERN,NUMMQN,NUM_GN,NO_YES(IABS(IDSIGN))
C
                  IF (IABS(IDSIGP).EQ.1)
     *                WRITE(NFIPRI,'(
     *                1H*,9X,A26,1X,'' PROTONS:'',A6,2A7,7X,A3,2X,1H*)')
     *
     *                IFTIMR(IDSIGP),
     *                NUMERP,NUMMQP,NUM_GP,NO_YES(IABS(IDSIGP))
C
                  WRITE(NFIPRI,'(                         1H*,77X,1H*)')
C
              END IF
C
              IF (IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1) THEN
C
                  IF (INIBLN.EQ.1) THEN
                      WRITE (NUMERN,'(I6)')  INSIMN
                      WRITE (NUMMQN,'(I6)')  IRSIMN
                  ELSE
                      WRITE (NUMERN,'(A6)') '  FILE'
                      WRITE (NUMMQN,'(A6)') '  FILE'
                  END IF
C
                  IF (INIBLP.EQ.1) THEN
                      WRITE (NUMERP,'(I6)')  INSIMP
                      WRITE (NUMMQP,'(I6)')  IRSIMP
                  ELSE
                      WRITE (NUMERP,'(A6)') '  FILE'
                      WRITE (NUMMQP,'(A6)') '  FILE'
                  END IF
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''BLOCKING OF QUASIPARTICLES THAT HAVE '',
     *                    ''LARGEST OVERLAP WITH PARTICLE STATES:'',
     *                                                     2X,1H*,/,
     *            1H*, 1X,''                                     '',
     *                    ''                NUMBER SIMPLEX       '',
     *                                                     2X,1H*)')
                  IF (IABS(IDSIMN).EQ.1)
     *                WRITE(NFIPRI,'(
     *                1H*,16X,A26,1X,''NEUTRONS:'',A6,A7,7X,A3,2X,1H*)')
     *
     *                IFTIMR(IDSIMN),
     *                NUMERN,NUMMQN,NO_YES(IABS(IDSIMN))
C
                  IF (IABS(IDSIMP).EQ.1)
     *                WRITE(NFIPRI,'(
     *                1H*,16X,A26,1X,'' PROTONS:'',A6,A7,7X,A3,2X,1H*)')
     *
     *                IFTIMR(IDSIMP),
     *                NUMERP,NUMMQP,NO_YES(IABS(IDSIMP))
C
                  WRITE(NFIPRI,'(                         1H*,77X,1H*)')
C
              END IF
C
              I_HEAD=0
C
              IF (MAXVAL(IABS(IDSIZN)).EQ.1) THEN
C
                  DO NUBLOC=1,NDBLOC
C
                     IF (IABS(IDSIZN(NUBLOC)).EQ.1) THEN
C
                         IF (INIBLN.EQ.1) THEN
                             WRITE (NUMERN,'(I6)') INSIZN(NUBLOC)
                         ELSE
                             WRITE (NUMERN,'(A6)') '  FILE'
                         END IF
C
                         IF (I_HEAD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(79(1H*),/,    1H*,77X,1H*,/,
     *               1H*, 1X,''BLOCKING QUASIPARTICLES THAT HAVE THE '',
     *                       ''LARGEST OVERLAP WITH PARTICLE STATES'',
     *                                                         2X,1H*,/,
     *               1H*, 1X,''                                      '',
     *                       ''    NUMBER            STATE         '',
     *                                                         2X,1H*)')
                         ELSE
                             I_HEAD=1
                         END IF
C
                         WRITE(NFIPRI,'(
     *                   1H*,21X,A26,1X,I1,1X,''NEUTRONS:'',A6,7X,A3,
     *                                                         2X,1H*)')
     *
     *                   IFTIMR(IDSIZN(NUBLOC)),NUBLOC,NUMERN,
     *                   NO_YES(IABS(IDSIZN(NUBLOC)))
C
                     END IF
                  END DO
C
                  IF (I_HEAD.EQ.1) WRITE(NFIPRI,'(        1H*,77X,1H*)')
C
              END IF
C
              IF (MAXVAL(IABS(IDSIZP)).EQ.1) THEN
C
                  DO NUBLOC=1,NDBLOC
C
                     IF (IABS(IDSIZP(NUBLOC)).EQ.1) THEN
C
                         IF (INIBLP.EQ.1) THEN
                             WRITE (NUMERN,'(I6)') INSIZP(NUBLOC)
                         ELSE
                             WRITE (NUMERN,'(A6)') '  FILE'
                         END IF
C
                         IF (I_HEAD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(79(1H*),/,    1H*,77X,1H*,/,
     *               1H*, 1X,''BLOCKING QUASIPARTICLES THAT HAVE THE '',
     *                       ''LARGEST OVERLAP WITH PARTICLE STATES'',
     *                                                         2X,1H*,/,
     *               1H*, 1X,''                                      '',
     *                       ''    NUMBER            STATE         '',
     *                                                         2X,1H*)')
                         ELSE
                             I_HEAD=1
                         END IF
C
                         WRITE(NFIPRI,'(
     *                   1H*,21X,A26,1X,I1,1X,'' PROTONS:'',A6,7X,A3,
     *                                                         2X,1H*)')
     *
     *                   IFTIMR(IDSIZP(NUBLOC)),NUBLOC,NUMERN,
     *                   NO_YES(IABS(IDSIZP(NUBLOC)))
C
                     END IF
                  END DO
C
              END IF
C
              IF (MAXVAL(IABS(IDSIZN)).EQ.1.OR.
     *            MAXVAL(IABS(IDSIZP)).EQ.1)
     *            WRITE(NFIPRI,'(        1H*,77X,1H*)')
C
              I_HEAD=0
C
              IF (MAXVAL(IABS(IDSIQN)).EQ.1) THEN
C
                  DO NUBLOC=1,NDBLOC
C
                     IF (IABS(IDSIQN(NUBLOC)).EQ.1) THEN
C
                         IF (INIBLN.EQ.1) THEN
                             WRITE (NUMERN,'(I6)')  INSIQN(NUBLOC)
                             WRITE (NUMMQN,'(I6)')  IPSIQN(NUBLOC)
                         ELSE
                             WRITE (NUMERN,'(A6)') '  FILE'
                             WRITE (NUMMQN,'(A6)') '  FILE'
                         END IF
C
                         IF (I_HEAD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(79(1H*),/,    1H*,77X,1H*,/,
     *                1H*, 1X,''BLOCKING OF QUASIPARTICLES THAT HAVE '',
     *                        ''LARGEST OVERLAP WITH PARTICLE STATES:'',
     *                                                         2X,1H*,/,
     *                1H*, 1X,''                                     '',
     *                        ''                NUMBER  PARITY       '',
     *                                                         2X,1H*)')
                         ELSE
                             I_HEAD=1
                         END IF
C
                         WRITE(NFIPRI,'(
     *                         1H*,16X,A26,1X,''NEUTRONS:'',A6,A7,7X,A3,
     *                                                         2X,1H*)')
     *
     *                   IFTIMR(IDSIQN(NUBLOC)),
     *                   NUMERN,NUMMQN,NO_YES(IABS(IDSIQN(NUBLOC)))
C
C
                     END IF
                  END DO
C
              END IF
C
              IF (MAXVAL(IABS(IDSIQP)).EQ.1) THEN
C
                  DO NUBLOC=1,NDBLOC
C
                     IF (IABS(IDSIQP(NUBLOC)).EQ.1) THEN
C
                         IF (INIBLP.EQ.1) THEN
                             WRITE (NUMERN,'(I6)')  INSIQP(NUBLOC)
                             WRITE (NUMMQN,'(I6)')  IPSIQP(NUBLOC)
                         ELSE
                             WRITE (NUMERN,'(A6)') '  FILE'
                             WRITE (NUMMQN,'(A6)') '  FILE'
                         END IF
C
                         IF (I_HEAD.EQ.0) THEN
C
                             WRITE(NFIPRI,'(79(1H*),/,    1H*,77X,1H*,/,
     *                1H*, 1X,''BLOCKING OF QUASIPARTICLES THAT HAVE '',
     *                        ''LARGEST OVERLAP WITH PARTICLE STATES:'',
     *                                                         2X,1H*,/,
     *                1H*, 1X,''                                     '',
     *                        ''                NUMBER  PARITY       '',
     *                                                         2X,1H*)')
                         ELSE
                             I_HEAD=1
                         END IF
C
                         WRITE(NFIPRI,'(
     *                         1H*,16X,A26,1X,'' PROTONS:'',A6,A7,7X,A3,
     *                                                         2X,1H*)')
     *
     *                   IFTIMR(IDSIQP(NUBLOC)),
     *                   NUMERN,NUMMQN,NO_YES(IABS(IDSIQP(NUBLOC)))
C
C
                     END IF
                  END DO
C
              END IF
C
              IF (MAXVAL(IABS(IDSIQN)).EQ.1.OR.
     *            MAXVAL(IABS(IDSIQP)).EQ.1)
     *            WRITE(NFIPRI,'(        1H*,77X,1H*)')
C
              IF (IFIBLN.EQ.1.OR.IFIBLP.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''PARTICLE STATES THAT ARE USED FOR BLO'',
     *                    ''CKING WILL BE FIXED DURING ITERATION:'',
     *                                                     2X,1H*,/,
     *                     1H*,58X,''FOR NEUTRONS:'',1X,A3,2X,1H*,/,
     *                     1H*,58X,''FOR  PROTONS:'',1X,A3,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            NO_YES(IFIBLN),NO_YES(IFIBLP)
C
              END IF
C
              IF (INIBLN.EQ.1.OR.INIBLP.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''PARTICLE STATES THAT ARE USED FOR BLO'',
     *                    ''CKING WILL BE INITIALIZED AT 1ST ITER'',
     *                                                     2X,1H*,/,
     *                     1H*,58X,''FOR NEUTRONS:'',1X,A3,2X,1H*,/,
     *                     1H*,58X,''FOR  PROTONS:'',1X,A3,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            NO_YES(INIBLN),NO_YES(INIBLP)
C
              END IF
C
              IF (IFIBLN.EQ.1.AND.INIBLN.EQ.0) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''NEUTRON PARTICLE STATE USED FOR BLOCK'',
     *                    ''ING WILL BE READ FROM THE RECORD FILE'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (IFIBLP.EQ.1.AND.INIBLP.EQ.0) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''PROTON  PARTICLE STATE USED FOR BLOCK'',
     *                    ''ING WILL BE READ FROM THE RECORD FILE'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (IMFHFB.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''THE HFB-MEAN-FIELD SPECTRA AND SINGLE'',
     *                    ''-PARTICLE PROPERTIES  WILL BE PRINTED'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.0) THEN
C
                  IF (NCUSIZ(0).EQ.0) THEN
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                   1H*,1X,''CUTOFF ENERGY DEFINING THE ACTIVE'',
     *                          '' HFB NEUTRON SPACE='',F12.3,12X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                ECUTOF
C
                  ELSE
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                   1H*,1X,''NUMBER OF STATES DEFINING THE'',
     *                          '' ACTIVE HFB NEUTRON SPACE='',
     *                                                     I4,17X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                NCUSIZ(0)
C
                  END IF
C
                  IF (NCUSIZ(1).EQ.0) THEN
C
                      WRITE(NFIPRI,'(
     *                   1H*,1X,''CUTOFF ENERGY DEFINING THE ACTIVE'',
     *                          '' HFB PROTON  SPACE='',F12.3,12X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                ECUTOF
C
                  ELSE
C
                      WRITE(NFIPRI,'(
     *                   1H*,1X,''NUMBER OF STATES DEFINING THE'',
     *                          '' ACTIVE HFB PROTON  SPACE='',
     *                                                     I4,17X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                NCUSIZ(1)
C
                  END IF
C
              END IF
C
              IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.1) THEN
C
                  IF (NCUSIQ(0,0).EQ.0.AND.NCUSIQ(0,1).EQ.0) THEN
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                   1H*,1X,''CUTOFF ENERGY DEFINING THE ACTIVE'',
     *                          '' HFB NEUTRON SPACE='',F12.3,12X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                ECUTOF
C
                  ELSE
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                   1H*,1X,''NUMBERS OF PARITY STATES FOR THE '',
     *                          ''ACTIVE HFB NEUTRON SPACE: P+='',I4,
     *                                                   '' P-='',I4,
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                NCUSIQ(0,0),NCUSIQ(0,1)
C
                  END IF
C
                  IF (NCUSIQ(1,0).EQ.0.AND.NCUSIQ(1,1).EQ.0) THEN
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                   1H*,1X,''CUTOFF ENERGY DEFINING THE ACTIVE'',
     *                          '' HFB PROTON  SPACE='',F12.3,12X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                ECUTOF
C
                  ELSE
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                   1H*,1X,''NUMBERS OF PARITY STATES FOR THE '',
     *                          ''ACTIVE HFB PROTON  SPACE: P+='',I4,
     *                                                   '' P-='',I4,
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                NCUSIQ(1,0),NCUSIQ(1,1)
C
                  END IF
C
              END IF
C
              IF (LIMQUA.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''ONLY THE QUASIPARTICLES WITH ENERGIES '',
     *                    ''BELOW THE CUTOFF ENERGY WILL BE USED'',
     *                                                     2X,1H*,/,
     *            1H*, 1X,''ATTENTION: THE CUTOFF ENERGY MUST NOT '',
     *                    ''BE BELOW THE QP ENERGY OF THE 1S_1/2'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (LAMCUT.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''QUASIPARTICLE CUTOFF ENERGY WILL BE '',
     *                    ''APPLIED RELATIVELY TO THE FERMI ENERGY'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (NUQEVE.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''EVEN NUMBERS OF QUASIPARTICLES ENFORCED '',
     *                    ''TO COMPLY WITH THE PFAFFIAN METHOD'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
C=======================================================================
C
          END IF
C
          IF (JPABCS.GT.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH THE BCS PAIRING'',
     *                        '' CORRELATIONS'',          30X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              IF (JPABCS.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,             1H*,77X,1H*,/,
     *                     1H*, 1X,''CALCULATIONS WITH PAIRING-'',
     *                             ''STRENGTHS SCALING FACTORS: '',7X,
     *                             ''NEUTRONS='',F5.3,       2X,1H*,/,
     *                     1H*,61X,'' PROTONS='',F5.3,       2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *            FACTGN,FACTGP
C
              END IF
C
              IF (JPABCS.EQ.2) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH FIXED VALUES OF THE'',
     *                    '' PAIRING GAP:       VALUE       FIXED'',
     *                                                     2X,1H*,/,
     *            1H*,42X,       ''NEUTRONS:'',F12.3,8X,A3,3X,1H*,/,
     *            1H*,42X,       '' PROTONS:'',F12.3,8X,A3,3X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            DELFIN,NO_YES(IDEFIN),
     *            DELFIP,NO_YES(IDEFIP)
C
              END IF
C
              IF (JPABCS.EQ.3) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATIONS WITH THE STATE-DEPENDENT'',
     *                    '' PAIRING GAPS -- CORRESPONDING TO THE'',
     *                                                     2X,1H*,/,
     *            1H*, 1X,''CONTACT PAIRING INTERACTION:     V0  '',
     *                    ''      V1       RHO-SAT      POWER    '',
     *                                                     2X,1H*,/,
     *            1H*,20X, ''NEUTRONS:'',3F10.3,F14.7,     4X,1H*,/,
     *            1H*,20X, '' PROTONS:'',3F10.3,F14.7,     4X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            PRHO_N,PRHODN,PRHOSN,POWERN,
     *            PRHO_P,PRHODP,PRHOSP,POWERP
C
                  WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*, 1X,''CALCULATING PAIRING M.E. FOR THE '',
     *                        ''FOLLOWING ITERATIONS:'',4X,
     *                               ''THE  FIRST:'',2X,A3,    2X,1H*,/,
     *                1H*,59X,       ''THE MIDDLE:'',2X,A3,    2X,1H*,/,
     *                1H*,59X,       ''THE   LAST:'',2X,A3,    2X,1H*,/,
     *                1H*,57X,     ''AND/OR EVERY:'',I3,''TH'',2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *               NO_YES(IDESTA),NO_YES(IDEMID),NO_YES(IDESTO),IDEDIS
C
              END IF
C
          END IF
C
          IF (IFERAN.EQ.1.OR.IFERAP.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *        1H*, 1X,''CALCULATIONS WITH ALM-ADJUSTEMENT FOR'',
     *                '' FERMI ENERGY:    STIFFNESS  ADJUSTED'',
     *                                                 2X,1H*,/,
     *        1H*,43X,       ''NEUTRONS:'',F12.5,7X,A3,3X,1H*,/,
     *        1H*,43X,       '' PROTONS:'',F12.5,7X,A3,3X,1H*,/,
     *                                            1H*,77X,1H*)')
     *
     *        FERALN,NO_YES(IFERAN),
     *        FERALP,NO_YES(IFERAP)
C
          END IF
C
      ELSE
C
          I_HEAD=0
C
          IF (MAXVAL(IABS(IDSIQN)).EQ.2) THEN
C
              DO NUBLOC=1,NDBLOC
C
                 IF (IABS(IDSIQN(NUBLOC)).EQ.2) THEN
C
                     IF (INIBLN.EQ.1) THEN
                         WRITE (NUMERN,'(I4,2X)')  INSIQN(NUBLOC)
                         WRITE (NUMMQN,'(I4,2X)')  IPSIQN(NUBLOC)
                     ELSE
                         WRITE (NUMERN,'(A6)') '  FILE'
                         WRITE (NUMMQN,'(A6)') '  FILE'
                     END IF
C
                     IF (I_HEAD.EQ.0) THEN
C
                         WRITE(NFIPRI,'(79(1H*),/,    1H*,77X,1H*,/,
     *            1H*, 1X,''BLOCKING OF SINGLE-PARTICLES THAT HAV'',
     *                    ''E LARGEST OVERLAP WITH THE GIVEN ONE:'',
     *                                                     2X,1H*,/,
     *            1H*, 1X,''                                     '',
     *                    ''                NUMBER  PARITY       '',
     *                                                     2X,1H*)')
                     ELSE
                         I_HEAD=1
                     END IF
C
                     WRITE(NFIPRI,'(
     *                    1H*,16X,26X,1X,''NEUTRONS:  '',A6,2X,A6,4X,A3,
     *                                                     2X,1H*)')
     *
     *                     NUMERN,NUMMQN,NO_YES(IABS(IDSIQN(NUBLOC)))
C
                 END IF
              END DO
C
          END IF
C
          IF (MAXVAL(IABS(IDSIQP)).EQ.2) THEN
C
              DO NUBLOC=1,NDBLOC
C
                 IF (IABS(IDSIQP(NUBLOC)).EQ.2) THEN
C
                     IF (INIBLN.EQ.1) THEN
                         WRITE (NUMERN,'(I4,2X)')  INSIQP(NUBLOC)
                         WRITE (NUMMQN,'(I4,2X)')  IPSIQP(NUBLOC)
                     ELSE
                         WRITE (NUMERN,'(A6)') '  FILE'
                         WRITE (NUMMQN,'(A6)') '  FILE'
                     END IF
C
                     IF (I_HEAD.EQ.0) THEN
C
                         WRITE(NFIPRI,'(79(1H*),/,    1H*,77X,1H*,/,
     *            1H*, 1X,''BLOCKING OF SINGLE-PARTICLES THAT HAV'',
     *                    ''E LARGEST OVERLAP WITH THE GIVEN ONE:'',
     *                                                     2X,1H*,/,
     *            1H*, 1X,''                                     '',
     *                    ''                NUMBER  PARITY       '',
     *                                                     2X,1H*)')
                     ELSE
                         I_HEAD=1
                     END IF
C
                     WRITE(NFIPRI,'(
     *                    1H*,16X,26X,1X,'' PROTONS:  '',A6,2X,A6,4X,A3,
     *                                                     2X,1H*)')
     *
     *                     NUMERN,NUMMQN,NO_YES(IABS(IDSIQP(NUBLOC)))
C
                 END IF
              END DO
C
          END IF
C
          IF (MAXVAL(IABS(IDSIQN)).EQ.2.OR.MAXVAL(IABS(IDSIQP)).EQ.2)
     *        WRITE(NFIPRI,'(        1H*,77X,1H*)')
C
          I_HEAD=0
C
          IF (MAXVAL(IABS(IDSIZN)).EQ.2) THEN
C
              DO NUBLOC=1,NDBLOC
C
                 IF (IABS(IDSIZN(NUBLOC)).EQ.2) THEN
C
                     IF (INIBLN.EQ.1) THEN
                         WRITE (NUMERN,'(I4,2X)')  INSIZN(NUBLOC)
                     ELSE
                         WRITE (NUMERN,'(A6)') '  FILE'
                     END IF
C
                     IF (I_HEAD.EQ.0) THEN
C
                         WRITE(NFIPRI,'(79(1H*),/,    1H*,77X,1H*,/,
     *            1H*, 1X,''BLOCKING OF SINGLE-PARTICLES THAT HAV'',
     *                    ''E LARGEST OVERLAP WITH THE GIVEN ONE:'',
     *                                                     2X,1H*,/,
     *            1H*, 1X,''                                     '',
     *                    ''                        NUMBER       '',
     *                                                     2X,1H*)')
                     ELSE
                         I_HEAD=1
                     END IF
C
                     WRITE(NFIPRI,'(
     *                    1H*,16X,26X,1X,''NEUTRONS:  '',6X,2X,A6,4X,A3,
     *                                                     2X,1H*)')
     *
     *                     NUMERN,NO_YES(IABS(IDSIZN(NUBLOC)))
C
                 END IF
              END DO
C
          END IF
C
          IF (MAXVAL(IABS(IDSIZP)).EQ.2) THEN
C
              DO NUBLOC=1,NDBLOC
C
                 IF (IABS(IDSIZP(NUBLOC)).EQ.2) THEN
C
                     IF (INIBLN.EQ.1) THEN
                         WRITE (NUMERN,'(I4,2X)')  INSIZP(NUBLOC)
                     ELSE
                         WRITE (NUMERN,'(A6)') '  FILE'
                     END IF
C
                     IF (I_HEAD.EQ.0) THEN
C
                         WRITE(NFIPRI,'(79(1H*),/,    1H*,77X,1H*,/,
     *            1H*, 1X,''BLOCKING OF SINGLE-PARTICLES THAT HAV'',
     *                    ''E LARGEST OVERLAP WITH THE GIVEN ONE:'',
     *                                                     2X,1H*,/,
     *            1H*, 1X,''                                     '',
     *                    ''                        NUMBER       '',
     *                                                     2X,1H*)')
                     ELSE
                         I_HEAD=1
                     END IF
C
                     WRITE(NFIPRI,'(
     *                    1H*,16X,26X,1X,'' PROTONS:  '',6X,2X,A6,4X,A3,
     *                                                     2X,1H*)')
     *
     *                     NUMERN,NO_YES(IABS(IDSIZP(NUBLOC)))
C
                 END IF
              END DO
C
          END IF
C
          IF (MAXVAL(IABS(IDSIZN)).EQ.2.OR.MAXVAL(IABS(IDSIZP)).EQ.2)
     *        WRITE(NFIPRI,'(        1H*,77X,1H*)')
C
          IF (MAXVAL(IABS(IDSIQN)).EQ.2.OR.MAXVAL(IABS(IDSIQP)).EQ.2.OR.
     *        MAXVAL(IABS(IDSIZN)).EQ.2.OR.MAXVAL(IABS(IDSIZP)).EQ.2)
     *                                                              THEN
              IF (IFIBLN.EQ.1.OR.IFIBLP.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''PARTICLE STATES THAT ARE USED FOR BLO'',
     *                    ''CKING WILL BE FIXED DURING ITERATION:'',
     *                                                     2X,1H*,/,
     *                     1H*,58X,''FOR NEUTRONS:'',1X,A3,2X,1H*,/,
     *                     1H*,58X,''FOR  PROTONS:'',1X,A3,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            NO_YES(IFIBLN),NO_YES(IFIBLP)
C
              END IF
C
              IF (INIBLN.EQ.1.OR.INIBLP.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''PARTICLE STATES THAT ARE USED FOR BLO'',
     *                    ''CKING WILL BE INITIALIZED AT 1ST ITER'',
     *                                                     2X,1H*,/,
     *                     1H*,58X,''FOR NEUTRONS:'',1X,A3,2X,1H*,/,
     *                     1H*,58X,''FOR  PROTONS:'',1X,A3,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *            NO_YES(INIBLN),NO_YES(INIBLP)
C
              END IF
C
              IF (IFIBLN.EQ.1.AND.INIBLN.EQ.0) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''NEUTRON PARTICLE STATE USED FOR BLOCK'',
     *                    ''ING WILL BE READ FROM THE RECORD FILE'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
              IF (IFIBLP.EQ.1.AND.INIBLP.EQ.0) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *            1H*, 1X,''PROTON  PARTICLE STATE USED FOR BLOCK'',
     *                    ''ING WILL BE READ FROM THE RECORD FILE'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IKEINV.GE.1.OR.IKEKAR.GE.1)
     *
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *              1H*,'' BEFORE CALCULATING THE KERNELS, THE RIGHT'',
     *                  '' WAVE FUNCTION WILL BE MODIFIED BY'',
     *                                                         1X,1H*,/,
     *              1H*,'' ONE OF THE D2H TRANSFORMATIONS: '',A43,
     *                                                         1X,1H*,/,
     *              1H*,77X,1H*)')
     *
     *    NAMINV(IKEINV,IKEKAR)
C
C=======================================================================
C
      IF (INIINV.GE.1.OR.INIKAR.GE.1)
     *
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *              1H*,'' AFTER THE FIRST ITERATION OF THIS RUN'',
     *                  '' THE WAVE FUNCTION WILL BE MODIFIED BY'',
     *                                                         1X,1H*,/,
     *              1H*,'' ONE OF THE D2H TRANSFORMATIONS: '',A43,
     *                                                         1X,1H*,/,
     *              1H*,77X,1H*)')
     *
     *    NAMINV(INIINV,INIKAR)
C
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
      DEGRAD=180/PI
C
      IF (INIROT.EQ.1)
     *
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *              1H*,'' AFTER THE FIRST ITERATION OF THIS RUN'',
     *                  '' THE WAVE FUNCTIONS WILL BE ROTATED BY'',
     *                                                         1X,1H*,/,
     *              1H*,'' THE FOLLOWING STANDARD EULER ANGLES (IN'',
     *                  '' DEGREES)'',                        28X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,'' ALPHA ='',F7.2,2X,
     *                  ''  BETA ='',F7.2,2X,
     *                  '' GAMMA ='',F7.2,28X,1H*,/,
     *              1H*,77X,1H*)')
     *
     *    ALPINI*DEGRAD,BETINI*DEGRAD,GAMINI*DEGRAD
C
C=======================================================================
C
      IF (IPRGCM.GE.1) THEN
C
          IF (IPAKER.NE.1) THEN
C
              IF (MOD(IPROMI,2).EQ.0) THEN
C
                  WRITE(LPROMI,'(I4,1X)') IPROMI/2
                  WRITE(LPROMA,'(I4,1X)') IPROMA/2
                  WRITE(LPROJE,'(I4,1X)') KPROJE/2
C
              ELSE
C
                  WRITE(LPROMI,'(I3,''/2'')') IPROMI
                  WRITE(LPROMA,'(I3,''/2'')') IPROMA
                  WRITE(LPROJE,'(I3,''/2'')') KPROJE
C
              END IF
C
              IF (NUBKNO.GT.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                 1H*,'' THE ANGULAR MOMENTUM PROJECTION IS'',
     *                     '' PERFORMED AFTER THE ITERATIONS ARE DONE'',
     *                                           2X,1H*,/,1H*,77X,1H*,/,
     *                 1H*,'' PROJECTION ON VALUES OF ANGULAR MOMENTA'',
     *                     '' BETWEEN J ='',A5,'' AND J ='',A5,
     *                     '' HBAR'',            2X,1H*,/,1H*,77X,1H*,/,
     *                 1H*,'' NUMBERS OF INTEGRATION POINTS IN EULER'',
     *                     '' ANGLES:'',I3,'' (ALPHA/GAMMA),'',I3,
     *                     '' (BETA)'',                        2X,1H*)')
     *
     *                 LPROMI,LPROMA,NUAKNO,NUBKNO
C
                  IF (NUAKNO.EQ.1) THEN
C
                      WRITE(NFIPRI,'(                     1H*,77X,1H*,/,
     *                   1H*,'' AXIAL SYMMETRY IS ASSUMED: THE'',
     *                       '' PROJECTIONS ARE PERFORMED FOR K ='',A5,
     *                       '' ONLY'',                        2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                    LPROJE
C
                  ELSE
C
                      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
                  END IF
C
              ELSE
C
C=======================================================================
C             THE OPTION BELOW NOT PROGRAMMED YET (22/02/06)
C=======================================================================
C
                  IF (NUAKNO.GT.1) THEN
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,'' PROJECTION ON GOOD JZ COMPONENT IS'',
     *                     '' PERFORMED AFTER THE ITERATIONS ARE DONE'',
     *                                           2X,1H*,/,1H*,77X,1H*,/,
     *                 1H*,'' PROJECTION ON VALUES OF  JZ  COMPONENTS'',
     *                     '' BETWEEN K ='',A5,'' AND K ='',A5,
     *                     '' HBAR'',            2X,1H*,/,1H*,77X,1H*,/,
     *                 1H*,'' NUMBERS OF INTEGRATION POINTS IN EULER'',
     *                     '' ANGLES:'',I3,'' (ALPHA/GAMMA),'',I3,
     *                     '' (BETA)'',                        2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *                 LPROMI,LPROMA,NUAKNO,NUBKNO
C
                  END IF
C
              END IF
C
              IF (MOD(ISOSMI,2).EQ.0) THEN
C
                  WRITE(LPROMI,'(I4,1X)') ISOSMI/2
                  WRITE(LPROMA,'(I4,1X)') ISOSMA/2
                  WRITE(LPROJE,'(I4,1X)') ISOSTZ/2
C
              ELSE
C
                  WRITE(LPROMI,'(I3,''/2'')') ISOSMI
                  WRITE(LPROMA,'(I3,''/2'')') ISOSMA
                  WRITE(LPROJE,'(I3,''/2'')') ISOSTZ
C
              END IF
C
              IF (NBTKNO.GT.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                 1H*,'' THE  I S O S P I N   PROJECTION IS'',
     *                     '' PERFORMED AFTER THE ITERATIONS ARE DONE'',
     *                                           2X,1H*,/,1H*,77X,1H*,/,
     *                 1H*,'' PROJECTION ON VALUES OF THE  I S O S P'',
     *                     '' I N  BETWEEN T ='',A5,''  AND T ='',A5,
     *                                           2X,1H*,/,1H*,77X,1H*,/,
     *                 1H*,'' NUMBERS OF INTEGRATION POINTS IN EULER'',
     *                     '' ANGLES:'',I3,'' (ALP_T/GAM_T),'',I3,
     *                     '' (BE_T)'',                        2X,1H*)')
     *
     *                 LPROMI,LPROMA,NATKNO,NBTKNO
C
                  IF (NBTKNO.EQ.1) THEN
C
                      WRITE(NFIPRI,'(                     1H*,77X,1H*,/,
     *                   1H*,'' ISOTZ SYMMETRY IS ASSUMED: THE'',
     *                       '' PROJECTIONS ARE PERFORMED FOR TZ='',A5,
     *                       '' ONLY'',                        2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                    LPROJE
C
                  ELSE
C
                      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
                  END IF
C
              END IF
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *             1H*,'' THE GCM KERNELS IN FUNCTION OF THE'',
     *                 '' EULER ANGLES WILL BE CALCULATED & SAVED'',
     *                                           2X,1H*,/,1H*,77X,1H*,/,
     *             1H*,'' ON THE DISK FOR THE GAUSS NODES '',I3,
     *                 '' -- '',I3,'' (ALPHA),'','' AND '',I3,
     *                 '' -- '',I3,'' (GAMMA)'',               2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *             NUASTA,NUASTO,NUGSTA,NUGSTO
C
              IF (IPAK3D.EQ.1)
     *        WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *             1H*,'' AND FOR THE GAUSS ISOSPIN NODES '',I3,
     *                 '' -- '',I3,'' (ALP_T),'','' AND '',I3,
     *                 '' -- '',I3,'' (GAM_T)'',               2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *             NATSTA,NATSTO,NGTSTA,NGTSTO
C
              IF (IPAALL.EQ.1)
     *        WRITE(NFIPRI,'(
     *             1H*,'' AND FOR THE BETA + BETA_T NODES '',I3,
     *                 '' -- '',I3,'' (BETA), '','' AND '',I3,
     *                 '' -- '',I3,'' (BET_T)'',               2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *             NUBSTA,NUBSTO,NUTSTA,NUTSTO
C
              IF (KFIKER.GE.1)
     *        WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *             1H*,'' THE GCM KERNELS WILL BE SAVED IN'',
     *                 '' THE KERNEL FILE NUMBER: '',I5,
     *                                          14X,1H*,/,1H*,77X,1H*)')
     *
     *             KFIKER
C
          END IF
C
          IF (NPNKNO.GT.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *             1H*,'' PROJECTION ON TOTAL PARTICLE NUMBER A ='',
     *              I4,'' PERFORMED AFTER THE ITERATIONS'',2X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *             1H*,'' THE NUMBER OF INTEGRATION POINTS USED'',
     *                 '' FOR THE GAUGE ANGLE PHI EQUALS TO'',I3,
     *                                                     2X,1H*)')
     *
     *             IN_FIX+IZ_FIX,NPNKNO
C
              IF (IDENSU.EQ.1) THEN
C
                  WRITE(NFIPRI,'(
     *             1H*,'' UNPROJECTED TOTAL DENSITY USED IS IN'',
     *                 '' THE DENSITY-DEPENDENT PH AND PP TERMS'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              ELSE
C
                  WRITE(NFIPRI,'(1H*,77X,1H*)')
C
              END IF
C
          END IF
C
          IF (NTZKNO.GT.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *             1H*,'' PROJECTION ON TOTAL ISOVECTOR NUMBER TZ'',
     *              I4,'' PERFORMED AFTER THE ITERATIONS'',2X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *             1H*,'' THE NUMBER OF INTEGRATION POINTS USED'',
     *                 '' FOR THE GAUGE ANGLE PHIT EQUALS: '',I3,
     *                                                     2X,1H*)')
     *
     *             IN_FIX-IZ_FIX,NTZKNO
C
              IF (IDENSU.EQ.1) THEN
C
                  WRITE(NFIPRI,'(
     *             1H*,'' UNPROJECTED TOTAL DENSITY USED IS IN'',
     *                 '' THE DENSITY-DEPENDENT PH AND PP TERMS'',
     *                                                     2X,1H*,/,
     *                                                1H*,77X,1H*)')
C
              ELSE
C
                  WRITE(NFIPRI,'(1H*,77X,1H*)')
C
              END IF
C
          END IF
C
          IF (NPAKNO.GT.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *             1H*,'' PROJECTION ON THE TOTAL PARITY '',
     *                                             1X,1H",A1,1H",1X,
     *                 '' IS PERFORMED AFTER THE ITERATIONS'',
     *                                                     6X,1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *             MINPLU(IPAPRO)
C
          END IF
C
C=======================================================================
C
          IF (IPAHFB.GE.1) THEN
C
              IF (IONISH.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *              1H*,'' THE ONISHI FORMULA USED TO CALCULATE'',
     *                  '' OVERLAPS OF PAIRED STATES            '',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
              ELSE
C
                  WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *              1H*,'' THE PFAFFIAN FORMULA USED TO CALCULATE'',
     *                  '' OVERLAPS OF PAIRED STATES          '',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
              END IF
C
          END IF
C
C=======================================================================
C
          IF ((NUBKNO.GT.1.OR.NBTKNO.GT.1).AND.NEWWIG.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,'' WIGNER D FUNCTIONS CALCULATED BY'',
     *                  '' METHODS OF PHYS. REV. E 92, 043307 (2015)'',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,'' OBSOLETE METHOD TO CALCULATE WIGNER D'',
     *                  '' FUNCTIONS USED - RERUN WITH NEWWIG=1'',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          END IF
C
C=======================================================================
C
          IF (NUBKNO.GT.1.AND.KETAJ2.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,'' AVERAGE VALUES OF J^2 IN ANGULAR-MOMENTUM'',
     *                  '' PROJECTED STATES WILL BE PRINTED'', 2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          END IF
C
C=======================================================================
C
          IF (NBTKNO.GT.1.AND.KETAT2.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,'' AVERAGE VALUES OF T^2 IN ISOSPIN-PROJECTED'',
     *                  '' STATES WILL BE PRINTED'',          11X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          END IF
C
          IF (NAMKER.EQ.2.AND.NUCONF.GT.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,'' THE FOLLOWING SINGLE-REFERENCE CONFIGURATI'',
     *                  ''ONS WILL BE CONSIDERED; *=TAKEN'',   3X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *              1H*,''  NO. CONFIGURATION FILE NAME              '',
     *                  ''                               '',   3X,1H*,/,
     *              1H*,''  --- -------------------------------------'',
     *                  ''-------------------------------'',   3X,1H*)')
C
              DO I_CONF=1,NUCONF
C
                                          TACONF=' '
                 IF (INCONF(I_CONF).EQ.1) TACONF='*'
C
                 WRITE(NFIPRI,'(1H*,I4,A1,1X,A68,3X,1H*)')
     *                                      I_CONF,TACONF,FILLEF(I_CONF)
              END DO
C
              WRITE(NFIPRI,'(1H*,77X,1H*)')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUBKNO.GT.1) THEN
C
          IF (ISCHIF.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *          1H*, 1X,''REDUCED KERNELS AND MATRIX ELEMENTS:'',
     *                                                       40X,1H*,/,
     *          1H*, 1X,''FOR ELECTRIC MULTIPOLES CALCULATED UP TO'',
     *               I2,'' PRINTED IF LARGER THAN'',(1PE9.1),2X,1H*,/,
     *          1H*, 1X,''FOR MAGNETIC MULTIPOLES CALCULATED UP TO'',
     *               I2,'' PRINTED IF LARGER THAN'',(1PE9.1),2X,1H*,/,
     *          1H*, 1X,''FOR SCHIFF   MULTIPOLES CALCULATED UP TO'',
     *               I2,'' PRINTED IF LARGER THAN'',(1PE9.1),2X,1H*,/,
     *          1H*, 1X,''FOR SPIN-ASY MULTIPOLES CALCULATED UP TO'',
     *               I2,'' PRINTED IF LARGER THAN'',(1PE9.1),2X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *          NMURED,QMUCUT,NMARED,QMACUT,NSIRED,QSICUT,NASRED,QASCUT
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *          1H*, 1X,''REDUCED KERNELS AND MATRIX ELEMENTS:'',
     *                                                       40X,1H*,/,
     *          1H*, 1X,''FOR ELECTRIC MULTIPOLES CALCULATED UP TO'',
     *               I2,'' PRINTED IF LARGER THAN'',(1PE9.1),2X,1H*,/,
     *          1H*, 1X,''FOR MAGNETIC MULTIPOLES CALCULATED UP TO'',
     *               I2,'' PRINTED IF LARGER THAN'',(1PE9.1),2X,1H*,/,
     *          1H*, 1X,''FOR SURFACE  MULTIPOLES CALCULATED UP TO'',
     *               I2,'' PRINTED IF LARGER THAN'',(1PE9.1),2X,1H*,/,
     *          1H*, 1X,''FOR SPIN-ASY MULTIPOLES CALCULATED UP TO'',
     *               I2,'' PRINTED IF LARGER THAN'',(1PE9.1),2X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *          NMURED,QMUCUT,NMARED,QMACUT,NSIRED,QSICUT,NASRED,QASCUT
C
          END IF
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING THE RESULTS ONLY FOR '',
     *                    ''THE RANGE OF ANGULAR MOMENTA:'',
     *                                I2,'' <= 2*I <='',I3,2X,1H*,/,
     *            1H*,34X,''AVERAGE ENERGIES OF PROJECTED STATES: '',
     *                                                  A3,2X,1H*,/,
     *            1H*,34X,''KERNELS BETWEEN THE PROJECTED STATES: '',
     *                                                  A3,2X,1H*,/,
     *            1H*,34X,''SUM RULES COMPARED TO THE H-F VALUES: '',
     *                                                  A3,2X,1H*,/,
     *            1H*,34X,''K-MIXED ENERGIES OF PROJECTED STATES: '',
     *                                                  A3,2X,1H*,/,
     *            1H*,18X,''REDUCED  K E R N E L S  BETWEEN THE '',
     *                    ''PROJECTED STATES: '',       A3,2X,1H*,/,
     *            1H*,18X,''REDUCED MATRIX ELEMENTS BETWEEN THE '',
     *                    '' K-MIXED  STATES: '',       A3,2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *          ISLPRI,ISUPRI,
     *          NO_YES((IENPRI*(3-IENPRI))/2),
     *          NO_YES((IENPRI*(IENPRI-1))/2),
     *          NO_YES(ISRPRI),NO_YES(IMIPRI),
     *          NO_YES(IKEPRI),NO_YES(IRMPRI)
C
          IF (IELPRI.EQ.1.AND.IRMPRI.EQ.1)
     *        WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING THE REDUCED MATRIX '',
     *                    ''ELEMENTS OF THE ELECTROMAGNETIC '',
     *                    ''OPERATORS'',                   7X,1H*,/,
     *                                                1H*,77X,1H*)')
          IF (IELPRI.EQ.2.AND.IRMPRI.EQ.1)
     *        WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING THE REDUCED TRANSITION '',
     *                    ''RATES FOR THE IR ---> IL TRANSITIONS'',
     *                                                     8X,1H*,/,
     *                                                1H*,77X,1H*)')
          IF (IELPRI.EQ.3.AND.IRMPRI.EQ.1)
     *        WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING SPECTROSCOPIC MATRIX '',
     *                    ''ELEMENTS OF THE ELECTROMAGNETIC '',
     *                    ''OPERATORS'',                   5X,1H*,/,
     *                                                1H*,77X,1H*)')
          IF ((IKEPRI.EQ.1.OR.IRMPRI.EQ.1).AND.ILIMAM.EQ.1)
     *        WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *            1H*, 1X,''CALCULATING ONLY THE REDUCED '',
     *                    ''MATRIX ELEMENTS THAT ARE NEEDED '',
     *                    ''FOR PRINTING'',                3X,1H*,/,
     *                                                1H*,77X,1H*)')
          IF ((IKEPRI.EQ.1.OR.IRMPRI.EQ.1).AND.IALLAM.EQ.1)
     *        WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING NON-DIAGONAL REDUCED '',
     *                    ''MATRIX ELEMENTS FOR BOTH ORDERS '',
     *                    ''OF SPIN'',                     7X,1H*,/,
     *                                                1H*,77X,1H*)')
          IF ((IKEPRI.EQ.1.OR.IRMPRI.EQ.1).AND.IPRALL.EQ.1)
     *        WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *            1H*, 1X,''PRINTING ALL REDUCED '',
     *                    ''MATRIX ELEMENTS                 '',
     *                    ''       '',                    16X,1H*,/,
     *                                                1H*,77X,1H*)')
C
C=======================================================================
C
      END IF
C
C=======================================================================
C
      IF (IWRWAV.EQ.1)
     *
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *              1H*,'' THE WAVE FUNCTIONS FOR THE GCM KERNELS'',
     *                  '' WILL BE STORED AFTER THE ITERATIONS'',
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ISAKER.GE.1.AND.IPAKER.NE.1)
     *
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *              1H*,'' THE GCM KERNELS IN FUNCTION OF THE EULER'',
     *                  '' ANGLES WILL BE READ AND/OR STORED'',
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ISAKER.GE.1.AND.ICHKER.NE.1)
     *
     *    WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *              1H*,'' THE NAMES OF KERNEL FILES WILL  N O T  BE'',
     *                  '' COMPARED WITH THE RECORDED NAMES'',
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*)')
C
C=======================================================================
C
      IF (IPRGCM.GE.2) THEN
C
          WRITE(FFRGCM,'(I3)') IABS(IFRWAV)
            IF (FFRGCM(1:1).EQ.' ') FFRGCM(1:1)='0'
            IF (FFRGCM(2:2).EQ.' ') FFRGCM(2:2)='0'
C
          WRITE(FTOGCM,'(I3)') ITOWAV
            IF (FTOGCM(1:1).EQ.' ') FTOGCM(1:1)='0'
            IF (FTOGCM(2:2).EQ.' ') FTOGCM(2:2)='0'
C
          IF (IFRWAV.GT.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,'' THE GENERATOR COORDINATE KERNELS  WILL BE'',
     *                  '' CALCULATED BETWEEN "LEFT" STATES'', 2X,1H*,/,
     *              1H*,'' THAT ARE NUMBERED BETWEEN '',A3,
     *                  '' AND '',A3,'','',
     *                  '' AND "RIGHT" ONE  HAVING  NUMBER '',A3,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*)')
     *
     *        FFRGCM,FTOGCM,FTOGCM
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,'' THE GENERATOR COORDINATE KERNELS  WILL BE '',
     *                  '' CALCULATED BETWEEN "LEFT" STATE'', 2X,1H*,/,
     *              1H*,'' HAVING NUMBER '',A3,
     *                  '' AND THE "RIGHT" STATE HAVING NUMBER '',A3,
     *                                                        19X,1H*,/,
     *              1H*,77X,1H*)')
     *
     *        FFRGCM,FTOGCM
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IADBAT.EQ.1 .AND. IABMOD.EQ.0) THEN
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *      1H*,1X, ''ADIABATIC PARAMETERS WILL BE READ '',
     *              ''INTERACTIVELY IN DEBUG MODE'',          15X,1H*/,
     *                                                   1H*,77X,1H*)')
      END IF
C
      IF (IADBAT.EQ.1 .AND. IABMOD.NE.0) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *      1H*,18X,'' INFORMATION ON THE ADIABATIC CALCULATION '',
     *                                                       17X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                                        79(1H*),/, 1H*,77X,1H*,/,
     *      1H*,1X,''MAXIMUM ITERATION: IABNTE = '', I4,
     *             '' REQUESTED PRECISION: DABPRS ='',  E9.2, 5X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *      1H*,1X,''THE PARAMETERS DEFINING THE COLLECTIVE MOTION: '',
     *             ''IABCOL ='', I4,''  IABICH ='', I4,       3X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *      1H*,1X,''MIXING COEFFICIENT: XCHIMX ='',    F5.2,43X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *      IABNTE,DABPRS,IABCOL,IABICH,XCHIMX
C
      END IF
C
      IF (IADBAT.EQ.1 .AND. IFAMON.EQ.1) THEN
          WRITE(NFIPRI,'(79(1H*),/,                1H*,77X,1H*,/,
     *  1H*,1X,''FINITE AMPLITUDE METHOD WILL BE USED:  '',
     *                                                 ''ETA = '',
     *                                            E12.5,19X,1H*,/,
     *                                             1H*,77X,1H*)')
     *  ETAFAM
      END IF
C
C=======================================================================
C
      IF (JETA_T.GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH THE SKYRME TENSOR '',
     *                        ''INTERACTION INCLUDED'',   20X,1H*,/,
     *                                                1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (JETAPA.GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH THE SKYRME PAIRING '',
     *                        ''INTERACTION INCLUDED'',   19X,1H*,/,
     *                                                1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (JETAPA.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH THE SPIN-ORBIT IN '',
     *                        ''THE PAIRING CHANNEL NOT INCLUDED'',
     *                                                     8X,1H*,/,
     *                                                1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IPAIRI.NE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITHOUT PAIRING'',
     *                                                    48X,1H*,/,
     *                                                1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (ITIREP.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                    1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH CONSERVED '',
     *                        ''TIME-REVERSAL SYMMETRY IN THE '',
     *                        ''PAIRING  CHANNEL'',         2X,1H*,/,
     *                                                 1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (IPAHFB.GE.1.AND.IQPSTA.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                    1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH THE QUASIPARTICLE '',
     *                        ''EXPRESSION FOR THE STABILITY '',
     *                        ''ENERGY   '',                2X,1H*,/,
     *                                                 1H*,77X,1H*)')
C
      END IF
C
C=======================================================================
C
      IF (ISPHER.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *             1H*,1X,''CALCULATIONS WITH THE SPHERICAL'',
     *                                          '' SYMMETRY'',
     *                                                36X,1H*,/,
     *                                            1H*,77X,1H*)')
C
      ELSE
C
          IF (ISIMPY.EQ.1) THEN
C
              IF (ISIGNY.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                     1H*,1X,''CALCULATIONS WITH'',
     *                               '' PARITY/SIGNATURE SYMMETRY'',
     *                                                    33X,1H*,/,
     *                                                1H*,77X,1H*)')
C
                  IF ((NLSIGN.NE.0.OR.NLSIGP.NE.0).AND.IPAIRI.NE.1)
     *
     *                WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                             1H*,1X,''CALCULATIONS WITH '',
     *                                    ''FIXED NUMBERS OF STATES '',
     *                                    ''OCCUPIED IN THE OMEGA '',
     *                                    ''BLOCKS FOR'',      2X,1H*,/,
     *                            1H*,52X,''NLSIGN='',I2,'' AND '',
     *                                    ''NLSIGP='',I2,      2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                NLSIGN,NLSIGP
C
              ELSE
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                     1H*,1X,''CALCULATIONS WITH SIMPLEX'',
     *                                                '' SYMMETRY'',
     *                                                    42X,1H*,/,
     *                                                1H*,77X,1H*)')
C
                  IF ((NLSIMN.NE.0.OR.NLSIMP.NE.0).AND.IPAIRI.NE.1)
     *
     *                WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                             1H*,1X,''CALCULATIONS WITH '',
     *                                    ''FIXED NUMBERS OF STATES '',
     *                                    ''OCCUPIED IN THE OMEGA '',
     *                                    ''BLOCKS FOR'',      2X,1H*,/,
     *                            1H*,52X,''NLSIMN='',I2,'' AND '',
     *                                    ''NLSIMP='',I2,      2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                NLSIMN,NLSIMP
C
              END IF
C
C=======================================================================
C
          ELSE
C
              IF (ISIQTY.EQ.1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                         1H*,1X,''CALCULATIONS WITH PARITY'',
     *                                                '' SYMMETRY'',
     *                                                    43X,1H*,/,
     *                                                1H*,77X,1H*)')
C
                  IF ((NLSIQN.NE.0.OR.NLSIQP.NE.0).AND.IPAIRI.NE.1)
     *
     *                WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                             1H*,1X,''CALCULATIONS WITH '',
     *                                    ''FIXED NUMBERS OF STATES '',
     *                                    ''OCCUPIED IN THE OMEGA '',
     *                                    ''BLOCKS FOR'',      2X,1H*,/,
     *                            1H*,52X,''NLSIQN='',I2,'' AND '',
     *                                    ''NLSIQP='',I2,      2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                NLSIQN,NLSIQP
C
              ELSE
C
                  IF (ISIGNY.EQ.1) THEN
C
                      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                             1H*,1X,''CALCULATIONS WITH'',
     *                                          '' SIGNATURE SYMMETRY'',
     *                                                        40X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
                  ELSE
C
                      WRITE(NFIPRI,'(79(1H*),/,         1H*,77X,1H*,/,
     *                           1H*,1X,''CALCULATIONS WITHOUT '',
     *                                  ''SIMPLEX, SIGNATURE, OR '',
     *                                  ''PARITY SYMMETRIES'',
     *                                                      15X,1H*,/,
     *                                                  1H*,77X,1H*)')
C
                      IF ((NLSIZN.NE.0.OR.NLSIZP.NE.0).AND.IPAIRI.NE.1)
     *
     *                    WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *                             1H*,1X,''CALCULATIONS WITH '',
     *                                    ''FIXED NUMBERS OF STATES '',
     *                                    ''OCCUPIED IN THE OMEGA '',
     *                                    ''BLOCKS FOR'',      2X,1H*,/,
     *                            1H*,52X,''NLSIZN='',I2,'' AND '',
     *                                    ''NLSIZP='',I2,      2X,1H*,/,
     *                                                    1H*,77X,1H*)')
     *                    NLSIZN,NLSIZP
C
                  END IF
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IAXIAP.EQ.1) THEN
C
          IF (IPAIRI.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH ENFORCED AXIAL SYM'',
     *                        ''METRY OF THE P-H AND P-P MEAN FIELDS'',
     *                                                 4X,1H*,/,
     *                                            1H*,77X,1H*)')
          ELSE
              WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH ENFORCED AXIAL SYM'',
     *                        ''METRY OF THE P-H MEAN FIELDS'',
     *                                                 12X,1H*,/,
     *                                            1H*,77X,1H*)')
          END IF
C
      ELSEIF (IAXIAP.EQ.-1) THEN
C
          IF (IPAIRI.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH ENFORCED AXIAL SYM'',
     *                        ''METRY OF P-H & P-P FIELDS & DENSITIES'',
     *                                                 3X,1H*,/,
     *                                            1H*,77X,1H*)')
          ELSE
              WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH ENFORCED AXIAL SYM'',
     *                        ''METRY OF THE P-H FIELDS & DENSITIES'',
     *                                                 5X,1H*,/,
     *                                            1H*,77X,1H*)')
          END IF
C
      END IF
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *     1H*,1X,''CALCULATIONS WITH TIME-ODD SYMMETRIES:'',
     *         8X,''T*SIMPLEX_X => '',A3,'' CONSERVED'',
     *                                         2X,1H*,/,
     *     1H*,1X,''                                      '',
     *         8X,''T*SIMPLEX_Y => '',A3,'' CONSERVED'',
     *                                         2X,1H*,/,
     *     1H*,1X,''                                      '',
     *         8X,''T*SIMPLEX_Z => '',A3,'' CONSERVED'',
     *                                         2X,1H*,/,
     *                                    1H*,77X,1H*)')
     *
     *    NONYES(ISIMTX),NONYES(JSIMTY),NONYES(ISIMTZ)
C
C=======================================================================
C
      IF (.NOT.DOSYMM)
     *
     *    WRITE(NFIPRI,'(79(1H*),/,           1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH OMITTED SYMMETRIZAT'',
     *                        ''ION OF DENSITIES WRT CARTESIAN PLANES'',
     *                                             2X,1H*,/,
     *                                        1H*,77X,1H*)')
C
C=======================================================================
C
      IF (ISYMDE.EQ.1) THEN
C
          IF (ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.
     *        ISIMTX.NE.1.AND.JSIMTY.NE.1.AND.ISIMTZ.NE.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,1X,''THE ISYMDE=1 PARAMETER HAS BEEN SET I'',
     *                        ''N THE INPUT DATA. HENCE THE DENSITIES'',
     *                                                         2X,1H*,/,
     *                 1H*,1X,''WILL BE TESTED FOR PRESENCE OF ANY OF'',
     *                        '' THE THREE PLANE SYMMETRIES.         '',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,1X,''ATTENTION:  THE  ISYMDE=1  PARAMETER '',
     *                        ''HAS BEEN SET IN THE INPUT DATA. HENCE'',
     *                                                         2X,1H*,/,
     *                 1H*,1X,''FOR ITERATIONS WHEN RESULTS ARE PRINT'',
     *                        ''ED, THE DENSITIES WILL BE  CALCULATED'',
     *                                                         2X,1H*,/,
     *                 1H*,1X,''WITHOUT ASSUMING ANY SPACE SYMMETRIES'',
     *                        '' AND SUBSEQUENTLY TESTED FOR PRESENCE'',
     *                                                         2X,1H*,/,
     *                 1H*,1X,''OF ANY OF THE THREE PLANE SYMMETRIES.'',
     *                        ''                                     '',
     *                                                         2X,1H*,/,
     *                                                    1H*,77X,1H*)')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IROTAT.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITH BROKEN TIME-'',
     *                        ''REVERSAL SYMMETRY'',        29X,1H*,/,
     *                                                  1H*,77X,1H*)')
C
          IF (ITILAX.EQ.0.AND.ITISAX.EQ.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,
     *                  1H*,77X,1H*,/,
     *                  1H*,1X,''CALCULATIONS WITH ONE-DIMENSIONAL '',
     *                         ''CRANKING '',
     *                         ''FOR THE ROTATIONAL FREQUENCIES:'',
     *                       2X,1H*,/,
     *                  1H*,77X,1H*,/,
     *                  1H*,1X,''OMEGAY ='',F9.6,'' (ISOSCALAR)'',
     *                         ''      AND       '',
     *                         ''OMISOY ='',F9.6,'' (ISOVECTOR)'',
     *                       2X,1H*,/,
     *                  1H*,77X,1H*)')
     *
     *        OMEGAY,OMISOY
C
          ELSE
C
              IF (IMOVAX.GT.0)
     *
     *            WRITE(NFIPRI,'(79(1H*),/,
     *                  1H*,77X,1H*,/,
     *                  1H*,1X,''CALCULATIONS WITH ADJUSTABLE '',
     *                         ''ISOSCALAR ROTATIONAL FREQUENCY '',
     *                         ''VECTOR,  WHICH'',2X,1H*,/,
     *                  1H*,1X,''IN EACH ITERATION IS TURNED '',
     *                         ''TO BE PARALLEL TO THE ANGULAR '',
     *                         ''MOMENTUM  VECTOR'',2X,1H*,/,
     *                  1H*,77X,1H*)')
C
              IF (IMOVAX.LT.0)
     *
     *            WRITE(NFIPRI,'(79(1H*),/,
     *                  1H*,77X,1H*,/,
     *                  1H*,1X,''CALCULATIONS WITH ADJUSTABLE '',
     *                         ''ISOSCALAR ROTATIONAL FREQUENCY '',
     *                         ''VECTOR,  WHICH'',2X,1H*,/,
     *                  1H*,1X,''IN EACH ITERATION IS TURNED '',
     *                         ''ANTI-PARALLELLY TO THE ANGULAR '',
     *                         ''MOMENTUM VECTOR'',2X,1H*,/,
     *                  1H*,77X,1H*)')
C
              IF (IMOVAX.NE.0.AND.IOCONT.EQ.0)
     *
     *            WRITE(NFIPRI,'(
     *                  1H*,1X,''DIRECTION OF THE ROTATIONAL '',
     *                         ''FREQUENCY VECTOR THAT IS GIVEN '',
     *                         ''BELOW  WILL  BE'',2X,1H*,/,
     *                  1H*,1X,''USED ONLY IN THE FIRST ITERATION, '',
     *                         ''AND LATER WILL BE IGNORED'',17X,1H*,/,
     *                  1H*,77X,1H*)')
C
              IF (IMOVAX.NE.0.AND.IOCONT.NE.0)
     *
     *            WRITE(NFIPRI,'(
     *                  1H*,1X,''DIRECTION OF THE ROTATIONAL '',
     *                         ''FREQUENCY VECTOR THAT IS GIVEN '',
     *                         ''BELOW  WILL  BE'',2X,1H*,/,
     *                  1H*,1X,''IGNORED, AND ONLY ITS LENGTH WILL '',
     *                         ''BE USED DURING THE ITERATION'',
     *                      14X,1H*,/,
     *                  1H*,77X,1H*)')
C
              IF (ITILAX.NE.0)
     *
     *            WRITE(NFIPRI,'(79(1H*),/,
     *                  1H*,77X,1H*,/,
     *                  1H*,1X,''CALCULATIONS WITH THE TILTED-AXIS '',
     *                         ''CRANKING'',34X,1H*,/,
     *                  1H*,77X,1H*,/,
     *                  1H*,1X,''FOR THE ISOSCALAR ROTATIONAL '',
     *                         ''FREQUENCIES OF:'',32X,1H*,/,
     *                  1H*,77X,1H*,/
     *                  1H*,1X,''OMEGAX ='',F9.6,2X,''OMEGAY ='',F9.6,
     *                         2X,''OMEGAZ ='',F9.6,3X,
     *                         ''OMEGA ='',F9.6,
     *                         2X,1H*,/,
     *                  1H*,77X,1H*)')
     *
     *        OMEGAX,OMEGAY,OMEGAZ,
     *        SQRT(OMEGAX**2+OMEGAY**2+OMEGAZ**2)
C
              IF (ITISAX.NE.0)
     *
     *            WRITE(NFIPRI,'(79(1H*),/,
     *                  1H*,77X,1H*,/,
     *                  1H*,1X,''CALCULATIONS WITH THE TILTED-AXIS '',
     *                         ''CRANKING'',34X,1H*,/,
     *                  1H*,77X,1H*,/,
     *                  1H*,1X,''FOR THE ISOVECTOR ROTATIONAL '',
     *                         ''FREQUENCIES OF:'',32X,1H*,/,
     *                  1H*,77X,1H*,/
     *                  1H*,1X,''OMISOX ='',F9.6,2X,''OMISOY ='',F9.6,
     *                         2X,''OMISOZ ='',F9.6,3X,
     *                         ''OMISO ='',F9.6,
     *                         2X,1H*,/,
     *                  1H*,77X,1H*)')
     *
     *        OMISOX,OMISOY,OMISOZ,
     *        SQRT(OMISOX**2+OMISOY**2+OMISOZ**2)
C
          END IF
C
          IF (IFLAGI(1).NE.0.OR.IFLAGI(2).NE.0.OR.IFLAGI(3).NE.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*,1X,''CALCULATIONS WITH QUADRATIC '',
     *                       ''CONSTRAINT ON SPIN:'',     29X,1H*,/,
     *                                                1H*,77X,1H*)')
              IF (IFLAGI(1).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''X-DIRECTION: SPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKEDI(1),STIFFI(1)
C
              IF (IFLAGI(2).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Y-DIRECTION: SPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKEDI(2),STIFFI(2)
C
              IF (IFLAGI(3).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Z-DIRECTION: SPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKEDI(3),STIFFI(3)
C
              WRITE(NFIPRI,'(                         1H*,77X,1H*)')
C
          END IF
C
          IF (IFTAGI(1).NE.0.OR.IFTAGI(2).NE.0.OR.IFTAGI(3).NE.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*,1X,''CALCULATIONS WITH QUADRATIC ISOVECTOR '',
     *                       ''CONSTRAINT ON SPIN:'',     19X,1H*,/,
     *                                                1H*,77X,1H*)')
              IF (IFTAGI(1).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''X-DIRECTION: SPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKETI(1),STIFTI(1)
C
              IF (IFTAGI(2).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Y-DIRECTION: SPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKETI(2),STIFTI(2)
C
              IF (IFTAGI(3).NE.0)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Z-DIRECTION: SPIN PROJECTION '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*)')
     *            ASKETI(3),STIFTI(3)
C
              WRITE(NFIPRI,'(                         1H*,77X,1H*)')
C
          END IF
C
          IF (IFLALI(1).EQ.1.OR.IFLALI(2).EQ.1.OR.IFLALI(3).EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*,1X,''CALCULATIONS WITH AUGMENTED '',
     *                       ''CONSTRAINT ON SPIN:'',     29X,1H*,/,
     *                                                1H*,77X,1H*)')
              IF (IFLALI(1).EQ.1.AND.ISCONT.NE.1)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''X-DIRECTION: INITIAL CORRECTION '',
     *                       ''TO THE ANGULAR FREQUENCY EQUALS TO'',
     *                                                F8.4,2X,1H*)')
     *            DALSPI(1)
C
              IF (IFLALI(2).EQ.1.AND.ISCONT.NE.1)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Y-DIRECTION: INITIAL CORRECTION '',
     *                       ''TO THE ANGULAR FREQUENCY EQUALS TO'',
     *                                                F8.4,2X,1H*)')
     *            DALSPI(2)
C
              IF (IFLALI(3).EQ.1.AND.ISCONT.NE.1)
     *            WRITE(NFIPRI,'(
     *                1H*,1X,''Z-DIRECTION: INITIAL CORRECTION '',
     *                       ''TO THE ANGULAR FREQUENCY EQUALS TO'',
     *                                                F8.4,2X,1H*)')
     *            DALSPI(3)
C
              IF (ISCONT.NE.1)
     *            WRITE(NFIPRI,'(                     1H*,77X,1H*)')
C
          END IF
C
          IF (IFLAGA.NE.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*,1X,''CALCULATIONS WITH QUADRATIC '',
     *                       ''CONSTRAINT ON VECTOR PRODUCT '',
     *                       ''OMEGA TIMES SPIN:'',        2X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                1H*,1X,''                             '',
     *                       ''CONSTRAINED TO'',F8.3,1X,
     *                       ''WITH STIFFNESS'',F8.4,       2X,1H*,/,
     *                                                 1H*,77X,1H*)')
     *        ASKEDA,STIFFA
C
          END IF
C
          IF (NO_ORB.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,               1H*,77X,1H*,/,
     *                1H*,1X,''CALCULATIONS WITH CONSTRAINTS '',
     *                       ''ON THE ITRINSIC SPIN ONLY -- '',
     *                       ''NO ORBITAL PART'',          2X,1H*,/,
     *                                                 1H*,77X,1H*)')
C
          END IF
C
      ELSE
C
          WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,1X,''CALCULATIONS WITHOUT ROTATION'',
     *                                                    47X,1H*,/,
     *                                                1H*,77X,1H*)')
C
      END IF
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
      IF (IFSHEL.GE.1) THEN
C
          WRITE(NFIPRI,'(''*'',77X,''*'',/,
     *              ''* THE SHELL CORRECTION WILL BE COMPUTED '',
     *              ''AT THE LAST ITERATION                 *'')')
C
          IF (IPAHFB.EQ.0) THEN
              WRITE(NFIPRI,'(''*  - BASED ON HARTREE-FOCK '',
     *              ''SINGLE-PARTICLE ENERGIES (IPAHFB=0)'',16X,''*'')')
          ELSE
              IF (IMFHFB.EQ.0) THEN
                  WRITE(NFIPRI,'(''*  - BASED ON HFB EQUIVALENT '',
     *                         ''SPECTRUM (IPAHFB=1 AND IMFHFB=0)'',
     *                           17X,''*'')')
              END IF
              IF (IMFHFB.EQ.1) THEN
                  WRITE(NFIPRI,'(''*  - BASED ON HFB CANONICAL '',
     *                         ''SPECTRUM (IPAHFB=1 AND IMFHFB=1)'',
     *                           18X,''*'')')
              END IF
          END IF
C
          IF (IFSHEL.EQ.1) THEN
              WRITE(NFIPRI,'(''*  - NOT CORRECTED FOR THE '',
     *              ''CONTRIBUTION OF CONTINUUM STATES '',
     *              ''(IFSHEL=1)'',8X,''*'')')
          END IF
C
          IF (IFSHEL.EQ.2) THEN
              WRITE(NFIPRI,'(''*  - CORRECTED FOR THE '',
     *              ''CONTRIBUTION OF CONTINUUM STATES '',
     *              ''(IFSHEL=2)'',12X,''*'')')
          END IF
C
          WRITE(NFIPRI,'(''*  - WITH: GSTRUN = '',F4.2,''  GSTRUP = '',
     *                   F4.2,''  HOMFAC = '',F8.2,''  NPOLYN = '',I2,
     *                   7X,''*'',/,''*'',77X,''*'',/,79(''*''))')
     *                  GSTRUN,GSTRUP,HOMFAC,NPOLYN
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZEROUT
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      COMPLEX
     *          C_ZERO
      COMPLEX
     *          EGOGSD,EGOGSE,EGOGVD,EGOGVE,
     *          EGOTSD,EGOTSE,EGOTVD,EGOTVE,
     *          EGOSSD,EGOSSE,EGOSVD,EGOSVE,
     *          EGOPSD,EGOPSE,EGOPVD,EGOPVE,
     *          EGOMSD,EGOMSE,EGOMVD,EGOMVE
      COMPLEX
     *          EGOGSP,EGOGVP
C
      COMMON
     *       /SIGOCC/ N_OCCU(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS),
     *                N_OCVA(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMOCC/ L_OCCU(1:NDSTAT,0:NDREVE,0:NDISOS),
     *                L_OCVA(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIQOCC/ K_OCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *                K_OCVA(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIZOCC/ M_OCCU(1:2*NDSTAT,0:NDISOS),
     *                M_OCVA(1:2*NDSTAT,0:NDISOS)
C
      COMMON
     *       /SIGACT/ N_OCAC(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMACT/ L_OCAC(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIQACT/ K_OCAC(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIZACT/ M_OCAC(1:2*NDSTAT,0:NDISOS)
C
      COMMON
     *       /MIGOCC/ NMOCCU(1:2*NDSTAT,0:NDPARI,0:NDREVE),
     *                NMOCVA(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIMOCC/ LMOCCU(1:2*NDSTAT,0:NDREVE),
     *                LMOCVA(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /MIQOCC/ KMOCCU(1:4*NDSTAT,0:NDPARI),
     *                KMOCVA(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /MIZOCC/ MMOCCU(1:4*NDSTAT),
     *                MMOCVA(1:4*NDSTAT)
C
      COMMON
     *       /MIGACT/ NMOCAC(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIMACT/ LMOCAC(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /MIQACT/ KMOCAC(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /MIZACT/ MMOCAC(1:4*NDSTAT)
C
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /LINMOM/ DLINSN(0:NDKART),DLINSP(0:NDKART),DLINST(0:NDKART)
     *               ,ELINSN(0:NDKART),ELINSP(0:NDKART),ELINST(0:NDKART)
     *               ,TLINSN(0:NDKART),TLINSP(0:NDKART),TLINST(0:NDKART)
     *               ,ALINLN(0:NDKART),ALINLP(0:NDKART),ALINLT(0:NDKART)
      COMMON
     *       /SHIANG/ ANGS_N(1:NDKART),ANGS_P(1:NDKART),ANGS_T(1:NDKART)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BMULTI/ BMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                BMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                BMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /AMULTI/ AMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /QSHIFT/ QSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /WMULTI/ WMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /BSHIFT/ BSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                BSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                BSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SSHIFT/ SSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                SSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                SSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ASHIFT/ ASHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                ASHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                ASHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ASHIXX/ ASHIXN(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                ASHIXP(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                ASHIXT(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /QROTAT/ QROT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QROT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QROT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BROTAT/ BROT_N(0:NDMULT,-NDMULT:NDMULT),
     *                BROT_P(0:NDMULT,-NDMULT:NDMULT),
     *                BROT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SROTAT/ SROTNN(0:NDMULT,-NDMULT:NDMULT),
     *                SROTNP(0:NDMULT,-NDMULT:NDMULT),
     *                SROTNT(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /AROTAT/ AROTNN(0:NDMULT,-NDMULT:NDMULT),
     *                AROTNP(0:NDMULT,-NDMULT:NDMULT),
     *                AROTNT(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /AROTXX/ AROTXN(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AROTXP(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AROTXT(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SENTRO/ ENTRPY(0:NDISOS)
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /EN_GOG/ EGOGSD(0:NDISOS,0:NDISOS),
     *                EGOGSE(0:NDISOS,0:NDISOS),
     *                EGOGVD(0:NDISOS,0:NDISOS),
     *                EGOGVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_GTS/ EGOTSD,EGOTSE,EGOTVD,EGOTVE,
     *                EGOSSD,EGOSSE,EGOSVD,EGOSVE
     *
     *       /EN_GPM/ EGOPSD,EGOPSE,EGOPVD,EGOPVE,
     *                EGOMSD,EGOMSE,EGOMVD,EGOMVE
      COMMON
     *       /PN_GOG/ EGOGSP(0:NDISOS),EGOGVP(0:NDISOS)
     *
     *       /PGOGTT/ EGOGPT
      COMMON
     *       /ISOENE/ EISOCO,EISSLO,EISREA
C
C=======================================================================
C      THIS SUBROUTINE INITIALIZES SOME OF THE  *OUTPUT* VARIABLES
C      GENERATED BY THE CODE, WHILE THE ROUTINE PREDEF INITIALIZES
C      *INPUT* DATA.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C      Proton-neutron mixing
C
      EISOCO=0.0
      EISSLO=0.0
      EISREA=0.0
C
C      Gogny force
C
      EGOGSD(:,:)=C_ZERO
      EGOGSE(:,:)=C_ZERO
      EGOGVD(:,:)=C_ZERO
      EGOGVE(:,:)=C_ZERO
C
      EGOTSD=C_ZERO
      EGOTSE=C_ZERO
      EGOTVD=C_ZERO
      EGOTVE=C_ZERO
      EGOSSD=C_ZERO
      EGOSSE=C_ZERO
      EGOSVD=C_ZERO
      EGOSVE=C_ZERO
C
      EGOPSD=C_ZERO
      EGOPSE=C_ZERO
      EGOPVD=C_ZERO
      EGOPVE=C_ZERO
      EGOMSD=C_ZERO
      EGOMSE=C_ZERO
      EGOMVD=C_ZERO
      EGOMVE=C_ZERO
C
C      Gogny pairing
C
      EGOGSP(:)=C_ZERO
      EGOGVP(:)=C_ZERO
C
C      Pairing
C
      GPAIRN=0.0D0
      GPAIRP=0.0D0
C
      EFERMN=-8.0D0
      EFERMP=-8.0D0
C
      DELTAN=1.0D0
      DELTAP=1.0D0
C
      EFER2N=0.1D0
      EFER2P=0.1D0
C
C      Temperature
C
      ENTRPY(:)=0.0D0
      FERMFN(:,:)=0.0D0
C
      IDEBLO(:)=0
C
C      Configurations
C
      N_OCCU(:,:,:,:)=0
      N_OCVA(:,:,:,:)=0
      N_OCAC(:,:,:,:)=0
C
      L_OCCU(:,:,:)=0
      L_OCVA(:,:,:)=0
      L_OCAC(:,:,:)=0
C
      K_OCCU(:,:,:)=0
      K_OCVA(:,:,:)=0
      K_OCAC(:,:,:)=0
C
      M_OCCU(:,:)=0
      M_OCVA(:,:)=0
      M_OCAC(:,:)=0
C
      NMOCCU(:,:,:)=0
      NMOCVA(:,:,:)=0
      NMOCAC(:,:,:)=0
C
      LMOCCU(:,:)=0
      LMOCVA(:,:)=0
      LMOCAC(:,:)=0
C
      KMOCCU(:,:)=0
      KMOCVA(:,:)=0
      KMOCAC(:,:)=0
C
      MMOCCU(:)=0
      MMOCVA(:)=0
      MMOCAC(:)=0
C
C      Observables related to angular and linear momentum
C
      ANGU_N(:)=0.0D0
      ANGU_P(:)=0.0D0
      ANGU_T(:)=0.0D0
C
      ANGS_N(:)=0.0D0
      ANGS_P(:)=0.0D0
      ANGS_T(:)=0.0D0
C
      DLINSN(:)=0.0D0
      DLINSP(:)=0.0D0
      DLINST(:)=0.0D0
      ELINSN(:)=0.0D0
      ELINSP(:)=0.0D0
      ELINST(:)=0.0D0
      TLINSN(:)=0.0D0
      TLINSP(:)=0.0D0
      TLINST(:)=0.0D0
      ALINLN(:)=0.0D0
      ALINLP(:)=0.0D0
      ALINLT(:)=0.0D0
C
C      Observables related to multipole moments
C
      QMUL_N(:,:)=0.0D0
      QMUL_P(:,:)=0.0D0
      QMUL_T(:,:)=0.0D0
C
      BMUL_N(:,:)=0.0D0
      BMUL_P(:,:)=0.0D0
      BMUL_T(:,:)=0.0D0
C
      SMUL_N(:,:)=0.0D0
      SMUL_P(:,:)=0.0D0
      SMUL_T(:,:)=0.0D0
C
      AMUL_N(:,:,:)=0.0D0
      AMUL_P(:,:,:)=0.0D0
      AMUL_T(:,:,:)=0.0D0
C
      WMUL_N(:,:,:)=0.0D0
      WMUL_P(:,:,:)=0.0D0
      WMUL_T(:,:,:)=0.0D0
C
      QSHI_N(:,:)=0.0D0
      QSHI_P(:,:)=0.0D0
      QSHI_T(:,:)=0.0D0
C
      BSHI_N(:,:)=0.0D0
      BSHI_P(:,:)=0.0D0
      BSHI_T(:,:)=0.0D0
C
      SSHI_N(:,:)=0.0D0
      SSHI_P(:,:)=0.0D0
      SSHI_T(:,:)=0.0D0
C
      ASHI_N(:,:)=0.0D0
      ASHI_P(:,:)=0.0D0
      ASHI_T(:,:)=0.0D0
C
      ASHIXN(:,:,:)=0.0D0
      ASHIXP(:,:,:)=0.0D0
      ASHIXT(:,:,:)=0.0D0
C
      QROT_N(:,:)=0.0D0
      QROT_P(:,:)=0.0D0
      QROT_T(:,:)=0.0D0
C
      BROT_N(:,:)=0.0D0
      BROT_P(:,:)=0.0D0
      BROT_T(:,:)=0.0D0
C
      SROTNN(:,:)=0.0D0
      SROTNP(:,:)=0.0D0
      SROTNT(:,:)=0.0D0
C
      AROTNN(:,:)=0.0D0
      AROTNP(:,:)=0.0D0
      AROTNT(:,:)=0.0D0
C
      AROTXN(:,:,:)=0.0D0
      AROTXP(:,:,:)=0.0D0
      AROTXT(:,:,:)=0.0D0
C
C      Linear constraint parameter
C
      GALMUQ(:,:)=0.0D0
C
C      Linear isovector constraint parameter
C
      GALMUV(:,:)=0.0D0
C
C      Linear spin constraint parameter
C
      GALSPI(:)=0.0D0
C
C      Linear isospin constraint parameter
C
      GALISO(:)=0.0D0
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FINPRI(NMUCON,NSICON,ISCHIF)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      IANYBL=0
      ITITLE=0
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALQ(LAMBDA,MIU).EQ.1) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''AUGMENTED MULTIPOLE CONSTRAINTS: '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PARAM.='',F6.3,2X,1H*)')
     *
     *              LAMBDA,MIU,GALMUQ(LAMBDA,MIU)
C
                    IANYBL=1
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(
     *                    1H*,1X,''                                 '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PARAM.='',F6.3,2X,1H*)')
     *
     *              LAMBDA,MIU,GALMUQ(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALV(LAMBDA,MIU).EQ.1) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                    1H*,1X,''AUGMENTED ISOV MULT CONSTRAINTS: '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PARAM.='',F6.3,2X,1H*)')
     *
     *              LAMBDA,MIU,GALMUV(LAMBDA,MIU)
C
                    IANYBL=1
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(
     *                    1H*,1X,''                                 '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''LAGRANGE PARAM.='',F6.3,2X,1H*)')
     *
     *              LAMBDA,MIU,GALMUV(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      ITITLE=0
C
      DO LAMBDA=1,NSICON
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALS(LAMBDA,MIU).GT.0) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*)')
C
                    IF (IFLALS(LAMBDA,MIU).EQ.2)
     *                  WRITE(NFIPRI,'(1H*,1X,
     *                           ''FOR NEUTRONS WE USE:'')')
C
                    IF (IFLALS(LAMBDA,MIU).EQ.3)
     *                  WRITE(NFIPRI,'(1H*,1X,
     *                           ''FOR PROTONS WE USE:'')')
C
                    IF (ISCHIF.EQ.1) THEN
C
                        WRITE(NFIPRI,'(1H*,1X,
     *                           ''AUGMENTED SCHIFF  CONSTRAINTS:   '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''FINAL LAGR. '',
     *                           ''PAR='',F6.3,     2X,1H*)')
     *
     *                  LAMBDA,MIU,GALMUS(LAMBDA,MIU)
C
                    ELSE
C
                        WRITE(NFIPRI,'(1H*,1X,
     *                           ''AUGMENTED SURFACE CONSTRAINTS:   '',
     *                           ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                           ''FINAL LAGR. '',
     *                           ''PAR='',F6.3,     2X,1H*)')
     *
     *                  LAMBDA,MIU,GALMUS(LAMBDA,MIU)
C
                    END IF
C
                    IANYBL=1
                    ITITLE=1
C
                ELSE
C
                    WRITE(NFIPRI,'(1H*,1X,
     *                       ''                                 '',
     *                       ''LAMBDA='',I2,''  MIU='',I2,2X,
     *                       ''FINAL LAGR. '',
     *                       ''PAR='',F6.3,     2X,1H*)')
     *
     *              LAMBDA,MIU,GALMUS(LAMBDA,MIU)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*)')
      IF (IANYBL.EQ.1) WRITE(NFIPRI,'(79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FINSPI
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      ITITLE=0
C
      DO KARTEZ=1,NDKART
C
         IF (IFLALI(KARTEZ).EQ.1) THEN
C
             IF (ITITLE.EQ.0) THEN
C
                 WRITE(NFIPRI,'(/,79(1H*),/,1H*,77X,1H*,/,
     *                 1H*,1X,''AUGMENTED SPIN CONSTR. FOR '',
     *                        ''COMPONENT='',I2,
     *                        '', ANG. FREQUENCY CORRECTION='',
     *                                  F7.4,2X,1H*)')
     *
     *           KARTEZ,GALSPI(KARTEZ)
C
                 ITITLE=1
C
             ELSE
C
                 WRITE(NFIPRI,'(
     *                 1H*,1X,''                           '',
     *                        ''COMPONENT='',I2,
     *                        '', ANG. FREQUENCY CORRECTION='',
     *                                  F7.4,2X,1H*)')
     *
     *           KARTEZ,GALSPI(KARTEZ)
C
             END IF
C
         END IF
C
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*/79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FINISO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      ITITLE=0
C
      DO KARTEZ=1,NDKART
C
         IF (IFLALT(KARTEZ).EQ.1) THEN
C
             IF (ITITLE.EQ.0) THEN
C
                 WRITE(NFIPRI,'(/,79(1H*),/,1H*,77X,1H*,/,
     *                 1H*,1X,''AUGMENTED ISOSPIN CNSTR. FOR '',
     *                        ''DIRECTION='',I2,
     *                        '', FERMI-ENERGY CORRECTION='',
     *                                  F7.4,2X,1H*)')
     *
     *           KARTEZ,GALISO(KARTEZ)
C
                 ITITLE=1
C
             ELSE
C
                 WRITE(NFIPRI,'(
     *                 1H*,1X,''                             '',
     *                        ''DIRECTION='',I2,
     *                        '', FERMI-ENERGY CORRECTION='',
     *                                  F7.4,2X,1H*)')
     *
     *           KARTEZ,GALISO(KARTEZ)
C
             END IF
C
         END IF
C
      END DO
C
      IF (ITITLE.EQ.1) WRITE(NFIPRI,'(1H*,77X,1H*/79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PREDEF(IN_FIX,IZ_FIX,SKYRME,GOGNAM,ISTAND,
     *                  KETA_J,KETA_W,KETACM,KETA_M,KETA_P,
     *                                KETA_T,KETAPA,NOZEPA,
     *                                ITWOLI,KETA_R,
     *                                KETAJ2,KETAT2,
     *           LANODD,LANSCA,HBMSAT,RHOSAT,EFFSAT,
     *           ILIBAS,INBASI,IZBASI,FCHOM0,R0PARM,
     *                                       IOPTGS,
     *           IPAIRI,IPAHFB,ITWOBA,IPABCS,IMFHFB,
     *                                       IPNMIX,
     *                                LIPKIN,LIPKIP,
     *                                LIPNON,LIPNOP,
     *                         IPNPRJ,NPPNPN,NPPNPP,
     *                  IROTAT,ITIREP,IREVIE,IQPSTA,
     *                  DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                  FERFIN,FERFIP,IFEFIN,IFEFIP,
     *                  FE2FIN,FE2FIP,IF2FIN,IF2FIP,
     *                  FERALN,FERALP,IFERAN,IFERAP,
     *                                       NUQEVE,
     *                  INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *                  INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                         INSIMN,IRSIMN,IDSIMN,
     *                         INSIMP,IRSIMP,IDSIMP,
     *                         INSIQN,IPSIQN,IDSIQN,
     *                         INSIQP,IPSIQP,IDSIQP,
     *                                INSIZN,IDSIZN,
     *                                INSIZP,IDSIZP,
     *                                IFIBLN,INIBLN,
     *                                IFIBLP,INIBLP,
     *                                       IREAWS,
     *                         ICONTI,IPCONT,IOCONT,
     *                         ISCONT,ITCONT,IACONT,
     *                  IYCONT,IGCONT,IGPCON,IECONT,
     *           ILCONT,IFCONT,IMCONT,IRCONT,IBCONT,
     *           NUCHAO,NUPING,EPSPNG,EPSITE,EPSCON,
     *                  ISPHER,ISIMPY,ISIGNY,IPARTY,
     *                         ISIMTX,ISIMTY,ISIMTZ,
     *                  IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                         NOITER,NULAST,NUCONS,
     *                  ISYMDE,INIROT,INIINV,INIKAR,
     *                         IRENMA,IRENIN,IDOGOA,
     *                         IFRWAV,ITOWAV,IWRWAV,
     *                                ISAKER,ICHKER,
     *                         IPRROT,IPRISO,IPRIS3,
     *                         IPRNUM,IPRVEC,IPRPTY,
     *                                IPROMI,IPROMA,
     *                         NUAKNO,NUBKNO,KPROJE,
     *                         NATKNO,NBTKNO,KSOSTZ,
     *                  NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *                                KSOSMI,KSOSMA,
     *                         ISOSAD,EPSISO,ICSKIP,
     *           IFERME,IBETME,IIFERR,ITFERR,ISFERR,
     *                  IPAKER,IPAK3D,IPAALL,KFIKER,
     *                  NUASTA,NUASTO,NUGSTA,NUGSTO,
     *                  NATSTA,NATSTO,NGTSTA,NGTSTO,
     *                  NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *                         ICUTOV,CUTOVE,CUTOVF,
     *                         IONISH,ISLPRI,ISUPRI,
     *                         IENPRI,ISRPRI,IMIPRI,
     *                         IKEPRI,IRMPRI,IELPRI,
     *                  QMUCUT,QMACUT,QASCUT,QSICUT,
     *                         NOSCIL,NLIMIT,ENECUT,
     *                         NUMCOU,NUMETA,FURMAX,
     *                  ICOTYP,ICOUDI,ICOUEX,E_EFFE,
     *                  PIMASS,PNMASS,IYUTYP,I_YUKA,
     *                  YUKAGT,YUKAG0,YUKAG1,YUKAG2,
     *                                I_GOGA,IGOGPA,
     *                                I_REGA,IREGPA,
     *                                I_SEPA,ISEPPA,
     *                                I_COUA,ICOUPA,
     *                                N3SERD,IDOTHC,
     *                  I1LINE,IPRSTA,IPRMID,IPRSTO,
     *                  IDESTA,IDEMID,IDESTO,IDEDIS,
     *                                INTRIP,IVIPRI,
     *                         IPRI_N,IPRI_P,IPRI_T,
     *                         NMUCON,NMUCOU,NMUPRI,
     *                                ICOUMD,ICOUMX,
     *                         ISCHIF,NSICON,NSIPRI,
     *                         NMACON,NMAPRI,NMAORD,
     *                         NASCON,NASPRI,NASORD,
     *                                       NRAORD,
     *                  NMURED,NMARED,NASRED,NSIRED,
     *                         NEXBET,IPRIBE,IPRIBL,
     *                  IWRIOL,IWRISO,IWRIRE,IWRIBA,
     *                         IWRIYU,IWRIGO,IWRIRO,
     *                  IWRILI,IWRIFI,IWRIQU,IWRIRM,
     *                         FILISO,FILREP,FILREC,
     *                         FILWOO,FILREV,FILCOU,
     *                                FILWAV,FILKER,
     *                                FILYUP,FILYUC,
     *                                FILGOP,FILGOC,
     *                                FILGPP,FILGPC,
     *                                FILROP,FILROC,
     *                                FILLIP,FILLIC,
     *                         FILFIP,FILFIC,FILFER,
     *                                FILQUA,FILRED,
     *                                FILBAP,FILBAC,
     *                         ICHFLI,IPAFLI,IREFLI,
     *                         ISPFLI,ISHFLI,IFLIPI,
     *                  SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                                ICOULI,ICOULO,
     *                                FACTGN,FACTGP,
     *                                EMINAL,EMAXAL,
     *                  EMAXQU,ECUTOF,LIMQUA,LAMCUT,
     *                                IQUNIL,NILXYZ,
     *                                       IAVRGG,
     *                                       IPOTHO,
     *                                       EPSHER,
     *                         ICOMIX,INLKER,INRKER,
     *                         ICMPRI,IN_EXC,EPSMIX,
     *                                ISOADD,NBTKNT,
     *                         IFSHEL,IF_RPA,IFRTHO,
     *                  PRHD_T,PRHDDT,PRHDST,POWDRT,
     *                         IFRAGM,NUMPUS,IFPUSH,
     *           DELTAE,XLOCMX,V2_MIN,ITRMAX,NTHETA,
     *                  MIN_QP,IDEALL,IDELOC,IDECON,
     *                         ILIPON,ILIPOP,GAUSHI,
     *                                I_SLOW,SLOWAL,
     *                  SLOWLD,SLOWTP,SLOWRP,SLOWLM,
     *           NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,
     *           NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,
     *                                LASTAN,LASTAP,
     *                         IAXIAP,KAPASY,INUNIL,
     *                                       IADBAT,
     *                                NEWGOG,NEWCOU,
     *                                       ITWCEN,
     *                                IEIGCU,EIGCUT,
     *                                NLIMTW,ENECTW,
     *                                       IFRCNT)
C
C=======================================================================
      USE hfodd_functional
      USE hfodd_fission_rotated_qp
      USE FRAGFL
      USE colcoord
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDF2BC=5)
      PARAMETER (NDFANL=2)
      PARAMETER (NDFSTA=3)
C=======================================================================
C
      CHARACTER
     *          SKYRME*4,GOGNAM*4
      CHARACTER
     *          FILREP*68,FILREC*68,FILWOO*68,
     *          FILREV*68,FILCOU*68,FILISO*68,FILWAV*68,FILKER*68,
     *          FILYUP*68,FILYUC*68,
     *          FILGOP*68,FILGOC*68,
     *          FILGPP*68,FILGPC*68,
     *          FILROP*68,FILROC*68,
     *          FILLIP*68,FILLIC*68,
     *          FILFIP*68,FILFIC*68,
     *          FILFER*68,FILQUA*68,
     *          FILBAP*68,FILBAC*68,
     *          FILRED*68
      CHARACTER
     *          FILLEF*68,FILRIG*68
      CHARACTER
     *          NIBLOL*15
C
      DIMENSION
     *          INSIZN(1:NDBLOC),IDSIZN(1:NDBLOC),
     *          INSIZP(1:NDBLOC),IDSIZP(1:NDBLOC)
      DIMENSION
     *          INSIQN(1:NDBLOC),IPSIQN(1:NDBLOC),IDSIQN(1:NDBLOC),
     *          INSIQP(1:NDBLOC),IPSIQP(1:NDBLOC),IDSIQP(1:NDBLOC)
      DIMENSION
     *             IN_EXC(ND_EXC)
      DIMENSION
     *             STSALL(NDCOUT), SPMALL(NDCOUT)
      DIMENSION
     *             ATSALL(NDCOUT), APMALL(NDCOUT)
      EQUIVALENCE
     *            (STSALL,SRHO_T),(SPMALL,SRHO_P)
      EQUIVALENCE
     *            (ATSALL,ARHO_T),(APMALL,ARHO_P)
C
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /SIMKPH/ KPSIMP(NDPAHO,0:NDISOS),KPSIMM(NDPAHO,0:NDISOS),
     *                KHSIMP(NDPAHO,0:NDISOS),KHSIMM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIGKPH/ KPPPSP(NDPAHO,0:NDISOS),KPPPSM(NDPAHO,0:NDISOS),
     *                KPPMSP(NDPAHO,0:NDISOS),KPPMSM(NDPAHO,0:NDISOS),
     *                KHPPSP(NDPAHO,0:NDISOS),KHPPSM(NDPAHO,0:NDISOS),
     *                KHPMSP(NDPAHO,0:NDISOS),KHPMSM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIQKPH/ KPSIQP(NDPAHO,0:NDISOS),KPSIQM(NDPAHO,0:NDISOS),
     *                KHSIQP(NDPAHO,0:NDISOS),KHSIQM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIZKPH/ KPNONE(NDPAHO,0:NDISOS),
     *                KHNONE(NDPAHO,0:NDISOS)
      COMMON
     *       /MIGKPH/ LPPPSP(NDPAHO),LPPPSM(NDPAHO),
     *                LPPMSP(NDPAHO),LPPMSM(NDPAHO),
     *                LHPPSP(NDPAHO),LHPPSM(NDPAHO),
     *                LHPMSP(NDPAHO),LHPMSM(NDPAHO)
      COMMON
     *       /MIMKPH/ LPSIMP(NDPAHO),LPSIMM(NDPAHO),
     *                LHSIMP(NDPAHO),LHSIMM(NDPAHO)
      COMMON
     *       /MIQKPH/ LPSIQP(NDPAHO),LPSIQM(NDPAHO),
     *                LHSIQP(NDPAHO),LHSIQM(NDPAHO)
      COMMON
     *       /MIZKPH/ LPNONE(NDPAHO),
     *                LHNONE(NDPAHO)
      COMMON
     *       /SIGKVA/ KVASIG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /SIMKVA/ KVASIM(         0:NDSIMP,0:NDISOS)
      COMMON
     *       /SIQKVA/ KVASIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /SIZKVA/ KVASIZ(                  0:NDISOS)
      COMMON
     *       /SIZMVA/ MVASIZ(0:NDISOS)
      COMMON
     *       /MIGKVA/ KVAMIG(0:NDPARI,0:NDSIGN)
      COMMON
     *       /MIMKVA/ KVAMIM(0:NDSIMP)
      COMMON
     *       /MIQKVA/ KVAMIQ(0:NDPARI)
      COMMON
     *       /K_FLIG/ KPFLIG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KHFLIG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KOFLIG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /K_FLIM/ KPFLIM(         0:NDSIMP,0:NDISOS),
     *                KHFLIM(         0:NDSIMP,0:NDISOS),
     *                KOFLIM(         0:NDSIMP,0:NDISOS)
      COMMON
     *       /K_FLIQ/ KPFLIQ(0:NDPARI,         0:NDISOS),
     *                KHFLIQ(0:NDPARI,         0:NDISOS),
     *                KOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /K_FLIZ/ KPFLIZ(                  0:NDISOS),
     *                KHFLIZ(                  0:NDISOS),
     *                KOFLIZ(                  0:NDISOS)
      COMMON
     *       /K_MLIG/ KPMLIG(0:NDPARI,0:NDSIGN),
     *                KHMLIG(0:NDPARI,0:NDSIGN),
     *                KOMLIG(0:NDPARI,0:NDSIGN)
      COMMON
     *       /K_MLIM/ KPMLIM(0:NDSIMP),
     *                KHMLIM(0:NDSIMP),
     *                KOMLIM(0:NDSIMP)
      COMMON
     *       /K_MLIQ/ KPMLIQ(0:NDPARI),
     *                KHMLIQ(0:NDPARI),
     *                KOMLIQ(0:NDPARI)
      COMMON
     *       /K_MLIZ/ KPMLIZ,
     *                KHMLIZ,
     *                KOMLIZ
      COMMON
     *       /K_FILG/ KPFILG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KHFILG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KOFILG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /K_FILZ/ KPFILZ(                  0:NDISOS),
     *                KHFILZ(                  0:NDISOS),
     *                KOFILZ(                  0:NDISOS)
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /STSSKY/ SRHO_T,SRHO_S,SRHODT,SRHODS,
     *                SLPR_T,SLPR_S,
     *                STAU_T,STAU_S,
     *                SSCU_T,SSCU_S,
     *                SDIV_T,SDIV_S,
     *                SSPI_T,SSPI_S,SSPIDT,SSPIDS,
     *                SLPS_T,SLPS_S,
     *                SCUR_T,SCUR_S,
     *                SKIS_T,SKIS_S,
     *                SROT_T,SROT_S,
     *                SSCT_T,SSCT_S,
     *                SKIT_T,SKIT_S,
     *                SSPT_T,SSPT_S
      COMMON
     *       /SPMSKY/ SRHO_P,SRHO_M,SRHODP,SRHODM,
     *                SLPR_P,SLPR_M,
     *                STAU_P,STAU_M,
     *                SSCU_P,SSCU_M,
     *                SDIV_P,SDIV_M,
     *                SSPI_P,SSPI_M,SSPIDP,SSPIDM,
     *                SLPS_P,SLPS_M,
     *                SCUR_P,SCUR_M,
     *                SKIS_P,SKIS_M,
     *                SROT_P,SROT_M,
     *                SSCT_P,SSCT_M,
     *                SKIT_P,SKIT_M,
     *                SSPT_P,SSPT_M
      COMMON
     *       /ATSSKY/ ARHO_T,ARHO_S,ARHODT,ARHODS,
     *                ALPR_T,ALPR_S,
     *                ATAU_T,ATAU_S,
     *                ASCU_T,ASCU_S,
     *                ADIV_T,ADIV_S,
     *                ASPI_T,ASPI_S,ASPIDT,ASPIDS,
     *                ALPS_T,ALPS_S,
     *                ACUR_T,ACUR_S,
     *                AKIS_T,AKIS_S,
     *                AROT_T,AROT_S,
     *                ASCT_T,ASCT_S,
     *                AKIT_T,AKIT_S,
     *                ASPT_T,ASPT_S
      COMMON
     *       /APMSKY/ ARHO_P,ARHO_M,ARHODP,ARHODM,
     *                ALPR_P,ALPR_M,
     *                ATAU_P,ATAU_M,
     *                ASCU_P,ASCU_M,
     *                ADIV_P,ADIV_M,
     *                ASPI_P,ASPI_M,ASPIDP,ASPIDM,
     *                ALPS_P,ALPS_M,
     *                ACUR_P,ACUR_M,
     *                AKIS_P,AKIS_M,
     *                AROT_P,AROT_M,
     *                ASCT_P,ASCT_M,
     *                AKIT_P,AKIT_M,
     *                ASPT_P,ASPT_M
      COMMON
     *       /NILPAR/ CNILSN,DNILSN,CNILSP,DNILSP,
     *                HBANIX,HBANIY,HBANIZ,NILDAT
      COMMON
     *       /OMEGAS/ OMEGAX,OMEGAY,OMEGAZ
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /IANGLE/ ALPINI,BETINI,GAMINI
      COMMON
     *       /ICNSTR/ STIFFI(1:NDKART),
     *                ASKEDI(1:NDKART),
     *                IFLAGI(1:NDKART)
      COMMON
     *       /ICNTTR/ STIFTI(1:NDKART),
     *                ASKETI(1:NDKART),
     *                IFTAGI(1:NDKART)
      COMMON
     *       /TCNSTR/ STIFFT(1:NDKART),
     *                ASKEDT(1:NDKART),
     *                IFLAGT(1:NDKART)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /ACNSTR/ STIFFA,ASKEDA,IFLAGA
      COMMON
     *       /CCPRHD/ PRHD_N,PRHDDN,PRHDSN,POWDRN,
     *                PRHD_P,PRHDDP,PRHDSP,POWDRP
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VCNSTR/ STIFFV(0:NDMULT,-NDMULT:NDMULT),
     *                VASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SCNSTR/ STIFFS(0:NDMULT,-NDMULT:NDMULT),
     *                SASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /GCNSTR/ STIFFG(0:NDMULT),
     *                GASKED(0:NDMULT),
     *                IFLAGG(0:NDMULT)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /FRCONS/ FRGSTF(0:NDISOS,1:NDTWCE),
     *                FRGASK(0:NDISOS,1:NDTWCE),
     *                IFLFRG(0:NDISOS,1:NDTWCE),
     *                CLMFRA(0:NDISOS,1:NDTWCE),
     *                AVEFRA(0:NDISOS,1:NDTWCE)
      COMMON
     *       /QTWCNS/ STQTWC(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QTWCAS(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                IFLQTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                GALMTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
      COMMON
     *       /QMUTWC/ QFRA_N(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QFRA_P(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QFRA_T(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
      COMMON
     *       /ROTFRG/ ALFFRA(1:NDTWCE),BETFRA(1:NDTWCE),
     *                GAMFRA(1:NDTWCE),IROFRG(1:NDTWCE)
      COMMON
     *       /VACCNF/ IVACUM
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /PAIINI/ FERINI(0:NDISOS),DELINI(0:NDISOS),FE2INI(0:NDISOS)
      COMMON
     *       /ISOFER/ FERISO(0:NDKART)
      COMMON
     *       /ISOFE_/ FE_RAD,FE_THE,FE_PHI,FE_OFF
      COMMON
     *       /LAND_G/ X0_LAN,X1_LAN,G0_LAN,G0PLAN,G1_LAN,G1PLAN
      COMMON
     *       /REGPAR/ REGWID
      COMMON
     *       /REJVIN/ REJVCC(NDREGA,NDFORC)
      COMMON
     *       /REJVER/ REJERR(NDREGA,NDFORC)
      COMMON
     *       /REJVAC/ REJFAC(NDREGA,NDFORC)
      COMMON
     *       /REJTIN/ REJTCC(NDREGA,NDFORC)
      COMMON
     *       /JREJAL/ IREREJ(4),NREREJ(4)
      COMMON
     *       /SEPPAR/ SEPWID(NDSEGA),SEPGAU(NDSEGA),NUSEGA
      COMMON
     *       /SEPBIN/ SEPVIC(NDSEPA,NDFORC),IVISEP
      COMMON
     *       /SEPVER/ SEPERR(NDSEPA,NDFORC),IERSEP
      COMMON
     *       /SEPFAC/ SEPFAC(NDSEPA,NDFORC),IFASEP
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /ATWOBO/ TWOBOD,TWOINP,ITWOIN
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /SKYDAT/ T0_DAT,X0_DAT,T1_DAT,X1_DAT,T2_DAT,X2_DAT,
     *                T3_DAT,X3_DAT,WW_DAT,PO_DAT
      COMMON
     *       /SKYERR/ T0_ERR,X0_ERR,T1_ERR,X1_ERR,T2_ERR,X2_ERR,
     *                T3_ERR,X3_ERR,WW_ERR,PO_ERR
      COMMON
     *       /SKYFAC/ T0_FAC,X0_FAC,T1_FAC,X1_FAC,T2_FAC,X2_FAC,
     *                T3_FAC,X3_FAC,WW_FAC,PO_FAC
      COMMON
     *       /CBRPA2/ T02CBR,X02CBR,
     *                T12CBR,X12CBR,
     *                T22CBR,X22CBR
     *       /CBRPA3/ T03CBR,X03CBR,
     *                T13CBR,X13CBR,
     *                T23CBR,X23CBR
     *       /CBRSWI/ I_2CBR,I_3CBR
      COMMON
     *       /SO_PAR/ W0_INP,W0PINP
      COMMON
     *       /SO_ERR/ W0_ERR,W0PERR
      COMMON
     *       /SO_FAC/ W0_FAC,W0PFAC
      COMMON
     *       /DISTAN/ DISTAX,DISTAY,DISTAZ
      COMMON
     *       /ROTATT/ ROTATX,ROTATY,ROTATZ
      COMMON
     *       /RINORM/ HBMRIN(NDKART)
      COMMON
     *       /RINROT/ ROTRIN(NDKART)
      COMMON
     *       /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMIX/ ALPHAM,BROTRI
     *       /BROMAT/ NOIINP,MIXMAT
      COMMON
     *       /DPOWER/ POWERD
      COMMON
     *       /NEWIGN/ NEWWIG
      COMMON
     *       /IKETRA/ IKEINV,IKEKAR
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
      COMMON
     *       /STRUTI_PARAMS/ GSTRUN,GSTRUP,HOMFAC,EPSRTN
     *       /STRUTI_POLYNO/ NPOLYN
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL
      COMMON
     *       /SCALAPACK_INP/ NBLOCK,MBLOCK,NPGRID,MPGRID,KZHPEV
C SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /T_FLAG/ IFTEMP
      COMMON
     *       /GCTEMP/ TEMP_T
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /AUTOBA/ IBASIS
      COMMON
     *       /EDFINP/ IF_EDF
     *       /EDFPAR/ V0NEFF,V0PEFF,COUSCA
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
     *       /NCKFLA/ IFNECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C- XB - XB - - XB - - XB - - XB - - XB - - XB - - XB - - XB - - XB
       REAL
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
      COMMON
     *       /LIPLAM/
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
C- XB - XB - - XB - - XB - - XB - - XB - - XB - - XB - - XB - - XB
      COMMON
     *       /QUOCCU/ PARACC,CORLIM,DERLIM,OCCLIM,MAXQUA,IPQBCS
      COMMON
     *       /JPA2HF/ DEL2HF(0:NDISOS),IPA2HF(0:NDISOS)
      COMMON
     *       /IDENTU/ IDENSU,JDENSU
      COMMON
     *       /IPRIAM/ ILIMAM,IALLAM
      COMMON
     *       /ALLPRI/ IPRALL
      COMMON
     *       /GYROSC/ GYRORP,GYRSPN,GYRSPP,IGYROS
      COMMON
     *       /CUSIZN/ NCUSIZ(0:NDISOS)
      COMMON
     *       /CUSIQN/ NCUSIQ(0:NDISOS,0:NDPARI)
      COMMON
     *       /BLOCNI/ NIBLOC(       0:NDISOS),NIBLOM(NDBLOC,0:NDISOS),
     *                NIBLOE(NDBLOC,0:NDISOS),NIBLOL(NDBLOC,0:NDISOS)
      COMMON
     *       /KERNAM/ FILLEF(NDCONF),FILRIG(NDCONF),NUCONF,NAMKER
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /DIQ_GA/ DIQCOD,DIQCOE,DIQCOP,IDIQGA
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /CENPOS/ CENCOR(1:NDKART,1:NDTWCE)
      COMMON
     *       /ADBRUN/ IABNTE,IABCOL,IABICH,IABMOD,IFAMON
      COMMON
     *       /ADBLNM/ IADBLN
      COMMON
     *       /ADBPRC/ DABPRS,ETAFAM,XCHIMX
      COMMON /ADBFLE/ SFIADB, SFJADB
      CHARACTER SFIADB*68, SFJADB*68
      COMMON
     *       /TOMOPI/ ITOMOZ,IOBSCH,IDESCH,INDENS
      COMMON
     *       /TOMOPH/ PTOMOX,PTOMOY,PTOMOZ
      COMMON
     *       /TOMSIC/ ITOMSC
      COMMON
     *       /TOMSLC/ P0VECX,P0VECY,P0VECZ,
     *                P1VECX,P1VECY,P1VECZ,
     *                P2VECX,P2VECY,P2VECZ
      COMMON
     *       /TOMIMK/ ITOMII,ITOMMM,ITOMKK,NTOMNB,NTOMNA
      COMMON
     *       /TOMMEN/ NCMESH
      COMMON
     *       /TOMMES/ PINTSC, PWIDTH, PHEIGH
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /GEF2BC/ GIN2BC,GSA2BC,IGY2BC
      COMMON
     *       /FORANL/ MAGANL(NDFANL)
      COMMON
     *       /GEFANL/ GJ2ANL,GSQANL,IGYANL
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /FSTFOR/ FSOSTR(NDGOGA,NDFORC),
     *                FTOSTR(NDGOGA,NDFORC),
     *                FTESTR(NDGOGA,NDFORC),FSTWID(NDGOGA)
      COMMON
     *       /INTCHE/ RANGX,NPOINT
C
C=======================================================================
C         THIS SUBROUTINE SETS THE DEFAULT VALUES FOR THE INPUT DATA
C=======================================================================
C
C      Initialization of public variables of module hfodd_functional.
C      These variables are *only* used in hfodd_functional, so the
C      initialization below (to unrealistic values) should not affect
C      the rest of the code.
C
      HB00     =  20.0D0
C
      RHO_NM   =   0.1D0
      E_NM     =  10.0D0
      K_NM     = 200.0D0
      P_NM     =   0.0D0
      ASS_NM   =  50.0D0
      LASS_NM  =  50.0D0
      SMASS_NM =   1.0D0
      VMASS_NM =   1.0D0
C
      crho00   = 100.0D0
      crho0D   = 100.0D0
      crho10   = 100.0D0
      crho1D   = 100.0D0
      ctau0    = 100.0D0
      ctau1    = 100.0D0
      cdrho0   = 100.0D0
      cdrho1   = 100.0D0
      cdJ0     = 100.0D0
      cdJ1     = 100.0D0
      CJ0      = 100.0D0
      CJ1      = 100.0D0
C
      V0N      =   0.0D0
      V0P      =   0.0D0
      CExPar   =   1.0D0
C
      T0_PAR   = 100.0D0
      T1_PAR   = 100.0D0
      T2_PAR   = 100.0D0
      T3_PAR   = 100.0D0
      X0_PAR   =   1.0D0
      X1_PAR   =   1.0D0
      X2_PAR   =   1.0D0
      X3_PAR   =   1.0D0
C
      B4_PAR   =   0.0D0
      B4PPAR   =   0.0D0
      te       =   0.0D0
      to       =   0.0D0
      ALPHA    =   1.0D0
C
C=======================================================================
C
C      Minimization over deformations of the WS potential
C
      NUMPUS=1
      IFPUSH=0
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      IFNECK=0
      G_NECK=0.0
      Q0NECK=0.0
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
      IFRAGM = 0
C
C      Recording densities for whole nucleus, left and right fragments
C      including all/discrete/continuum q.p. states
      IDEALL = 0
      IDELOC = 0
      IDECON = 0
C
C      Rotation of q.p. wave-functions for fission fragments
      MIN_QP=0
C      This array is defined in the hfodd_rotated_qp module of the
C      hfodd_fission_256a.f90 file, and is used in DENSHF even when
C      no rotation of qp is performed. It needs to be initialized
C      properly.
      ALLOCATE(table_singles(1:NDBASE,0:NDISOS))
      table_singles = 1
      ALLOCATE(number_of_pairs(0:NDISOS))
      number_of_pairs = 0
C
      DELTAE=2.5D0
      XLOCMX=0.75D0
      V2_MIN=0.005D0
      ITRMAX=31
      NTHETA=181
C
      EIGMIN= -200.0D0
      EIGMAX=+1000.0D0
C
C      Energy functional flag, pairing strength and Coulomb exchange
C      scaling
C
      IF_EDF=0
      V0NEFF=-200.0D0
      V0PEFF=-200.0D0
      COUSCA=   1.0D0
C
C      Temperature
C
      IFTEMP=0
      TEMP_T=0.0D0
C
C      Shell correction
C
      IFSHEL=0
C
      GSTRUN=1.2D0
      GSTRUP=1.2D0
      HOMFAC=4.5D0
      EPSRTN=0.0001D0
      NPOLYN=6
C
C      Processor grid and block structure for ScaLAPACK
C
      MBLOCK=64
      NBLOCK=64
      KZHPEV=1
C
      IBROYD=0
      N_ITER=7
C
      ALPHAM=0.8D0
      BROTRI=1000.0D0
C
      MIXMAT=0
      NOIINP=4
C
C      Multi-dimensional constraints "a la Gogny"
      IF_RPA=0
C
      IF(ALLOCATED(F_FLAG)) DEALLOCATE (F_FLAG)
      ALLOCATE(F_FLAG(1:NDSTAT,0:NDREVE,0:NDISOS))
      F_FLAG(:,:,:)=1.0D0
C
C=======================================================================
C         HFBTHO INPUTS
C=======================================================================
C
      IFRTHO=0
C
C=======================================================================
C         GENERAL DATA
C=======================================================================
C
      IN_FIX=86
      IZ_FIX=66
C
      NOITER=50
      EPSITE=0.
      NULAST=1
      EPSCON=0.
      NUCONS=0
C
      EPSPNG=0.
      NUPING=3
C
      NUCHAO=0
C
      IPOTHO=0
C
      IQPSTA=0
C
C=======================================================================
C         PHASE SPACE
C=======================================================================
C
      NUMBSP(:,:)=0
C
C=======================================================================
C         INTERACTION OF THE SKYRME TYPE
C=======================================================================
C
      SKYRME='SKM*'
C
      ISTAND=0
      KETA_J=1
      KETA_W=0
      KETACM=0
      KETA_M=0
      KETA_P=1
      KETA_T=0
      KETAPA=0
C
      NOZEPA=0
C
      POWERD=1.0D0
C
      ITWOLI=0
      KETA_R=3
C
      KETAJ2=0
      KETAT2=0
C
      HBMINP=20.73620941D0
C
      TWOINP=0.0
      THRINP=0.0
      FOUINP=0.0
C
      TGRA10=0.0
      TGRA11=0.0
      TGRA20=0.0
      TGRA21=0.0
      TGRA22=0.0
C
      ITWOIN=0
      ITHRIN=0
      IFOUIN=0
      IGRAIN=0
C
      T0_DAT=0.0
      X0_DAT=0.0
      T1_DAT=0.0
      X1_DAT=0.0
      T2_DAT=0.0
      X2_DAT=0.0
      T3_DAT=0.0
      X3_DAT=0.0
      WW_DAT=0.0
      PO_DAT=1.0
C
      T0_ERR=0.0
      X0_ERR=0.0
      T1_ERR=0.0
      X1_ERR=0.0
      T2_ERR=0.0
      X2_ERR=0.0
      T3_ERR=0.0
      X3_ERR=0.0
      WW_ERR=0.0
      PO_ERR=0.0
C
      T0_FAC=0.0
      X0_FAC=0.0
      T1_FAC=0.0
      X1_FAC=0.0
      T2_FAC=0.0
      X2_FAC=0.0
      T3_FAC=0.0
      X3_FAC=0.0
      WW_FAC=0.0
      PO_FAC=0.0
C
      W0_INP=120.0
      W0PINP=120.0
C
      W0_ERR=0.0
      W0PERR=0.0
C
      W0_FAC=0.0
      W0PFAC=0.0
C
      LANODD=0
      LANSCA=0
C
      X0_LAN=0.0
      X1_LAN=0.0
      G0_LAN=0.0
      G0PLAN=0.0
      G1_LAN=0.0
      G1PLAN=0.0
C
      HBMSAT=-1.0
      RHOSAT=-1.0
      EFFSAT=-1.0
C
      STSALL(:)=1.0D0
      SPMALL(:)=1.0D0
      ATSALL(:)=0.0D0
      APMALL(:)=0.0D0
C
C=======================================================================
C         INTERACTION OF THE GOGNY TYPE
C=======================================================================
C
      GOGNAM='D1S '
C
C=======================================================================
C         INTERACTION OF THE CHARGE BREAKING TYPE
C=======================================================================
C
      T02CBR=0.0
      X02CBR=0.0
      T12CBR=0.0
      X12CBR=0.0
      T22CBR=0.0
      X22CBR=0.0
      I_2CBR=0
C
      T03CBR=0.0
      X03CBR=0.0
      T13CBR=0.0
      X13CBR=0.0
      T23CBR=0.0
      X23CBR=0.0
      I_3CBR=0
C
C=======================================================================
C         PAIRING INTERACTION
C=======================================================================
C
      FACTGN=1.0
      FACTGP=1.0
C
      IAVRGG=0
C
      PRHD_N=-200.0
      PRHDDN=0.0
      PRHDSN=0.16
      POWDRN=1.0
C
      PRHD_P=-200.0
      PRHDDP=0.0
      PRHDSP=0.16
      POWDRP=1.0
C
      PRHD_T=0.0
      PRHDDT=0.0
      PRHDST=0.16
      POWDRT=1.0
C
      INSIGN=1
      IPSIGN=0
      ISSIGN=0
      IDSIGN=0
C
      INSIGP=1
      IPSIGP=0
      ISSIGP=0
      IDSIGP=0
C
      INSIMN=1
      IRSIMN=0
      IDSIMN=0
C
      INSIMP=1
      IRSIMP=0
      IDSIMP=0
C
      INSIQN(:)=1
      IPSIQN(:)=0
      IDSIQN(:)=0
C
      INSIQP(:)=1
      IPSIQP(:)=0
      IDSIQP(:)=0
C
      NLSIGN=0
      NLSIMN=0
      NLSIQN=0
      NLSIZN=0
      MXALIN=1
      LASTAN=0
C
      NLSIGP=0
      NLSIMP=0
      NLSIQP=0
      NLSIZP=0
      MXALIP=1
      LASTAP=0
C
      IAXIAP=0
C
      KAPASY=0
C
      INSIZN(:)=1
      IDSIZN(:)=0
C
      INSIZP(:)=1
      IDSIZP(:)=0
C
      IFIBLN=0
      INIBLN=0
C
      IFIBLP=0
      INIBLP=0
C
      FERFIN=-8.0
      FERFIP=-8.0
C
      IFEFIN=0
      IFEFIP=0
C
      FE2FIN=0.1
      FE2FIP=0.1
C
      IF2FIN=0
      IF2FIP=0
C
      FERALN=0.0
      FERALP=0.0
C
      IFERAN=0
      IFERAP=0
C
      NUQEVE=0
C
      DELFIN=1.0
      DELFIP=1.0
C
      IDEFIN=0
      IDEFIP=0
C
      ECUTOF=60.
      NCUSIZ(:)=0
      NCUSIQ(:,:)=0
C
      LIMQUA=0
      LAMCUT=0
C
      PARACC=1.0D-10
      CORLIM=1.0D-10
      DERLIM=1.0D-20
      OCCLIM=1.0D-08
      MAXQUA=100
C
      IDESTA=1
      IDEMID=0
      IDESTO=0
      IDEDIS=0
C
C=======================================================================
C         INITIAL FERMI ENERGIES AND PAIRING GAPS
C=======================================================================
C
      FERINI(0)=-8.0
      FERINI(1)=-8.0
C
      DELINI(0)= 1.0
      DELINI(1)= 1.0
C
      FE2INI(0)= 0.1
      FE2INI(1)= 0.1
C
C=======================================================================
C         ISOSPIN FERMI ENERGIES
C=======================================================================
C
      FE_RAD=0.0
      FE_THE=0.0
      FE_PHI=0.0
      FE_OFF=0.0
C
      FERISO(0)= 0.0
      FERISO(1)= 0.0
      FERISO(2)= 0.0
      FERISO(3)= 0.0
C
C=======================================================================
C         EULER ANGLES OF THE INITIAL ROTATION OF THE WAVE FUNCTION
C=======================================================================
C
      ALPINI=0.0D0
      BETINI=0.0D0
      GAMINI=0.0D0
C
      INIROT=0
C
C=======================================================================
C         INDEXES OF THE INITIAL D2H TRANSFORMATION OF THE WAVE FUNCTION
C=======================================================================
C
      INIINV=0
      INIKAR=0
C
C=======================================================================
C         INDEXES OF THE D2H TRANSFORMATION OF THE RIGHT WAVE FUNCTION
C         BEFORE CALCULATIONG THE KERNELS
C=======================================================================
C
      IKEINV=0
      IKEKAR=0
C
C=======================================================================
C         NUCLEON MASS RENORMALIZATION
C=======================================================================
C
      IRENMA=0
C
      DISTAX=0.0D0
      DISTAY=0.0D0
      DISTAZ=0.0D0
C
      HBMRIN(1)=1.0D0
      HBMRIN(2)=1.0D0
      HBMRIN(3)=1.0D0
C
C=======================================================================
C         NUCLEAR INERTIA RENORMALIZATION
C=======================================================================
C
      IRENIN=0
C
      ROTATX=0.0D0
      ROTATY=0.0D0
      ROTATZ=0.0D0
C
      ROTRIN(1)=1.0D0
      ROTRIN(2)=1.0D0
      ROTRIN(3)=1.0D0
C
C=======================================================================
C         GAUSSIAN OVERLAP APPROXIMATION
C=======================================================================
C
      IDOGOA=1
C
C=======================================================================
C         ANGULAR MOMENTUM/ISOSPIN PROJECTION AND THE GCM KERNELS
C=======================================================================
C
      IPRROT=0
      IPRISO=0
      IPRIS3=0
      IPRNUM=0
      IPRVEC=0
      IPRPTY=0
C
      IPROMI=0
      IPROMA=0
C
      NUAKNO=1
      NUBKNO=1
      KPROJE=0
C
      KSOSMI=0
      KSOSMA=0
      KSOSTZ=0
      ISOSAD=0
C
      NEWWIG=0
C
      NATKNO=1
      NBTKNO=1
      EPSISO=1.0D-6
      ICSKIP=0
C
      IFERME=0
      IBETME=0
      IIFERR=0
      ITFERR=2
      ISFERR=1
C
      ISOADD=6
      NBTKNT=8
C
      IFRWAV=1
      ITOWAV=1
      IWRWAV=0
C
      NPNKNO=1
      NTZKNO=1
      IDENSU=0
      NPAKNO=1
      IPAPRO=+1
C
      IONISH=0
C
      ICUTOV=0
      CUTOVE=1.0D-10
      CUTOVF=1.0D0
C
      ISLPRI=0
      ISUPRI=999
      IENPRI=1
      ISRPRI=1
      IMIPRI=1
      IKEPRI=0
      IRMPRI=0
      IELPRI=0
C
      ILIMAM=1
      IALLAM=0
      IPRALL=0
C
      QMUCUT=0.0D0
      QMACUT=0.0D0
      QASCUT=0.0D0
      QSICUT=0.0D0
C
      ISAKER=0
      ICHKER=1
C
      IPAKER=0
      IPAK3D=0
      IPAALL=0
      KFIKER=0
C
      NUASTA=1
      NUASTO=1
      NUGSTA=1
      NUGSTO=1
C
      NATSTA=1
      NATSTO=1
      NGTSTA=1
      NGTSTO=1
C
      NUBSTA=1
      NUBSTO=1
      NUTSTA=1
      NUTSTO=1
C
C=======================================================================
C         CONFIGURATION MIXING
C=======================================================================
C
      ICOMIX=0
      INLKER=0
      INRKER=0
      ICMPRI=0
      IN_EXC(:)=0
                      IN_EXC(1)=1
      ILCONF=0
      INCONF(:)=0
      EPSMIX=1.0D-6
C
C=======================================================================
C         SYMMETRIES
C=======================================================================
C
      IROTAT=1
C
      ITIREP=0
C
      ISPHER=0
C
      ISIMPY= 1
      ISIGNY= 1
      IPARTY=-1
C
      ISIMTX= 1
      ISIMTY=-1
      ISIMTZ= 1
C
      IPAIRI=0
      IPAHFB=0
      ITWOBA=0
      IPABCS=-1
C
      DEL2HF(:)=0.0D0
      IPA2HF(:)=0
C
      IMFHFB=0
C
      IPNMIX=0
C
      LIPKIN=0
      LIPKIP=0
C
      LIPNON=0
      LIPNOP=0
C
      IPNPRJ=0
      NPPNPN=0
      NPPNPP=0
C
C=======================================================================
C     PARAMETRS FOR THE LIPKIN VAPNP METHOD
C=======================================================================
C
      ILIPON=0
      ILIPOP=0
C
      LAM2_N=0.1
      LAM2_P=0.1
C
      LAM4_N=0.0
      LAM4_P=0.0
C
      LAM6_N=0.0
      LAM6_P=0.0
C
      GAUSHI=8.D0*ATAN(1.0D0)/51
C
C=======================================================================
C         CONFIGURATIONS
C=======================================================================
C
      IVACUM=0
C
C=======================================================================
C         CONSERVED SIGNATURE
C=======================================================================
C
      KVASIG(0,0,0)=22
      KVASIG(0,1,0)=22
      KVASIG(1,0,0)=21
      KVASIG(1,1,0)=21
C
      KVASIG(0,0,1)=16
      KVASIG(0,1,1)=16
      KVASIG(1,0,1)=17
      KVASIG(1,1,1)=17
C
      KVAMIG(:,:)=38
C
      KPPPSP(:,:)=0
      KPPPSM(:,:)=0
      KPPMSP(:,:)=0
      KPPMSM(:,:)=0
C
      KHPPSP(:,:)=0
      KHPPSM(:,:)=0
      KHPMSP(:,:)=0
      KHPMSM(:,:)=0
C
      LPPPSP(:)=0
      LPPPSM(:)=0
      LPPMSP(:)=0
      LPPMSM(:)=0
C
      LHPPSP(:)=0
      LHPPSM(:)=0
      LHPMSP(:)=0
      LHPMSM(:)=0
C
C=======================================================================
C         CONSERVED SIMPLEX
C=======================================================================
C
      KVASIM(0,0)=43
      KVASIM(1,0)=43
C
      KVASIM(0,1)=33
      KVASIM(1,1)=33
C
      KVAMIM(0)=76
      KVAMIM(1)=76
C
      KPSIMP(:,:)=0
      KPSIMM(:,:)=0
C
      KHSIMP(:,:)=0
      KHSIMM(:,:)=0
C
      LPSIMP(:)=0
      LPSIMM(:)=0
C
      LHSIMP(:)=0
      LHSIMM(:)=0
C
C=======================================================================
C         CONSERVED PARITY
C=======================================================================
C
      KVASIQ(0,0)=44
      KVASIQ(1,0)=42
C
      KVASIQ(0,1)=32
      KVASIQ(1,1)=34
C
      KVAMIQ(0)=76
      KVAMIQ(1)=76
C
      KPSIQP(:,:)=0
      KPSIQM(:,:)=0
C
      KHSIQP(:,:)=0
      KHSIQM(:,:)=0
C
      LPSIQP(:)=0
      LPSIQM(:)=0
C
      LHSIQP(:)=0
      LHSIQM(:)=0
C
C=======================================================================
C         NON-CONSERVED SIMPLEX
C=======================================================================
C
      KVASIZ(:)=0
      MVASIZ(:)=0
C
      KPNONE(:,:)=0
      KHNONE(:,:)=0
C
      LPNONE(:)=0
      LHNONE(:)=0
C
C=======================================================================
C         DIABATIC BLOCKING
C=======================================================================
C
      ICHFLI=0
      IPAFLI=0
      IREFLI=0
      ISPFLI=2
      ISHFLI=1
      IFLIPI=0
C
      KPFLIG(:,:,:)=2
      KHFLIG(:,:,:)=1
      KOFLIG(:,:,:)=0
C
      KPFLIM(:,:)=2
      KHFLIM(:,:)=1
      KOFLIM(:,:)=0
C
      KPFLIQ(:,:)=2
      KHFLIQ(:,:)=1
      KOFLIQ(:,:)=0
C
      KPFLIZ(:)=2
      KHFLIZ(:)=1
      KOFLIZ(:)=0
C
      KPMLIG(:,:)=2
      KHMLIG(:,:)=1
      KOMLIG(:,:)=0
C
      KPMLIM(:)=2
      KHMLIM(:)=1
      KOMLIM(:)=0
C
      KPMLIQ(:)=2
      KHMLIQ(:)=1
      KOMLIQ(:)=0
C
      KPMLIZ=2
      KHMLIZ=1
      KOMLIZ=0
C
      NIBLOC(:)=0
      NIBLOL(:,:)='               '
      NIBLOM(:,:)=0
      NIBLOE(:,:)=0
C
C=======================================================================
C         FILLING
C=======================================================================
C
      KPFILG(:,:,:)=2
      KHFILG(:,:,:)=1
      KOFILG(:,:,:)=0
C
      KPFILZ(:)=2
      KHFILZ(:)=1
      KOFILZ(:)=0
C
C=======================================================================
C         ADIABATIC METHOD
C=======================================================================
C
      IADBAT=0
C
      IABMOD=2
      IABNTE=99
      DABPRS=1.d-6
      XCHIMX=0.5d0
      IABCOL=1
      IABICH=0
C
      SFIADB='RADBCL.VIB'
      SFJADB='RADBCL.VJB'
C
      IADBLN=0
C
C=======================================================================
C         FINITE AMPLITUDE METHOD
C=======================================================================
C
      IFAMON=0
C
      ETAFAM=1.d-6
C
C=======================================================================
C         INTRINSIC/PROJECTED MULTIPOLE TOMOGRAPHY/ONE-BODY DENSITY
C=======================================================================
C
      ITOMOZ=0
C
      PTOMOX=0.0
      PTOMOY=0.0
      PTOMOZ=1.0
C
C=======================================================================
C         TYPE OF DENSITY CONSIDERED FOR MULTIPOLE TOMOGRAPHY
C=======================================================================
C
      IOBSCH=1
      IDESCH=1
      INDENS=-1
C
C=======================================================================
C         DEFINE CONDITIONAL DENSITY SLICE
C=======================================================================
C
      ITOMSC=0
C
      P0VECX=0.D0
      P0VECY=0.D0
      P0VECZ=0.D0
      P1VECX=1.D0
      P1VECY=0.D0
      P1VECZ=0.D0
      P2VECX=0.D0
      P2VECY=0.D0
      P2VECZ=1.D0
C
C=======================================================================
C         IMK OF PROJECTED MULTIPOLE TOMOGRAPHY AND INTEGRATION NODES
C=======================================================================
C
      ITOMII=0
      ITOMMM=0
      ITOMKK=0
      NTOMNB=10
      NTOMNA=10
C
C=======================================================================
C         DEFINE THE SIZE OF CONDITIONAL DENSITY DISTRIBUTION SLICE
C=======================================================================
C
      NCMESH=0
      PINTSC=0.D0
      PWIDTH=5.D0
      PHEIGH=5.D0
C
C=======================================================================
C         TWO-CENTER BASIS
C=======================================================================
C
      ITWCEN=1
C
      CENCOR(:,:)= 0.D0
C
C     STIFFNESS, ASKED PARTICLE NUMBER AND SWITCH FOR THE FRAGMENTS
      FRGSTF= 0.D0
      FRGASK= 0.D0
      CLMFRA= 0.D0
      IFLFRG= 0

C
      QFRA_N=0.D0
      QFRA_P=0.D0
      QFRA_T=0.D0
C
C     CONSTRAINT IN FRAGMENT'S DEFORMATION
      STQTWC=0.D0
      QTWCAS=0.D0
      IFLQTW=0
C
C     INITIALIZING FROM PREVIOUS LAGRANGE MULTIPLIERS
      IFRCNT=0
C
C     ORIENTATION OF FRAGMENTS
      IROFRG(:)=0
C
      ALFFRA(:)=0.0D0
      BETFRA(:)=0.0D0
      GAMFRA(:)=0.0D0
C
C=======================================================================
C         NATURAL BASIS CUT-OFF
C=======================================================================
C
      IEIGCU=0
      EIGCUT=1E-06
C
C=======================================================================
C         COULOMB MIXING MATRIX ELEMENTS
C=======================================================================
C
      ICOUMD=0
      ICOUMX=0
C
C=======================================================================
C         NUMERICAL DATA
C=======================================================================
C
      NMUCON=2
      NMUCOU=4
      NMUPRI=4
C
      NSICON=0
      NSIPRI=0
C
      ISCHIF=0
C
      NMACON=0
      NMAPRI=0
      NMAORD=0
      MAG2BC(:)=0
      MAGANL(:)=0
C
      NASCON=0
      NASPRI=0
C     SEE COMMENT OF 27/10/2023 IN TESDAT
      NASORD=-1
C
      NRAORD=0
C
      NMURED=2
      NMARED=1
C     SEE COMMENT OF 27/10/2023 IN TESDAT
      NASRED=0
      NSIRED=0
C
      IGYROS=0
      GYRORP=1.0D0
      GYRSPN=1.0D0
      GYRSPP=1.0D0
C
      IGY2BC=0
      GIN2BC=1.0D0
      GSA2BC=1.0D0
C
      IGYANL=0
      GJ2ANL=1.0D0
      GSQANL=1.0D0
C
      NEXBET=4
      IPRIBE=0
      IPRIBL=1
C
      NUMCOU=80
      NUMETA=79
      FURMAX=0.25
C
      ICOTYP=7
      ICOUDI=1
      ICOUEX=1
      E_EFFE=1.0D0
C
      PIMASS=0.7045
      PNMASS=4.7565
      YUKAGT=1.0D0
      YUKAG0=0.0D0
      YUKAG1=0.0D0
      YUKAG2=0.0D0
      IYUTYP=1
      I_YUKA=0
C
      NEWGOG=0
      NEWCOU=0
C
      I_GOGA=0
      IGOGPA=0
C
      I_REGA=0
      IREGPA=0
C
      N3SERD=0
      I_SEPA=0
      ISEPPA=0
C
      I_COUA=0
      ICOUPA=0
C
      I_FSTA(:)=0
      IFSTPA(:)=0
C
      IDIQGA=0
      DIQCOD=0.0D0
      DIQCOE=0.0D0
      DIQCOP=0.0D0
C
      REGWID=1.0D0
C
      REJVCC(:,:)=0.0D0
      REJERR(:,:)=0.0D0
      REJFAC(:,:)=0.0D0
      REJTCC(:,:)=0.0D0
C
      IREREJ(:)=100
      NREREJ(:)=0
C
      FSOSTR(:,:)=0.0D0
      FTOSTR(:,:)=0.0D0
      FTESTR(:,:)=0.0D0
C
      FSTWID(:)=1.0D0
C
      IVISEP=0
      IERSEP=0
      IFASEP=0
C
      SEPVIC=0.0D0
      SEPERR=0.0D0
      SEPFAC=0.0D0
C
      NUSEGA=1
      SEPWID=1.0D0
      SEPGAU=0.0D0
      SEPGAU(1)=1.0D0
C
      IDOTHC=0
C
      SLOWEV=0.500
      SLOWOD=0.500
      SLOWPA=0.500
      SLOWLI=0.500
C
      SLOWLD=0.5D0
      SLOWTP=0.5D0
      SLOWRP=0.5D0
      SLOWLM=0.5D0
C
      I_SLOW=0
      SLOWAL=0.5D0
C
#if(SWITCH_QUAD==1)
      EPSHER=1.0D-30
#else
      EPSHER=1.0D-14
#endif
C
      IOPTGS=1
C
      NXHERM=18
      NYHERM=18
      NZHERM=32
C
      RANGX=20.0D0
      NPOINT=500
C
C=======================================================================
C         PARAMETERS OF THE HARMONIC OSCILLATOR BASIS
C=======================================================================
C
      IBASIS=0
C
      NOSCIL=15
      NLIMIT=301
      ENECUT=800.
C
      FCHOM0=1.20
C
      ILIBAS=0
      INBASI=86
      IZBASI=66
      R0PARM=1.23
C
      ALPHAR(:,:)=0.0D0
C
C      Attention: preset nuclear surface is deformed as follows
      ALPHAR(2,0)=0.61
      ALPHAR(4,0)=0.10
C
      BASINX(:)=1.0D0
      BASINY(:)=1.0D0
      BASINZ(:)=1.0D0
C
      INPOME=0
      NLIMTW=0
      ENECTW=800.
C
C=======================================================================
C         CONSTRAINTS
C=======================================================================
C
      IMOVAX=0
      ITILAX=0
      ITISAX=0
C
      NO_ORB=0
C
      OMOVAX=0.0D0
      OMOVAY=0.0D0
      OMOVAZ=0.0D0
C
      OMEGAX=0.00D0
      OMEGAY=0.50D0
      OMEGAZ=0.00D0
C
      OMISOX=0.00D0
      OMISOY=0.00D0
      OMISOZ=0.00D0
C
      STIFFQ(:,:)=0.0D0
      QASKED(:,:)=0.0D0
      IFLAGQ(:,:)=0
C
      QLINEA(:,:)=0.0D0
      IFLALQ(:,:)=0
C
      STIFFV(:,:)=0.0D0
      VASKED(:,:)=0.0D0
      IFLAGV(:,:)=0
C
      VLINEA(:,:)=0.0D0
      IFLALV(:,:)=0
C
C      Attention: there is a preset constraint on Q20 as follows
      STIFFQ(2,0)=00.01D0
      QASKED(2,0)=42.00D0
      IFLAGQ(2,0)=1
C
      STIFFS(:,:)=0.0D0
      SASKED(:,:)=0.0D0
      SLINEA(:,:)=0.0D0
C
      IFLAGS(:,:)=0
      IFLALS(:,:)=0
C
      STIFFG(:)=0.0D0
      GASKED(:)=0.0D0
C
      IFLAGG(:)=0
C
      STIFFI(:)=0.0
      ASKEDI(:)=0.0
      IFLAGI(:)=0
C
      STIFTI(:)=0.0
      ASKETI(:)=0.0
      IFTAGI(:)=0
C
      STIFFT(:)=0.0
      ASKEDT(:)=0.0
      IFLAGT(:)=0
C
      DALSPI(:)=0.0
      IFLALI(:)=0
C
      DALISO(:)=0.0
      IFLALT(:)=0
C
      STIFFA=0.00D0
      ASKEDA=0.00D0
      IFLAGA=0
C
C=======================================================================
C         OUTPUT-FILE PARAMETERS
C=======================================================================
C
      I1LINE=1
      IPRSTA=1
      IPRMID=0
      IPRSTO=1
C
      INTRIP=1
      IVIPRI=0
C
      IPRI_N=1
      IPRI_P=1
      IPRI_T=1
C
      EMINAL=-12.
      EMAXAL=  0.
C
      EMAXQU=10.
C
      ISYMDE=0
C
      NILXYZ=3
      IQUNIL=0
C
C=======================================================================
C         FILES
C=======================================================================
C
      FILREV='HFODD.REV'
      FILREC='HFODD.REC'
      FILREP='HFODD.REP'
      FILWOO='WOODS.WFN'
      FILCOU='HFODD.COU'
      FILWAV='HFODD.WFN'
      FILKER='HFODD.KER'
      FILYUC='HFODD.YUC'
      FILYUP='HFODD.YUP'
      FILGOC='HFODD.GOC'
      FILGOP='HFODD.GOP'
      FILGPC='HFODD.GOC'
      FILGPP='HFODD.GOP'
      FILROC='HFODD.ROC'
      FILROP='HFODD.ROP'
      FILLIC='HFODD.LIC'
      FILLIP='HFODD.LIP'
      FILFIC='HFODD.FIC'
      FILFIP='HFODD.FIP'
      FILFER='HFODD.FER'
      FILQUA='HFODD.QUA'
      FILRED='HFODD.RED'
      FILBAC='HFODD.BAC'
      FILBAP='HFODD.BAP'
C
      FILISO='HFODD.ISO'
C
      FILLEF(:)='HFODD.LEF'
      FILRIG(:)='HFODD.RIG'
      NUCONF=0
      NAMKER=1
C
      IWRIOL=0
      IWRISO=0
C
      IWRIRE=1
      IWRILI=1
      IWRIYU=-1
      IWRIGO=-1
      IWRIRO=-1
      IWRIFI=-1
C
      IWRIQU=-1
C
      IWRIBA=-1
C
      IWRIRM=0
C
      IREVIE=2
C
      INUNIL=0
C
      ICOULI=0
      ICOULO=0
C
C=======================================================================
C         STARTING THE ITERATION
C=======================================================================
C
      ICONTI=0
      IPCONT=0
      IOCONT=0
      ISCONT=0
      ITCONT=0
      IYCONT=0
      IGCONT=0
      IGPCON=0
      IECONT=0
      ILCONT=0
      IFCONT=0
      IMCONT=0
      IACONT=0
      IRCONT=0
      IBCONT=0
      IREAWS=0
C
      NILDAT=0
C
      CNILSN=-1.175
      DNILSN=-0.247
C
      CNILSP=-1.175
      DNILSP=-0.352
C
      HBANIX=11.170
      HBANIY=11.170
      HBANIZ= 6.280
C
      imominer=0
      imaspar=0
      numcoor=0
      icolcoor=0
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NOALLO(NAMMAT,NAMSUB)
C
      CHARACTER
     *          NAMMAT*6,NAMSUB*6
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
      WRITE(NFIPRI,'(/,
     *           1X,19(1H/),'' ALLOCATION OF MEMORY FOR ARRAY: '',A6,
     *                                                   1X,19(1H/),/,
     *           1X,19(1H/),'' WAS UNSUCCESSFUL IN SUBROUTINE: '',A6,
     *                                                   1X,19(1H/),/,
     *           1X,19(1H/),'' PLEASE RERUN THE CODE USING A COMPUTER'',
     *                                                   1X,19(1H/),/,
     *           1X,19(1H/),'' THAT HAS A LARGER MEMORY. YOU MAY ALSO'',
     *                                                   1X,19(1H/),/,
     *           1X,19(1H/),'' NEED TO USE A 64-BIT FORTRAN COMPILER.'',
     *                                                   1X,19(1H/),/)')
     *          NAMMAT,NAMSUB
C
      IDUMMY=1
C
      IF (IDUMMY.EQ.1)
     *    STOP ' ALLOCATION OF MEMORY FAILED'
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NILASP(NOSCIL,MREVER,ICHARG,ISIMPY,NILXYZ)
C=======================================================================
      USE ALLWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      CHARACTER
     *          FORMA*1,FORMB*1
      CHARACTER
     *          SPKART*10,SPNILS*15,SPORDE*13,SPNILA*15,SPNILB*15
C
      COMPLEX
     *          SPINUP,SPINDW,AUZCYL
      COMPLEX
     *          WASPUP,WASPDW,UNIT_I
      COMPLEX
     *          WASPIN,PHASPI
      COMPLEX
     *          C_ZERO,C_UNIT
C=======================================================================
      ALLOCATABLE SPINUP(:,:)
      ALLOCATABLE SPINDW(:,:)
      ALLOCATABLE AUZCYL(:,:)
C=======================================================================
      DIMENSION
     *          NSTATE(2*NDTRAN)
      DIMENSION
     *          MAINCL(2*NDTRAN),LAMBCL(2*NDTRAN),
     *          NSPICL(2*NDTRAN),IOMECL(2*NDTRAN),NZ__CL(2*NDTRAN)
      DIMENSION
     *          SPNILB(2*NDTRAN)
      DIMENSION
     *          SPAMPB(2*NDTRAN)
C=======================================================================
      ALLOCATABLE WASPIN(:,:,:)
C=======================================================================
      COMMON
     *       /SPLABS/ SPKART(1:2*NDSTAT,0:NDISOS),
     *                SPNILS(1:2*NDSTAT,0:NDISOS),
     *                SPORDE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /ALLABS/ SPNILA(1:2*NDSTAT,2*NDTRAN,0:NDISOS)
      COMMON
     *       /ALAMPL/ SPAMPL(1:2*NDSTAT,2*NDTRAN,0:NDISOS),
     *                SPAMPN(1:2*NDSTAT,        0:NDISOS)
      COMMON
     *       /BASCLI/ NBASER(NDTRAN),
     *                NBASEP(NDTRAN),
     *                NBASEM(NDTRAN),
     *                NBASPA(NDTRAN)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
C=======================================================================
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('NILASP',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (SPINUP(1:2*NDSTAT,NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINUP','NILASP')
      ALLOCATE (SPINDW(1:2*NDSTAT,NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINDW','NILASP')
      ALLOCATE (AUZCYL(NDBASE,NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUZCYL','NILASP')
      ALLOCATE (WASPIN(1:NDBASE,1:2*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WASPIN','NILASP')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE NILSSON LABELS OF
C        SINGLE-PARTICLE STATES
C=======================================================================
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      SQ2=SQRT(2.0D0)
C
C=======================================================================
C
C         DEFINING THE TWO-DIMENSIONAL MATRICES
C         < NX,NY,NZ | NRO,NZ,M >  OF THE H.O. B R A C K E T S
C
C=======================================================================
C
      CALL CYLXYZ(NOSCIL)
C
      CALL TRANSC(NOSCIL,AUZCYL,NILXYZ,LDTRAN)
C
C=======================================================================
C        CALCULATING THE SPIN WAVE FUNCTIONS
C=======================================================================
C
      WASPIN(:,:,:)=C_ZERO
C
      DO IREVER=0,MREVER
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(DYNAMIC)
!$OMP& SHARED(NUMBSP,IREVER,ICHARG,ISIMPY,LDBASE,
!$OMP&        WASPIN,WAVOCC,PHASPI,NILXYZ,SQ2,UNIT_I)
!$OMP& PRIVATE(ISTATE,LSTATE,IBASE,ISPIN,WASPUP,WASPDW)
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            LSTATE=ISTATE+IREVER*NUMBSP(0,ICHARG)
C
            IF (LSTATE.GT.2*NDSTAT)
     *
     *          STOP ' LSTATE > 2*NDSTAT IN NILASP'
C
C=======================================================================
C           DEFINING THE WASPIN ARRAY FOR THE CONSERVED SIMPLEX
C=======================================================================
C
            IF (ISIMPY.EQ.1) THEN
C
                DO IBASE=1,LDBASE
                   DO ISPIN=0,NDSPIN
C
                      WASPIN(IBASE,LSTATE,ISPIN)=
     *                WAVOCC(IBASE,LSTATE,IREVER)
     *               *PHASPI(IBASE,IREVER,ISPIN,1)
C
                   END DO
                END DO
C
            ELSE
C
C=======================================================================
C           DEFINING THE WASPIN ARRAY FOR THE NON-CONSERVED SIMPLEX
C=======================================================================
C
                DO IBASE=1,LDBASE
                   DO ISPIN=0,NDSPIN
C
                      WASPIN(IBASE,LSTATE,ISPIN)=
     *
     *               (WAVOCC(IBASE,LSTATE,0)*PHASPI(IBASE,0,ISPIN,1)
     *               +WAVOCC(IBASE,LSTATE,1)*PHASPI(IBASE,1,ISPIN,1))
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           DEFINING THE WASPIN ARRAY FOR THE SPIN QUANTIZED ALONG THE
C           X-AXIS
C=======================================================================
C
            IF (NILXYZ.EQ.1) THEN
C
                DO IBASE=1,LDBASE
C
                   WASPUP=(WASPIN(IBASE,LSTATE,1)
     *                    +WASPIN(IBASE,LSTATE,0))/SQ2
C
                   WASPDW=(WASPIN(IBASE,LSTATE,1)
     *                    -WASPIN(IBASE,LSTATE,0))/SQ2
C
                   WASPIN(IBASE,LSTATE,1)=WASPUP
                   WASPIN(IBASE,LSTATE,0)=WASPDW
C
                END DO
C
            END IF
C
C=======================================================================
C           DEFINING THE WASPIN ARRAY FOR THE SPIN QUANTIZED ALONG THE
C           Y-AXIS
C=======================================================================
C
            IF (NILXYZ.EQ.2) THEN
C
                DO IBASE=1,LDBASE
C
                   WASPUP=(WASPIN(IBASE,LSTATE,1)
     *                    -WASPIN(IBASE,LSTATE,0)*UNIT_I)/SQ2
C
                   WASPDW=(WASPIN(IBASE,LSTATE,1)
     *                    +WASPIN(IBASE,LSTATE,0)*UNIT_I)/SQ2
C
                   WASPIN(IBASE,LSTATE,1)=WASPUP
                   WASPIN(IBASE,LSTATE,0)=WASPDW
C
                END DO
C
            END IF
C
         END DO
!$OMP END PARALLEL DO
      END DO
C
#if(USE_OPENMP==0)
      IF (LSTATE.NE.NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG))
     *
     *    STOP ' INCORRECT LSTATE IN NILASP'
#endif
C
C=======================================================================
C            J U S T   M U L T I P L Y I N G   M A T R I C E S
C=======================================================================
C            ATTENTION: THE CALL TO "CGEMM" BELOW BECAME INCORRECT  WHEN
C                       THE NUMBER OF SINGLE-PARTICLE  STATES  HAS  BEEN
C                       IN  VERSION  (1.84)  REDUCED  FROM  "NDBASE"  TO
C                       "NDSTAT". THIS BUG WAS CORRECTED  ON  09/02/2004
C                       IN VERSION (2.08F).
C=======================================================================
C            ATTENTION: THE CALL TO "ZGEMUL" BELOW BECAME INCORRECT WHEN
C                       THE NUMBER OF  TESTED  AMPLITUDES  HAS  BEEN  IN
C                       VERSION (1.60) REDUCED FROM "NDTRAN" TO "NDBASE"
C                       THIS BUG DID NOT AFFECT  RESULTS  OF  THE  CALL;
C                       ONLY THE INDICES IN "ZGEMUL" WERE RUNNING BEYOND
C                       DIMENSIONS  TRANSFERRED  TO  "ZGEMUL".  HOWEVER,
C                       WHEN THE NUMBER OF  SINGLE-PARTICLE  STATES  HAS
C                       BEEN IN VERSION  (1.84)  REDUCED  FROM  "NDBASE"
C                       TO "NDSTAT", THIS BECAME A REAL BUG IN CASE  THE
C                       DIMENSIONS WERE SUCH THAT 2*NDSTAT > NDBASE, AND
C                       THE TIME-REVERSAL  WAS  BROKEN  (IROTAT=1). THIS
C                       BUG WAS CORRECTED ON 09/02/04 IN VERSION (2.08F)
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
      FORMA='T'
      FORMB='N'
C
      LSTATE=NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG)
C
      NDACTU=2*NDSTAT
C
      CALL ZGEMM(FORMA,FORMB,LSTATE,LDTRAN,LDBASE,
     *                C_UNIT,WASPIN(1,1,0),NDBASE,
     *                              AUZCYL,NDBASE,
     *                       C_ZERO,SPINDW,NDACTU)
C
      CALL ZGEMM(FORMA,FORMB,LSTATE,LDTRAN,LDBASE,
     *                C_UNIT,WASPIN(1,1,1),NDBASE,
     *                              AUZCYL,NDBASE,
     *                       C_ZERO,SPINUP,NDACTU)
C
C=======================================================================
C         COLLECTING THE QUANTUM NUMBERS OF THE CYLINDRICAL BASIS
C=======================================================================
C
      NBASE=0
C
      DO JCYLIN=1,LDTRAN
C
         NRO=NBASER(JCYLIN)
         NZ =NBASEP(JCYLIN)
         M  =NBASEM(JCYLIN)
C
         DO NSPIN=-1,1,2
C
            NBASE=NBASE+1
C
            IF (NBASE.GT.2*NDTRAN) STOP 'INCORRECT NDTRAN IN NILASP'
C
            MAINCL(NBASE)=2*NRO+NZ+M
            LAMBCL(NBASE)=M
            NZ__CL(NBASE)=NZ
            NSPICL(NBASE)=NSPIN
            IOMECL(NBASE)=2*LAMBCL(NBASE)+NSPIN
            NSTATE(NBASE)=JCYLIN
C
         END DO
      END DO
C
C=======================================================================
C         FINDING THE COMPONENTS WITH MAXIMUM AMPLITUDES
C=======================================================================
C
      DO ISTATE=1,LSTATE
C
         INDMAX=0
         ELEMAX=-1.0
C
         DO IBASE=1,NBASE
C
            IF (NSPICL(IBASE).EQ.1) THEN
C
                AMPLIT=ABS(SPINUP(ISTATE,NSTATE(IBASE)))
            ELSE
                AMPLIT=ABS(SPINDW(ISTATE,NSTATE(IBASE)))
C
            END IF
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.87C) AND (3.33),  THERE  WAS  A
C                    BUG IN SAVING ON THE REVIEW FILE THE NILSSON LABELS
C                    FOR NON-DOMINATING NILSSON COMPONENTS, SEE  KEYWORD
C                    "ALLNILABS". THE BUG WAS  IN  SUBROUTINE  "NILASP",
C                    WHERE THOSE LABELS WERE  INCORRECTLY  STORED.  THIS
C                    BUG WAS CORRECTED ON 15/02/2025 IN VERSION (3.33A).
C=======================================================================
C
            SPAMPL(ISTATE,IBASE,ICHARG)=AMPLIT**2
C
            MAIN=MAINCL(IBASE)
            NZ  =NZ__CL(IBASE)
            LAMB=LAMBCL(IBASE)
            IOME=IOMECL(IBASE)
C
            WRITE(SPNILA(ISTATE,IBASE,ICHARG),
     *                  '(''|'',I2,'','',I2,'','',I2,'','',I2,''/2>'')')
     *                                     MAIN,NZ,IABS(LAMB),IABS(IOME)
C
            IF (ELEMAX.LT.AMPLIT) THEN
C
                INDMAX=IBASE
                ELEMAX=AMPLIT
C
            END IF
C
         END DO
C
         IF (INDMAX.LE.0.OR.INDMAX.GT.2*LDTRAN)
     *
     *       STOP '  WRONG INDMAX INDEX IN NILASP'
C
         MAIN=MAINCL(INDMAX)
         NZ  =NZ__CL(INDMAX)
         LAMB=LAMBCL(INDMAX)
         IOME=IOMECL(INDMAX)
C
         WRITE(SPNILS(ISTATE,ICHARG),
     *                  '(''|'',I2,'','',I2,'','',I2,'','',I2,''/2>'')')
     *                                     MAIN,NZ,IABS(LAMB),IABS(IOME)
C
      END DO
C
C=======================================================================
C         ORDERING THE COMPONENTS ACCORDING TO DECREASING AMPLITUDES
C=======================================================================
C
      DO ISTATE=1,LSTATE
C
         SPAMPN(ISTATE,ICHARG)=0.0D0
C
         DO IBASE=1,NBASE
C
            NSTATE(IBASE)=IBASE
C
            SPAMPB(IBASE)=SPAMPL(ISTATE,IBASE,ICHARG)
            SPNILB(IBASE)=SPNILA(ISTATE,IBASE,ICHARG)
C
            SPAMPN(ISTATE,ICHARG)=SPAMPN(ISTATE,ICHARG)+SPAMPB(IBASE)
C
         END DO
C
         CALL ORDER1(SPAMPB,NSTATE,NBASE)
C
         DO IBASE=1,NBASE
C
            SPAMPL(ISTATE,IBASE,ICHARG)=SPAMPB(       NBASE-IBASE+1 )
            SPNILA(ISTATE,IBASE,ICHARG)=SPNILB(NSTATE(NBASE-IBASE+1))
C
         END DO
C
      END DO
C
C=======================================================================
      DEALLOCATE (SPINUP,SPINDW,AUZCYL)
      DEALLOCATE (WASPIN)
C=======================================================================
C
      CALL CPUTIM('NILASP',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NILAQP(NOSCIL,MREVER,ICHARG,ISIMPY,NILXYZ)
C=======================================================================
      USE ALLQUA
      USE ALLQUZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      CHARACTER
     *          FORMA*1,FORMB*1
      CHARACTER
     *          QPORDD*13,
     *          QPNILS*15,QPNILA*15,QPNILB*15,QPNILC*15,QPNILD*15,
     *          QPNIL2*9,QPNILE*9
C
      COMPLEX
     *          SPINUP,SPINDW,AUZCYL
      COMPLEX
     *          WASPUP,WASPDW,UNIT_I
      COMPLEX
     *          WASPIN,PHASPI
      COMPLEX
     *          C_ZERO,C_UNIT
C=======================================================================
      ALLOCATABLE SPINUP(:,:)
      ALLOCATABLE SPINDW(:,:)
      ALLOCATABLE AUZCYL(:,:)
C=======================================================================
      DIMENSION
     *          NSTATE(2*NDTRAN)
      DIMENSION
     *          MAINCL(2*NDTRAN),LAMBCL(2*NDTRAN),
     *          NSPICL(2*NDTRAN),IOMECL(2*NDTRAN),NZ__CL(2*NDTRAN)
      DIMENSION
     *          QPNILB(NDTRAN)
      DIMENSION
     *          QPAMPB(NDTRAN)
      DIMENSION
     *          QPNORN(1:4*NDSTAT,1:2)
      DIMENSION
     *          QPNILC(1:4*NDSTAT,NDTRAN,1:2)
      DIMENSION
     *          QPNILD(1:4*NDSTAT,       1:2),
     *          QPNILE(1:4*NDSTAT,       1:2)
      DIMENSION
     *          QPAMPC(1:4*NDSTAT,NDTRAN,1:2)
C=======================================================================
      ALLOCATABLE WASPIN(:,:,:)
C=======================================================================
      COMMON
     *       /QPLABS/ QPORDD(1:4*NDSTAT,0:NDISOS),
     *                QPNILS(1:4*NDSTAT,0:NDISOS),
     *                QPNIL2(1:4*NDSTAT,0:NDISOS),
     *                QPNORM(1:4*NDSTAT,0:NDISOS)
      COMMON
     *       /QLLABS/ QPNILA(1:4*NDSTAT,NDTRAN,0:NDISOS)
      COMMON
     *       /QLAMPL/ QPAMPL(1:4*NDSTAT,NDTRAN,0:NDISOS),
     *                QPAMPN(1:4*NDSTAT,       0:NDISOS)
      COMMON
     *       /BASCLI/ NBASER(NDTRAN),
     *                NBASEP(NDTRAN),
     *                NBASEM(NDTRAN),
     *                NBASPA(NDTRAN)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('NILAQP',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (SPINUP(1:4*NDSTAT,NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINUP','NILAQP')
      ALLOCATE (SPINDW(1:4*NDSTAT,NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINDW','NILAQP')
      ALLOCATE (AUZCYL(NDBASE,NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUZCYL','NILAQP')
      ALLOCATE (WASPIN(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WASPIN','NILAQP')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE NILSSON LABELS OF
C        QUASIPARTICLE STATES
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      SQ2=SQRT(2.0D0)
C
C=======================================================================
C
C         DEFINING THE TWO-DIMENSIONAL MATRICES
C         < NX,NY,NZ | NRO,NZ,M >  OF THE H.O. B R A C K E T S
C
C=======================================================================
C
      CALL CYLXYZ(NOSCIL)
C
      CALL TRANSC(NOSCIL,AUZCYL,NILXYZ,LDTRAN)
C
C=======================================================================
C        CALCULATING THE SPIN WAVE FUNCTIONS FOR THE UPPER (IHFB=1)
C                                                AND LOWER (IHFB=2)
C                                                    HFB COMPONENTS
C=======================================================================
C        TO CALCULATE THE OVERLAP OF SINGLE-PARTICLE AND QUASIPARTICLE
C        STATES, SEE COMMENTS IN SUBROUTINE "BLOSIZ"
C=======================================================================
C
      DO IHFB=1,2
C
         WASPIN(:,:,:)=C_ZERO
C
         DO IREVER=0,MREVER
C
            DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
               LSTATE=ISTATE+IREVER*NUMBQP(0,ICHARG)
C
               IF (LSTATE.GT.4*NDSTAT)
     *
     *             STOP ' LSTATE > 4*NDSTAT IN NILAQP'
C
C=======================================================================
C              DEFINING THE WASPIN ARRAY FOR THE CONSERVED SIMPLEX
C=======================================================================
C
               QPNORN(LSTATE,IHFB)=0.0D0
C
               IF (ISIMPY.EQ.1) THEN
C
                   STOP 'NILAQP FOR ISIMPY=1 NOT YET TESTED'
C
                   DO IBASE=1,LDBASE
                      DO ISPIN=0,NDSPIN
C
                         IF (IHFB.EQ.1) THEN
C
                                   WASPIN(IBASE,LSTATE,ISPIN)=
     *        (2*IREVER-1)*CONJG(BWAQUA(IBASE,LSTATE,1-IREVER))
     *                          *PHASPI(IBASE,1-IREVER,ISPIN,1)
C
                             QPNORN(LSTATE,1)=QPNORN(LSTATE,1)
     *                        +ABS(WASPIN(IBASE,LSTATE,ISPIN))**2
C
                         ELSE
C
                                   WASPIN(IBASE,LSTATE,ISPIN)=
     *                       CONJG(AWAQUA(IBASE,LSTATE,IREVER))
     *                            *PHASPI(IBASE,IREVER,ISPIN,1)
C
                             QPNORN(LSTATE,2)=QPNORN(LSTATE,2)
     *                        +ABS(WASPIN(IBASE,LSTATE,ISPIN))**2
C
                         END IF
C
                      END DO
                   END DO
C
               ELSE
C
C=======================================================================
C              DEFINING THE WASPIN ARRAY FOR THE NON-CONSERVED SIMPLEX
C=======================================================================
C
                   DO IBASE=1,LDBASE
                      DO ISPIN=0,NDSPIN
C
                         IF (IHFB.EQ.1) THEN
C
                                    WASPIN(IBASE,LSTATE,ISPIN)=
     *                       (CONJG(BWAQUZ(IBASE,LSTATE,    1))*
     *                              PHASPI(IBASE,     1,ISPIN,1)
     *                       -CONJG(BWAQUZ(IBASE,LSTATE,    0))
     *                             *PHASPI(IBASE,     0,ISPIN,1))
C
                             QPNORN(LSTATE,1)=QPNORN(LSTATE,1)
     *                        +ABS(WASPIN(IBASE,LSTATE,ISPIN))**2
C
                         ELSE
C
                                   WASPIN(IBASE,LSTATE,ISPIN)=
     *                      (CONJG(AWAQUZ(IBASE,LSTATE,    0))*
     *                             PHASPI(IBASE,     0,ISPIN,1)
     *                      +CONJG(AWAQUZ(IBASE,LSTATE,    1))
     *                            *PHASPI(IBASE,     1,ISPIN,1))
C
                             QPNORN(LSTATE,2)=QPNORN(LSTATE,2)
     *                        +ABS(WASPIN(IBASE,LSTATE,ISPIN))**2
C
                         END IF
C
                      END DO
                   END DO
C
               END IF
C
C=======================================================================
C              DEFINING THE WASPIN ARRAY FOR THE SPIN QUANTIZED ALONG
C              THE X-AXIS
C=======================================================================
C
               IF (NILXYZ.EQ.1) THEN
C
                   DO IBASE=1,LDBASE
C
                      WASPUP=(WASPIN(IBASE,LSTATE,1)
     *                       +WASPIN(IBASE,LSTATE,0))/SQ2
C
                      WASPDW=(WASPIN(IBASE,LSTATE,1)
     *                       -WASPIN(IBASE,LSTATE,0))/SQ2
C
                      WASPIN(IBASE,LSTATE,1)=WASPUP
                      WASPIN(IBASE,LSTATE,0)=WASPDW
C
                   END DO
C
               END IF
C
C=======================================================================
C              DEFINING THE WASPIN ARRAY FOR THE SPIN QUANTIZED ALONG
C              THE Y-AXIS
C=======================================================================
C
               IF (NILXYZ.EQ.2) THEN
C
                   DO IBASE=1,LDBASE
C
                      WASPUP=(WASPIN(IBASE,LSTATE,1)
     *                       -WASPIN(IBASE,LSTATE,0)*UNIT_I)/SQ2
C
                      WASPDW=(WASPIN(IBASE,LSTATE,1)
     *                       +WASPIN(IBASE,LSTATE,0)*UNIT_I)/SQ2
C
                      WASPIN(IBASE,LSTATE,1)=WASPUP
                      WASPIN(IBASE,LSTATE,0)=WASPDW
C
                   END DO
C
               END IF
C
            END DO
C
         END DO
C
C=======================================================================
C               J U S T   M U L T I P L Y I N G   M A T R I C E S
C=======================================================================
C
         C_UNIT=CMPLX(1.0D0,0.0D0)
C
         FORMA='T'
         FORMB='N'
C
         KSTATE=NUMBQP(0,ICHARG)+MREVER*NUMBQP(1,ICHARG)
C
         NDACTU=4*NDSTAT
C
         CALL ZGEMM(FORMA,FORMB,KSTATE,LDTRAN,LDBASE,
     *                   C_UNIT,WASPIN(1,1,0),NDBASE,
     *                                 AUZCYL,NDBASE,
     *                          C_ZERO,SPINDW,NDACTU)
C
         CALL ZGEMM(FORMA,FORMB,KSTATE,LDTRAN,LDBASE,
     *                   C_UNIT,WASPIN(1,1,1),NDBASE,
     *                                 AUZCYL,NDBASE,
     *                          C_ZERO,SPINUP,NDACTU)
C
C=======================================================================
C            COLLECTING THE QUANTUM NUMBERS OF THE CYLINDRICAL BASIS
C=======================================================================
C
         NBASE=0
C
         DO JCYLIN=1,LDTRAN
C
            NRO=NBASER(JCYLIN)
            NZ =NBASEP(JCYLIN)
            M  =NBASEM(JCYLIN)
C
            DO NSPIN=-1,1,2
C
               NBASE=NBASE+1
C
               IF (NBASE.GT.2*NDTRAN) STOP 'INCORRECT NDTRAN IN NILAQP'
C
               MAINCL(NBASE)=2*NRO+NZ+M
               LAMBCL(NBASE)=M
               NZ__CL(NBASE)=NZ
               NSPICL(NBASE)=NSPIN
               IOMECL(NBASE)=2*LAMBCL(NBASE)+NSPIN
               NSTATE(NBASE)=JCYLIN
C
            END DO
         END DO
C
C=======================================================================
C            FINDING THE COMPONENTS WITH MAXIMUM AMPLITUDES
C=======================================================================
C
         DO ISTATE=1,NUMBQP(0,ICHARG)+MREVER*NUMBQP(1,ICHARG)
C
            INDMAX=0
            ELEMAX=-1.0
C
            DO IBASE=1,NBASE
C
               IF (NSPICL(IBASE).EQ.1) THEN
C
                   AMPLIT=ABS(SPINUP(ISTATE,NSTATE(IBASE)))
               ELSE
                   AMPLIT=ABS(SPINDW(ISTATE,NSTATE(IBASE)))
C
               END IF
C
               QPAMPC(ISTATE,NSTATE(IBASE),IHFB)=AMPLIT**2
C
               MAIN=MAINCL(IBASE)
               NZ  =NZ__CL(IBASE)
               LAMB=LAMBCL(IBASE)
               IOME=IOMECL(IBASE)
C
               WRITE(QPNILC(ISTATE,NSTATE(IBASE),IHFB),
     *                  '(''|'',I2,'','',I2,'','',I2,'','',I2,''/2>'')')
     *                                     MAIN,NZ,IABS(LAMB),IABS(IOME)
C
               IF (ELEMAX.LT.AMPLIT) THEN
C
                   INDMAX=IBASE
                   ELEMAX=AMPLIT
C
               END IF
C
            END DO
C
            IF (INDMAX.LE.0.OR.INDMAX.GT.2*LDTRAN)
     *
     *          STOP '  WRONG INDMAX INDEX IN NILAQP'
C
            MAIN=MAINCL(INDMAX)
            NZ  =NZ__CL(INDMAX)
            LAMB=LAMBCL(INDMAX)
            IOME=IOMECL(INDMAX)
C
            WRITE(QPNILD(ISTATE,IHFB),
     *                  '(''|'',I2,'','',I2,'','',I2,'','',I2,''/2>'')')
     *                                     MAIN,NZ,IABS(LAMB),IABS(IOME)
C
            IF (IABS(IOME).LT.10) THEN
C
                WRITE(QPNILE(ISTATE,IHFB),
     *                  '(''['',3I1,'']'',I1,''/2 '')')
     *                                     MAIN,NZ,IABS(LAMB),IABS(IOME)
            ELSE
C
                WRITE(QPNILE(ISTATE,IHFB),
     *                  '(''['',3I1,'']'',I2,''/2'')')
     *                                     MAIN,NZ,IABS(LAMB),IABS(IOME)
            END IF
C
         END DO
C
      END DO ! END IHFB LOOP
C
C=======================================================================
C         ORDERING THE LARGER HFB COMPONENTS ACCORDING TO DECREASING
C         AMPLITUDES
C=======================================================================
C
      DO ISTATE=1,NUMBQP(0,ICHARG)+MREVER*NUMBQP(1,ICHARG)
C
         QPAMPN(ISTATE,ICHARG)=0.0D0
C
         IF (QPNORN(ISTATE,1).GT.QPNORN(ISTATE,2)) THEN
C
             IHFB=1
         ELSE
             IHFB=2
C
         END IF
C
         DO JCYLIN=1,LDTRAN
C
            NSTATE(JCYLIN)=JCYLIN
C
            QPAMPB(JCYLIN)=QPAMPC(ISTATE,JCYLIN,IHFB)
            QPNILB(JCYLIN)=QPNILC(ISTATE,JCYLIN,IHFB)
C
            QPAMPN(ISTATE,ICHARG)=QPAMPN(ISTATE,ICHARG)+QPAMPB(JCYLIN)
C
         END DO
C
         CALL ORDER1(QPAMPB,NSTATE,LDTRAN)
C
         DO JCYLIN=1,LDTRAN
C
            QPAMPL(ISTATE,JCYLIN,ICHARG)=QPAMPB(       LDTRAN-JCYLIN+1 )
            QPNILA(ISTATE,JCYLIN,ICHARG)=QPNILB(NSTATE(LDTRAN-JCYLIN+1))
C
         END DO
C
         QPNILS(ISTATE,ICHARG)=QPNILD(ISTATE,IHFB)
         QPNIL2(ISTATE,ICHARG)=QPNILE(ISTATE,IHFB)
         QPNORM(ISTATE,ICHARG)=QPNORN(ISTATE,IHFB)
C
      END DO
C
C=======================================================================
      DEALLOCATE (SPINUP,SPINDW,AUZCYL)
      DEALLOCATE (WASPIN)
C=======================================================================
C
      CALL CPUTIM('NILAQP',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NILAPN(NOSCIL,MREVER,ISIMPY,NILXYZ)
C=======================================================================
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      CHARACTER
     *          PNKART*10,PNNILS*15,PNORDE*13
C
      COMPLEX
     *          SPINUP,SPINDW,AUZCYL
      COMPLEX
     *          WASPUP,WASPDW,UNIT_I
      COMPLEX
     *          WASPIN,PHASPI
C=======================================================================
      ALLOCATABLE SPINUP(:,:)
      ALLOCATABLE SPINDW(:,:)
      ALLOCATABLE AUZCYL(:,:)
C=======================================================================
      DIMENSION
     *          NSTATE(2*NDTRAN)
      DIMENSION
     *          MAINCL(2*NDTRAN),LAMBCL(2*NDTRAN),
     *          NSPICL(2*NDTRAN),IOMECL(2*NDTRAN),NZ__CL(2*NDTRAN)
C=======================================================================
      ALLOCATABLE WASPIN(:,:,:)
C=======================================================================
      COMMON
     *       /PNLABS/ PNKART(1:4*NDSTAT),
     *                PNNILS(1:4*NDSTAT),
     *                PNORDE(1:4*NDSTAT)
      COMMON
     *       /BASCLI/ NBASER(NDTRAN),
     *                NBASEP(NDTRAN),
     *                NBASEM(NDTRAN),
     *                NBASPA(NDTRAN)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
C=======================================================================
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('NILAPN',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (SPINUP(1:4*NDSTAT,2*NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINUP','NILAPN')
      ALLOCATE (SPINDW(1:4*NDSTAT,2*NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINDW','NILAPN')
      ALLOCATE (AUZCYL(NDBASE,NDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUZCYL','NILAPN')
      ALLOCATE (WASPIN(1:2*NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WASPIN','NILAPN')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE NILSSON LABELS IN THE CASE
C        OF THE PROTON-NEUTRON MIXING
C=======================================================================
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      SQ2=SQRT(2.0D0)
C
C=======================================================================
C
C         DEFINING THE TWO-DIMENSIONAL MATRICES
C         < NX,NY,NZ | NRO,NZ,M >  OF THE H.O. B R A C K E T S
C
C=======================================================================
C
      CALL CYLXYZ(NOSCIL)
C
      CALL TRANSC(NOSCIL,AUZCYL,NILXYZ,LDTRAN)
C
C=======================================================================
C        CALCULATING THE SPIN WAVE FUNCTIONS
C=======================================================================
C
      DO IREVER=0,MREVER
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(DYNAMIC)
!$OMP& SHARED(NUMBSP,IREVER,ISIMPY,LDBASE,
!$OMP&        WASPIN,PNMOCC,PHASPI,NILXYZ,SQ2,UNIT_I)
!$OMP& PRIVATE(ISTATE,LSTATE,IBASE,ISPIN,WASPUP,WASPDW)
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            LSTATE=ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))
C
            IF (LSTATE.GT.4*NDSTAT)
     *
     *          STOP ' LSTATE > 4*NDSTAT IN NILAPN'
C
C=======================================================================
C           DEFINING THE WASPIN ARRAY FOR THE CONSERVED SIMPLEX
C=======================================================================
C
            IF (ISIMPY.EQ.1) THEN
C
                DO IBASE=1,LDBASE
                   DO ISPIN=0,NDSPIN
C
                      WASPIN(       IBASE,LSTATE,ISPIN)=
     *                PNMOCC(       IBASE,LSTATE,IREVER)
     *               *PHASPI(       IBASE,IREVER,ISPIN,1)
C
                      WASPIN(LDBASE+IBASE,LSTATE,ISPIN)=
     *                PNMOCC(LDBASE+IBASE,LSTATE,IREVER)
     *               *PHASPI(       IBASE,IREVER,ISPIN,1)
C
                   END DO
                END DO
C
            ELSE
C
C=======================================================================
C           DEFINING THE WASPIN ARRAY FOR THE NON-CONSERVED SIMPLEX
C=======================================================================
C
                DO IBASE=1,LDBASE
                   DO ISPIN=0,NDSPIN
C
                      WASPIN(       IBASE,LSTATE,ISPIN)=
     *
     *               (PNMOCC(       IBASE,LSTATE,0)
     *               *PHASPI(       IBASE,0,ISPIN,1)
     *               +PNMOCC(       IBASE,LSTATE,1)
     *               *PHASPI(       IBASE,1,ISPIN,1))
C
                      WASPIN(LDBASE+IBASE,LSTATE,ISPIN)=
     *
     *               (PNMOCC(LDBASE+IBASE,LSTATE,0)
     *               *PHASPI(       IBASE,0,ISPIN,1)
     *               +PNMOCC(LDBASE+IBASE,LSTATE,1)
     *               *PHASPI(       IBASE,1,ISPIN,1))
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           DEFINING THE WASPIN ARRAY FOR THE SPIN QUANTIZED ALONG THE
C           X-AXIS
C=======================================================================
C
            IF (NILXYZ.EQ.1) THEN
C
                DO IBASE=1,2*LDBASE
C
                   WASPUP=(WASPIN(IBASE,LSTATE,1)
     *                    +WASPIN(IBASE,LSTATE,0))/SQ2
C
                   WASPDW=(WASPIN(IBASE,LSTATE,1)
     *                    -WASPIN(IBASE,LSTATE,0))/SQ2
C
                   WASPIN(IBASE,LSTATE,1)=WASPUP
                   WASPIN(IBASE,LSTATE,0)=WASPDW
C
                END DO
C
            END IF
C
C=======================================================================
C           DEFINING THE WASPIN ARRAY FOR THE SPIN QUANTIZED ALONG THE
C           Y-AXIS
C=======================================================================
C
            IF (NILXYZ.EQ.2) THEN
C
                DO IBASE=1,2*LDBASE
C
                   WASPUP=(WASPIN(IBASE,LSTATE,1)
     *                    -WASPIN(IBASE,LSTATE,0)*UNIT_I)/SQ2
C
                   WASPDW=(WASPIN(IBASE,LSTATE,1)
     *                    +WASPIN(IBASE,LSTATE,0)*UNIT_I)/SQ2
C
                   WASPIN(IBASE,LSTATE,1)=WASPUP
                   WASPIN(IBASE,LSTATE,0)=WASPDW
C
                END DO
C
            END IF
C
         END DO
!$OMP END PARALLEL DO
      END DO
C
#if(USE_OPENMP==0)
      IF (LSTATE.NE.NUMBSP(0,0)+NUMBSP(0,1)
     *                                +MREVER*(NUMBSP(1,0)+NUMBSP(1,1)))
     *
     *    STOP ' INCORRECT LSTATE IN NILAPN'
#endif
C
C=======================================================================
C            J U S T   M U L T I P L Y I N G   M A T R I C E S
C=======================================================================
C            ATTENTION: THE CALL TO "CGEMM" BELOW BECAME INCORRECT  WHEN
C                       THE NUMBER OF SINGLE-PARTICLE  STATES  HAS  BEEN
C                       IN  VERSION  (1.84)  REDUCED  FROM  "NDBASE"  TO
C                       "NDSTAT". THIS BUG WAS CORRECTED  ON  09/02/2004
C                       IN VERSION (2.08F).
C=======================================================================
C            ATTENTION: THE CALL TO "ZGEMUL" BELOW BECAME INCORRECT WHEN
C                       THE NUMBER OF  TESTED  AMPLITUDES  HAS  BEEN  IN
C                       VERSION (1.60) REDUCED FROM "NDTRAN" TO "NDBASE"
C                       THIS BUG DID NOT AFFECT  RESULTS  OF  THE  CALL;
C                       ONLY THE INDICES IN "ZGEMUL" WERE RUNNING BEYOND
C                       DIMENSIONS  TRANSFERRED  TO  "ZGEMUL".  HOWEVER,
C                       WHEN THE NUMBER OF  SINGLE-PARTICLE  STATES  HAS
C                       BEEN IN VERSION  (1.84)  REDUCED  FROM  "NDBASE"
C                       TO "NDSTAT", THIS BECAME A REAL BUG IN CASE  THE
C                       DIMENSIONS WERE SUCH THAT 2*NDSTAT > NDBASE, AND
C                       THE TIME-REVERSAL  WAS  BROKEN  (IROTAT=1). THIS
C                       BUG WAS CORRECTED ON 09/02/04 IN VERSION (2.08F)
C=======================================================================
C
      LSTATE=NUMBSP(0,0)+NUMBSP(0,1)+MREVER*(NUMBSP(1,0)+NUMBSP(1,1))
C
      DO ISTATE=1,LSTATE
         DO JCYLIN=1,LDTRAN
C
            SPINDW(ISTATE,       JCYLIN)=CMPLX(0.0D0,0.0D0)
            SPINDW(ISTATE,LDTRAN+JCYLIN)=CMPLX(0.0D0,0.0D0)
C
            SPINUP(ISTATE,       JCYLIN)=CMPLX(0.0D0,0.0D0)
            SPINUP(ISTATE,LDTRAN+JCYLIN)=CMPLX(0.0D0,0.0D0)
C
            DO IBASE=1,LDBASE
C
               SPINDW(ISTATE,       JCYLIN)=SPINUP(ISTATE,       JCYLIN)
     *               +WASPIN(       IBASE,ISTATE,0)*AUZCYL(IBASE,JCYLIN)
               SPINDW(ISTATE,LDTRAN+JCYLIN)=SPINDW(ISTATE,LDTRAN+JCYLIN)
     *               +WASPIN(LDBASE+IBASE,ISTATE,0)*AUZCYL(IBASE,JCYLIN)
C
               SPINUP(ISTATE,       JCYLIN)=SPINUP(ISTATE,       JCYLIN)
     *               +WASPIN(       IBASE,ISTATE,1)*AUZCYL(IBASE,JCYLIN)
               SPINUP(ISTATE,LDTRAN+JCYLIN)=SPINDW(ISTATE,LDTRAN+JCYLIN)
     *               +WASPIN(LDBASE+IBASE,ISTATE,1)*AUZCYL(IBASE,JCYLIN)
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         COLLECTING THE QUANTUM NUMBERS OF THE CYLINDRICAL BASIS
C=======================================================================
C
      NBASE=0
C
      DO JCYLIN=1,LDTRAN
C
         NRO=NBASER(JCYLIN)
         NZ =NBASEP(JCYLIN)
         M  =NBASEM(JCYLIN)
C
         DO NSPIN=-1,1,2
C
            NBASE=NBASE+1
C
            IF (NBASE.GT.2*NDTRAN) STOP 'INCORRECT NDTRAN IN NILAPN'
C
            MAINCL(NBASE)=2*NRO+NZ+M
            LAMBCL(NBASE)=M
            NZ__CL(NBASE)=NZ
            NSPICL(NBASE)=NSPIN
            IOMECL(NBASE)=2*LAMBCL(NBASE)+NSPIN
            NSTATE(NBASE)=JCYLIN
C
         END DO
      END DO
C
C=======================================================================
C         FINDING THE COMPONENTS WITH MAXIMUM AMPLITUDES
C=======================================================================
C
      DO ISTATE=1,LSTATE
C
         INDMAX=0
         ELEMAX=-1.0
C
         DO IBASE=1,NBASE
C
            IF (NSPICL(IBASE).EQ.1) THEN
C
                AMPLIT=ABS(SPINUP(ISTATE,NSTATE(IBASE)))
            ELSE
                AMPLIT=ABS(SPINDW(ISTATE,NSTATE(IBASE)))
C
            END IF
C
            IF (ELEMAX.LT.AMPLIT) THEN
C
                INDMAX=IBASE
                ELEMAX=AMPLIT
C
            END IF
C
            IF (NSPICL(IBASE).EQ.1) THEN
C
                AMPLIT=ABS(SPINUP(ISTATE,LDTRAN+NSTATE(IBASE)))
            ELSE
                AMPLIT=ABS(SPINDW(ISTATE,LDTRAN+NSTATE(IBASE)))
C
            END IF
C
            IF (ELEMAX.LT.AMPLIT) THEN
C
                INDMAX=IBASE
                ELEMAX=AMPLIT
C
            END IF
C
         END DO
C
         IF (INDMAX.LE.0.OR.INDMAX.GT.2*LDTRAN)
     *
     *       STOP '  WRONG INDMAX INDEX IN NILAPN'
C
         MAIN=MAINCL(INDMAX)
         NZ  =NZ__CL(INDMAX)
         LAMB=LAMBCL(INDMAX)
         IOME=IOMECL(INDMAX)
C
         WRITE(PNNILS(ISTATE),
     *                  '(''|'',I2,'','',I2,'','',I2,'','',I2,''/2>'')')
     *                                     MAIN,NZ,IABS(LAMB),IABS(IOME)
C
      END DO
C
C=======================================================================
      DEALLOCATE (SPINUP,SPINDW,AUZCYL)
      DEALLOCATE (WASPIN)
C=======================================================================
C
      CALL CPUTIM('NILAPN',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CYLXYZ(NPERPE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          COEFFC(0:NDPERP,0:NDPERP,0:NDPERP),COF,WSP
      DIMENSION
     *          FACTRL(0:NDPERP),XNEWTN(0:NDPERP,0:NDPERP),
     *          SQFCTL(0:NDPERP),SQ2PWR(0:NDPERP)
      COMMON
     *       /CNXNY / COEFFC
      SAVE
     *     INIT,FACTRL,XNEWTN,SQFCTL,SQ2PWR,SQ2
      DATA
     *     INIT  / -1 /
C
C=======================================================================
C
C        THIS SUBROUTINE CALCULATES THE TRANSFORMATION BRACKETS BETWEEN
C        THE CARTESIAN AND CYLINDRICAL BASES OF THE TWO-DIMENSIONAL HAR-
C        MONIC OSCILLATOR.
C
C        THE CALCULATIONS ARE PERFORMED FOR ALL VALUES OF N-PERPENDICU-
C        LAR UP TO NPERPE. ROUTINE DOES N O T  RECALCULATE THE ELEMENTS
C        ALREADY CALCULATED. IF CALLED MORE TIMES ONLY THE NEW ELEMENTS
C        WILL BE ADDED TO THE STORAGE ARRAY.
C
C        THE RESULTS ARE STORED IN THE COMPLEX ARRAY  'COEFFC' IN COMMON
C        "CNXNY". THE INDICES  OF  THE STORAGE ARRAY HAVE THE FOLLOWING
C        MEANING:
C
C                COEFFC(NX,NRO,NPERP) = <NX,NY|NRO,LAMBDA>
C
C        WHERE:       NX+NY = 2*NRO+LAMBDA = NPERP
C        I.E.         NY=NPERP-NX;  LAMBDA=NPERP-2*NRO
C                     (NX,NRO = 0,1,2,...,NPERP)
C
C=======================================================================
C        SEE  NOTES  "CO" FOR THE DERIVATION OF FORMULAE  AND SYMMETRIES
C        USED.
C=======================================================================
C=============================================== T.R.WERNER, AUGUST 1992
C=======================================================================
C
      IF (NPERPE.LT.     0) STOP 'CYLXYZ - NPERPE .LT. 0'
      IF (NPERPE.GT.NDPERP) STOP 'CYLXYZ - NPERPE .GT. NDPERP'
C
      IF (INIT.EQ.-1) THEN
C
          FACTRL(0)    =1.D0
          SQFCTL(0)    =1.D0
          SQ2PWR(0)    =1.D0
          XNEWTN(0,0)  =1.D0
C
          COEFFC(0,0,0)=CMPLX(1.0D0,0.0D0)
          SQ2          = SQRT(2.D0)
C
          INIT=0
C
      END IF
C
      INIT=INIT+1
C
      IF (NPERPE.LT.INIT) THEN
C
          INIT=INIT-1
          RETURN
C
      END IF
C
      DO NPER=INIT,NPERPE
         DO NRO=INIT,NPERPE
            DO NX=INIT,NPERPE
               COEFFC(NX,NRO,NPER)=CMPLX(0.0D0,0.0D0)
            END DO
         END DO
      END DO
C
C=======================================================================
C         FACTRL(N)   IS THE FACTORIAL OF N
C         SQFCTL(N)   IS THE SQUARE ROOT OF THE FACTORIAL OF N
C         SQ2PWR(N)   IS THE SQUARE ROOT OF THE N-TH POWER OF 2
C         XNEWTN(N,K) IS NEWTON'S SYMBOL "N OVER K"
C=======================================================================
C
      DO I=INIT,NPERPE
C
         FACTRL(I)=FACTRL(I-1)*REAL(I)
         SQFCTL(I)=SQRT(FACTRL(I))
         SQ2PWR(I)=SQ2PWR(I-1)*SQ2
C
         DO K=0,I
            XNEWTN(I,K)=(FACTRL(I)/FACTRL(K))/FACTRL(I-K)
         END DO
C
      END DO
C
C=======================================================================
C                       M A I N   L O O P
C=======================================================================
C
      IPE=2*MOD(INIT,2)-1
C
      DO NPER=INIT,NPERPE
C
         IPX=  -1
         IPY= IPE
         IPE=-IPE
C
         DO NX=0,NPER/2
C
            NY=NPER-NX
            IPX=-IPX
            IPY=-IPY
C
            DO NRO=0,NPER/2
C
               NROPRI=NPER-NRO
               LAMBDA=NPER-2*NRO
               NNNN  =(NPER-LAMBDA)/2
C
               KMIN  =MAX(0,(NX-LAMBDA+1)/2)
               KMAX  =MIN(NNNN,NX/2)
C
               IF (KMAX.GE.KMIN) THEN
C
                   FCT=0.0D0
                   IFA=1-2*MOD(KMIN,2)
C
                   DO K=KMIN,KMAX
                      FCT=FCT+IFA*XNEWTN(NNNN,K)*XNEWTN(LAMBDA,NX-2*K)
                      IFA=-IFA
                   END DO
C
                   FCT=FCT*(SQFCTL(NX)/SQFCTL(NPER-NRO))*SQFCTL(NY)
     *                                    /SQFCTL(NRO)/SQ2PWR(NPER)
C
                   COF=(CMPLX(0.0D0,1.0D0)**(LAMBDA-NX))*FCT
                   COEFFC(NX,NRO,NPER)=COF
C
                   IF (NRO.NE.NROPRI) COEFFC(NX,NROPRI,NPER)=COF*IPY
C
                   IF (NX.NE.NY) THEN
C
                      WSP=CMPLX(0.0D0,-1.0D0)**LAMBDA
                      COEFFC(NY,NRO,NPER)=COF*IPX*WSP
                      IF (NRO.NE.NROPRI) COEFFC(NY,NROPRI,NPER)=COF*WSP
C
                   END IF
C
               END IF
C
            END DO
         END DO
      END DO
C
      INIT=NPERPE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TRANSC(NMAIN,AUZCYL,NILXYZ,LDTRAN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          AUZCYL(NDBASE,NDTRAN)
C
      COMPLEX
     *          COEFFC(0:NDPERP,0:NDPERP,0:NDPERP)
      COMPLEX
     *          AUZCYL
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /BASCLI/ NBASER(NDTRAN),
     *                NBASEP(NDTRAN),
     *                NBASEM(NDTRAN),
     *                NBASPA(NDTRAN)
      COMMON
     *       /CNXNY / COEFFC
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
C         THIS SUBROUTINE PUTS THE TRANSFORMATION COEFFICIENTS
C         < NX,NY,NZ | NRHOX,NX,MX >  (FOR NILXYZ=1)
C         < NX,NY,NZ | NRHOY,NY,MY >  (FOR NILXYZ=2)
C         < NX,NY,NZ | NRHOZ,NZ,MZ >  (FOR NILXYZ=3)
C         INTO A 2-DIMENSIONAL ARRAY.
C
C=======================================================================
C
      ICOUNT=0
C
C=======================================================================
C         CALCULATION FOR THE CYLINDRICAL COORDINATE VARIANT
C=======================================================================
C
      DO NTOT=0,NMAIN
         DO NPAR=0,NTOT
            NPER=NTOT-NPAR
            DO NRHO=0,NPER
               MPAR=NPER-2*NRHO
C
               ICOUNT=ICOUNT+1
C
               NBASER(ICOUNT) = NRHO
               NBASEP(ICOUNT) = NPAR
               NBASEM(ICOUNT) = MPAR
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      LDTRAN=ICOUNT
C
      IF (LDTRAN.GT.NDTRAN) STOP ' LDTRAN.GT.NDTRAN IN TRANSC'
C
      DO I=1,LDBASE
C
         NX=NXVECT(I,1)
         NY=NYVECT(I,1)
         NZ=NZVECT(I,1)
C
         DO J=1,LDTRAN
C
            NRHO=NBASER(J)
            NPAR=NBASEP(J)
            MPAR=NBASEM(J)
C
            AUZCYL(I,J)=CMPLX(0.0D0,0.0D0)
C
            IF (NX.EQ.NPAR.AND.(NY+NZ).EQ.(2*NRHO+MPAR).AND.NILXYZ.EQ.1)
     *
     *          AUZCYL(I,J)=CONJG(COEFFC(NY,NRHO,NY+NZ))
C
            IF (NY.EQ.NPAR.AND.(NZ+NX).EQ.(2*NRHO+MPAR).AND.NILXYZ.EQ.2)
     *
     *          AUZCYL(I,J)=CONJG(COEFFC(NZ,NRHO,NZ+NX))
C
            IF (NZ.EQ.NPAR.AND.(NX+NY).EQ.(2*NRHO+MPAR).AND.NILXYZ.EQ.3)
     *
     *          AUZCYL(I,J)=CONJG(COEFFC(NX,NRHO,NX+NY))
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
C=======================================================================
C
      SUBROUTINE THOXYZ(NPERPE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          COF,UNIT_I
      COMPLEX
     *          COEFFC
C
      DIMENSION
     *          FACTRL(0:NDPERP),XNEWTN(0:NDPERP,0:NDPERP),
     *          SQFCTL(0:NDPERP),SQ2PWR(0:NDPERP)
      COMMON
     *       /THOCOF/ COEFFC(0:NDPERP,0:NDPERP,0:NDPERP)
C
C=======================================================================
C
C        THIS SUBROUTINE CALCULATES THE TRANSFORMATION BRACKETS BETWEEN
C        THE CARTESIAN AND CYLINDRICAL BASES OF THE TWO-DIMENSIONAL HAR-
C        MONIC OSCILLATOR.
C
C        THE CALCULATIONS ARE PERFORMED FOR ALL VALUES OF N-PERPENDICU-
C        LAR UP TO NPERPE. ROUTINE DOES N O T  RECALCULATE THE ELEMENTS
C        ALREADY CALCULATED. IF CALLED MORE TIMES ONLY THE NEW ELEMENTS
C        WILL BE ADDED TO THE STORAGE ARRAY.
C
C        THE RESULTS ARE STORED IN THE COMPLEX ARRAY  'COEFFC' IN COMMON
C        "CNXNY". THE INDICES  OF  THE STORAGE ARRAY HAVE THE FOLLOWING
C        MEANING:
C
C                COEFFC(NX,NRO,NPERP) = <NX,NY|NRO,LAMBDA>
C
C        WHERE:       NX+NY = 2*NRO+LAMBDA = NPERP
C        I.E.         NY=NPERP-NX;  LAMBDA=NPERP-2*NRO
C                     (NX,NRO = 0,1,2,...,NPERP)
C
C=======================================================================
C
      CALL CPUTIM('THOXYZ',1)
C
C=======================================================================
C
      IF (NPERPE.LT.     0) STOP 'THOXYZ - NPERPE .LT. 0'
      IF (NPERPE.GT.NDPERP) STOP 'THOXYZ - NPERPE .GT. NDPERP'
C
      SQ2=SQRT(2.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      FACTRL(0)=1.0D0
      SQFCTL(0)=1.0D0
      SQ2PWR(0)=1.0D0
C
      XNEWTN(0,0)=1.0D0
C
      COEFFC(0,0,0)=CMPLX(1.0D0,0.0D0)
C
      DO NPER=0,NPERPE
         DO NRO=0,NPERPE
            DO NX=0,NPERPE
               COEFFC(NX,NRO,NPER)=CMPLX(0.0D0,0.0D0)
            END DO
         END DO
      END DO
C
C=======================================================================
C         FACTRL(N)   IS THE FACTORIAL OF N
C         SQFCTL(N)   IS THE SQUARE ROOT OF THE FACTORIAL OF N
C         SQ2PWR(N)   IS THE SQUARE ROOT OF THE N-TH POWER OF 2
C         XNEWTN(N,K) IS NEWTON'S SYMBOL "N OVER K"
C=======================================================================
C
      DO I=1,NPERPE
C
         FACTRL(I)=FACTRL(I-1)*REAL(I)
         SQFCTL(I)=SQRT(FACTRL(I))
         SQ2PWR(I)=SQ2PWR(I-1)*SQ2
C
         DO K=0,I
            XNEWTN(I,K)=(FACTRL(I)/FACTRL(K))/FACTRL(I-K)
         END DO
C
      END DO
C
C=======================================================================
C                       M A I N   L O O P
C=======================================================================
C
      DO NPER=0,NPERPE
C
         DO NX=0,NPER
C
            NY=NPER-NX
C
            DO NRO=0,NPER/2
C
               NROPRI=NPER-NRO
               LAMBDA=NPER-2*NRO
C
               KMIN  = MAX(0,NX-NRO)
               KMAX  = MIN(NX,NPER-NRO)
C
               IF (KMAX .GE. KMIN) THEN
C
                   FCT=0.0
C
                   DO K=KMIN,KMAX
                      FCT=FCT+XNEWTN(NX,K)/(FACTRL(K+NRO-NX)
     *                                     *FACTRL(NRO+LAMBDA-K))
     *                                     *(-1)**K
                   END DO
C
                   FCT=FCT*(SQFCTL(NRO)*SQFCTL(NPER-NRO)*SQFCTL(NY))
     *                                 /SQFCTL(NX)/SQ2PWR(NPER)
C
                   COF=FCT*(-UNIT_I)**NY*(-1)**LAMBDA
C
                   COEFFC(NX,NRO,NPER)=COF
C
                   IF (NROPRI.NE.NRO)
     *                 COEFFC(NX,NROPRI,NPER)
     *                =CONJG(COF)*(-1)**LAMBDA
C
               END IF
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('THOXYZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE THOMAT(NMAIN,NILXYZ,IF_THO,NMAX,LDTRAN)
C=======================================================================
      USE hfodd_interface
      USE CYLTRA
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          COEFFC
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /BASCLI/ NBASER(NDTRAN),
     *                NBASEP(NDTRAN),
     *                NBASEM(NDTRAN),
     *                NBASPA(NDTRAN)
      COMMON
     *       /THOCOF/ COEFFC(0:NDPERP,0:NDPERP,0:NDPERP)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
C     THIS SUBROUTINE PUTS THE TRANSFORMATION COEFFICIENTS
C           < NX,NY,NZ | NRHOX,NX,MX >  (FOR NILXYZ=1)
C           < NX,NY,NZ | NRHOY,NY,MY >  (FOR NILXYZ=2)
C           < NX,NY,NZ | NRHOZ,NZ,MZ >  (FOR NILXYZ=3)
C     INTO A 2-DIMENSIONAL ARRAY.
C      - IF_THO=0: USED FOR THE CALCULATION OF THE NILSSON LABELS
C                  IN STANDARD HFODD CALCULATIONS. PRNCIPAL OSCILLATOR
C                  NUMBER IS 'NMAIN' (=NOSCIL)
C      - IF_THO=1: USED BOTH IN THE BASIS TRANSFORMATION FROM HFBTHO
C                  TO HFODD (SUBROUTINE CYLCAR) AND FOR THE CALCULATION
C                  OF NILSSON LABELS. PRINCIPAL OSCILLATOR NUMBER IS
C                  'NMAX'.
C                  SEE SUBROUTINE CYLCAR FOR MORE COMMENTS
C
C=======================================================================
C
      CALL CPUTIM('THOMAT',1)
C
C=======================================================================
C
      ICOUNT=0
C
C=======================================================================
C         CALCULATION FOR THE CYLINDRICAL COORDINATE VARIANT
C=======================================================================
C
      IF (IF_THO.EQ.0) THEN
C
          DO NTOT=0,NMAIN
             DO MZ=0,NTOT
                NPER=NTOT-MZ
                DO NRHO=0,NPER
                   MPAR=NPER-2*NRHO
C
                   ICOUNT=ICOUNT+1
C
                   NBASER(ICOUNT) = NRHO
                   NBASEP(ICOUNT) = MZ
                   NBASEM(ICOUNT) = MPAR
                   NBASPA(ICOUNT) = (-1)**NTOT
C
                END DO
             END DO
          END DO
C
      ELSE
C
          DO NTOT=0,NMAX
             DO MZ=0,NMAX
                NPER=NTOT-MZ
                DO NRHO=0,NPER
                   MPAR=NPER-2*NRHO
C
                                       NR=NRHO
                   IF (NRHO.GT.NPER/2) NR=NPER-NRHO
C
                   M=ABS(MPAR)
C
                   IF (validate_HFBTHO(NTOT,MZ,NR,M).EQ.1) THEN
C
                       ICOUNT=ICOUNT+1
C
                       NBASER(ICOUNT) = NRHO
                       NBASEP(ICOUNT) = MZ
                       NBASEM(ICOUNT) = MPAR
C
                   END IF
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      IF (IF_THO.EQ.1) THEN
          IF (LDTRAN.NE.NsizeHFBTHO) STOP 'ERROR LDTRAN'
          IF (LDBASE.NE.NsizeHFODD) THEN
              WRITE(6,'(''LDBASE = '',i6,'' NsizeHFODD = '',i6)')
     *                    LDBASE,NsizeHFODD
              STOP 'ERROR LDBASE'
          END IF
      END IF
C
      IF (LDTRAN.GT.NDTRAN) STOP ' LDTRAN.GT.NDTRAN IN THOMAT'
C
      IF (.NOT.ALLOCATED(AUXCYL)) ALLOCATE(AUXCYL(1:LDBASE,1:LDTRAN))
C
      DO J=1,LDTRAN
C
         NRHO=NBASER(J)
         NPAR=NBASEP(J)
         MPAR=NBASEM(J)
C
         DO I=1,LDBASE
C
            MX=NXVECT(I,1)
            MY=NYVECT(I,1)
            MZ=NZVECT(I,1)
C
            AUXCYL(I,J)=CMPLX(0.0D0,0.0D0)
C
            IF (MX.EQ.NPAR.AND.(MY+MZ).EQ.(2*NRHO+MPAR).AND.NILXYZ.EQ.1)
     *
     *          AUXCYL(I,J)=COEFFC(MY,NRHO,MY+MZ)
C
            IF (MY.EQ.NPAR.AND.(MZ+MX).EQ.(2*NRHO+MPAR).AND.NILXYZ.EQ.2)
     *
     *          AUXCYL(I,J)=COEFFC(MZ,NRHO,MZ+MX)
C
            IF (MZ.EQ.NPAR.AND.(MX+MY).EQ.(2*NRHO+MPAR).AND.NILXYZ.EQ.3)
     *
     *          AUXCYL(I,J)=COEFFC(MX,NRHO,MX+MY)
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('THOMAT',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE CYLDEN(NOSCIL,IF_THO)
C=======================================================================
      USE hfodd_interface
      USE CYLTRA
      USE MAF_PP
      USE MAF_PM
      USE MAT_PP
      USE MAT_PM
      USE MAPIDE
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *          C_UNIT,C_ZERO,PHASPI
      COMPLEX
     *          TRANSM,BAUCYL,DENS3D,CYLBAU,DENS2D
      DIMENSION
     *          IOMEGA(2*NDTRAN),IBASPA(2*NDTRAN)
      ALLOCATABLE
     *          TRANSM(:,:),BAUCYL(:,:),CYLBAU(:,:)
      ALLOCATABLE
     *          DENS3D(:,:),DENS2D(:,:)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BASCLI/ NBASER(NDTRAN),
     *                NBASEP(NDTRAN),
     *                NBASEM(NDTRAN),
     *                NBASPA(NDTRAN)
      COMMON
     *       /PARFIX/ ISIQTY
C
C=======================================================================
C
C     THIS SUBROUTINE  AXIALIZES  THE MATRIX STORED IN THE ARRAYS BIG_PP
C     AND BIG_PM, THAT IS EITHER THE PARTICLE-HOLE DENSITY OR FIELD.  IT
C     FIRST TRANSFORMS THE MATRIX FROM THE  CARTESIAN HO-SIMPLEX (HFODD)
C     BASIS TO THE CYLINDRICAL HO-SPIN (HFBTHO) BASIS,  THEN IT CUTS THE
C     MATRIX ELEMENTS NOT DIAGONAL IN OMEGA,  AND FINALLY STORES IT BACK
C     IN THE HFODD BASIS.
C
C=======================================================================
C
      CALL CPUTIM('CYLDEN',1)
C
C=======================================================================
C
      C_UNIT=CMPLX(1.0D0,0.0D0)
      C_ZERO=CMPLX(0.0D0,0.0D0)
      IALLOC=0
C
C=======================================================================
C     COMPUTING THE SIZE OF THE HFBTHO BASIS FOR ARRAY ALLOCATIONS
C=======================================================================
C
      LDTRAN=0
C
      DO NTOT=0,NOSCIL
         DO MZ=0,NTOT
            NPER=NTOT-MZ
            DO NRHO=0,NPER
               LDTRAN=LDTRAN+1
            END DO
         END DO
      END DO
C
      IF (LDTRAN.GT.NDTRAN) STOP ' LDTRAN.GT.NDTRAN IN CYLDEN'
C
C=======================================================================
C      CYLINDRICAL TO CARTESIAN BASIS TRANFORMATION MATRIX AUXCYL
C=======================================================================
C
      CALL THOXYZ(NOSCIL)
C
      NILXYZ=3
      CALL THOMAT(NOSCIL,NILXYZ,IF_THO,NOSCIL,LDTRAN)
C
C=======================================================================
C     TRANSFORMATION FROM SIMPLEX TO SPIN REPRESENTATION ADDED TO TRANSM
C=======================================================================
C
      ALLOCATE (TRANSM(1:2*LDBASE,1:2*LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINUP','CYLDEN')
C
      DO I=1,LDBASE
         TRANSM(I       ,1:LDTRAN         )=PHASPI(I,0,1,1)
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSM(I       ,LDTRAN+1:2*LDTRAN)=PHASPI(I,0,0,1)
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSM(I+LDBASE,1:LDTRAN         )=PHASPI(I,1,1,1)
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSM(I+LDBASE,LDTRAN+1:2*LDTRAN)=PHASPI(I,1,0,1)
     *                                     *AUXCYL(I,1:LDTRAN)
      END DO
C
C=======================================================================
C     GATHER THE MATRIX (P-H DENSITY OR FIELD) IN DENS3D
C=======================================================================
C
      ALLOCATE (DENS3D(1:2*LDBASE,1:2*LDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DENS3D','CYLDEN')
C
      IF (.NOT. ALLOCATED(BIG_PP)) STOP 'Error in CYLDEN (1)'
C
      DENS3D(1:LDBASE         ,1:LDBASE         )=
     *                                    BIG_PP(1:LDBASE,1:LDBASE,0)
      DENS3D(LDBASE+1:2*LDBASE,LDBASE+1:2*LDBASE)=
     *                                    BIG_PP(1:LDBASE,1:LDBASE,1)
C
      IF (ALLOCATED(BIG_PM)) THEN
C
          DENS3D(1:LDBASE,LDBASE+1:2*LDBASE)=
     *                                   BIG_PM(1:LDBASE,1:LDBASE,0)
          DENS3D(LDBASE+1:2*LDBASE,1:LDBASE)=
     *                                   BIG_PM(1:LDBASE,1:LDBASE,1)
      ELSE
         DENS3D(1:LDBASE,LDBASE+1:2*LDBASE) = C_ZERO
         DENS3D(LDBASE+1:2*LDBASE,1:LDBASE) = C_ZERO
C
      END IF
C
C=======================================================================
C     CALCULATING OMEGA AND PARITY FOR SPIN UP AND SPIN DOWN
C=======================================================================
C
      DO I=1,LDTRAN
         IOMEGA(I)=2*NBASEM(I)-1
         IOMEGA(I+LDTRAN)=2*NBASEM(I)+1
         IBASPA(I)=NBASPA(I)
         IBASPA(I+LDTRAN)=NBASPA(I)
      END DO
C
C=======================================================================
C     TRANSFORM THE MATRIX TO THE HFBTHO BASIS DENS3D->DENS2D
C=======================================================================
C
      ALLOCATE (BAUCYL(1:2*LDBASE,1:2*LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('BAUCYL','CYLDEN')
      ALLOCATE (DENS2D(1:2*LDTRAN,1:2*LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DENS2D','CYLDEN')
C
      CALL ZGEMM('N','N',2*LDBASE,2*LDTRAN,2*LDBASE,C_UNIT,DENS3D,
     *            2*LDBASE,TRANSM,2*LDBASE,C_ZERO,BAUCYL,2*LDBASE)
C
      DENS2D(:,:)=C_ZERO
C
      DO J=1,2*LDTRAN
         DO I=1,2*LDTRAN
C
            IF (IOMEGA(I).EQ.IOMEGA(J).AND.
     *         (IBASPA(I).EQ.IBASPA(J).AND.ISIQTY.EQ.1.OR.
     *                                     ISIQTY.EQ.0)) THEN
C
                DO K=1,2*LDBASE
C
                  DENS2D(I,J)=DENS2D(I,J)+CONJG(TRANSM(K,I))*BAUCYL(K,J)
C
                END DO
C
            END IF
C
         END DO
      END DO
C
      DEALLOCATE(BAUCYL)
C
C=======================================================================
C     TRANSFORM BACK THE MATRIX TO THE HFODD BASIS DENS2D->DENS3D
C=======================================================================
C
      ALLOCATE (CYLBAU(1:2*LDTRAN,1:2*LDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CYLBAU','CYLDEN')
C
      CYLBAU(:,:)=C_ZERO
C
      DO I=1,2*LDTRAN
         DO J=1,2*LDTRAN
C
            IF (IOMEGA(I).EQ.IOMEGA(J).AND.
     *         (IBASPA(I).EQ.IBASPA(J).AND.ISIQTY.EQ.1.OR.
     *                                     ISIQTY.EQ.0)) THEN
C
                DO K=1,2*LDBASE
C
                  CYLBAU(I,K)=CYLBAU(I,K)+DENS2D(I,J)*CONJG(TRANSM(K,J))
C
                END DO
C
            END IF
C
         END DO
      END DO
C
      CALL ZGEMM('N','N',2*LDBASE,2*LDBASE,2*LDTRAN,C_UNIT,TRANSM,
     *            2*LDBASE,CYLBAU,2*LDTRAN,C_ZERO,DENS3D,2*LDBASE)
C
C=======================================================================
C     REPLACE THE MATRIX (P-H DENSITY OR FIELD) BY THE AXIALIZED ONE
C=======================================================================
C
      BIG_PP(1:LDBASE,1:LDBASE,0)=
     *                    DENS3D(1:LDBASE,1:LDBASE)
      BIG_PP(1:LDBASE,1:LDBASE,1)=
     *                    DENS3D(LDBASE+1:2*LDBASE,LDBASE+1:2*LDBASE)
C
      IF (ALLOCATED(BIG_PM)) THEN
C
          BIG_PM(1:LDBASE,1:LDBASE,0)=
     *                             DENS3D(1:LDBASE,LDBASE+1:2*LDBASE)
          BIG_PM(1:LDBASE,1:LDBASE,1)=
     *                             DENS3D(LDBASE+1:2*LDBASE,1:LDBASE)
C
      END IF
C
C=======================================================================
      DEALLOCATE(TRANSM,CYLBAU,DENS3D,DENS2D)
C=======================================================================
C
      CALL CPUTIM('CYLDEN',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE CYLPAI(NOSCIL,IF_THO,IPAIAX)
C=======================================================================
      USE hfodd_interface
      USE CYLTRA
      USE KAP_PP
      USE KAP_PM
      USE PAIDEL
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *          C_UNIT,C_ZERO,PHASPI
      COMPLEX
     *          TRANSM,TRANSP,BAUCYL,DENS3D,CYLBAU,DENS2D
      DIMENSION
     *          IOMEGA(2*NDTRAN),IBASPA(2*NDTRAN)
      ALLOCATABLE
     *          TRANSM(:,:),TRANSP(:,:),BAUCYL(:,:),CYLBAU(:,:)
      ALLOCATABLE
     *          DENS3D(:,:),DENS2D(:,:)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BASCLI/ NBASER(NDTRAN),
     *                NBASEP(NDTRAN),
     *                NBASEM(NDTRAN),
     *                NBASPA(NDTRAN)
      COMMON
     *       /PARFIX/ ISIQTY
C
C=======================================================================
C
C     THIS SUBROUTINE  AXIALIZES  THE MATRIX STORED IN THE PAIRIG ARRAYS
C     THAT IS, EITHER THE PARTICLE-PARTICLE PAIRING TENSOR OR FIELD.  IT
C     FIRST TRANSFORMS THE MATRIX FROM THE  CARTESIAN HO-SIMPLEX (HFODD)
C     BASIS TO THE CYLINDRICAL HO-SPIN (HFBTHO) BASIS,  THEN IT CUTS THE
C     MATRIX ELEMENTS NOT ANTI-DIAGONAL IN OMEGA,  AND FINALLY STORES IT
C     BACK IN THE HFODD BASIS.
C
C=======================================================================
C
      CALL CPUTIM('CYLPAI',1)
C
C=======================================================================
C
      C_UNIT=CMPLX(1.0D0,0.0D0)
      C_ZERO=CMPLX(0.0D0,0.0D0)
      IALLOC=0
C
C=======================================================================
C     COMPUTING THE SIZE OF THE HFBTHO BASIS FOR ARRAY ALLOCATIONS
C=======================================================================
C
      LDTRAN=0
C
      DO NTOT=0,NOSCIL
         DO MZ=0,NTOT
            NPER=NTOT-MZ
            DO NRHO=0,NPER
               LDTRAN=LDTRAN+1
            END DO
         END DO
      END DO
C
      IF (LDTRAN.GT.NDTRAN) STOP ' LDTRAN.GT.NDTRAN IN CYLPAI'
C
C=======================================================================
C      CYLINDRICAL TO CARTESIAN BASIS TRANFORMATION MATRIX AUXCYL
C=======================================================================
C
      CALL THOXYZ(NOSCIL)
C
      NILXYZ=3
      CALL THOMAT(NOSCIL,NILXYZ,IF_THO,NOSCIL,LDTRAN)
C
C=======================================================================
C     TRANSFORMATION FROM SIMPLEX TO SPIN REPRESENTATION ADDED TO TRANSM
C=======================================================================
C
      ALLOCATE (TRANSM(1:2*LDBASE,1:2*LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('TRANSM','CYLPAI')
      ALLOCATE (TRANSP(1:2*LDBASE,1:2*LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('TRANSP','CYLPAI')
C
      DO I=1,LDBASE
         TRANSM(I       ,1:LDTRAN         )=CONJG(PHASPI(I,0,1,1))
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSM(I       ,LDTRAN+1:2*LDTRAN)=CONJG(PHASPI(I,0,0,1))
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSM(I+LDBASE,1:LDTRAN         )=CONJG(PHASPI(I,1,1,1))
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSM(I+LDBASE,LDTRAN+1:2*LDTRAN)=CONJG(PHASPI(I,1,0,1))
     *                                     *AUXCYL(I,1:LDTRAN)
C
         TRANSP(I       ,1:LDTRAN         )=PHASPI(I,1,0,1)
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSP(I       ,LDTRAN+1:2*LDTRAN)=PHASPI(I,1,1,1)
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSP(I+LDBASE,1:LDTRAN         )=PHASPI(I,0,0,1)
     *                                     *AUXCYL(I,1:LDTRAN)
         TRANSP(I+LDBASE,LDTRAN+1:2*LDTRAN)=PHASPI(I,0,1,1)
     *                                     *AUXCYL(I,1:LDTRAN)
C
      END DO
C
C=======================================================================
C     GATHER THE MATRIX (P-P DENSITY OR FIELD) IN DENS3D
C=======================================================================
C
      ALLOCATE (DENS3D(1:2*LDBASE,1:2*LDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DENS3D','CYLPAI')
C
      IF (.NOT.ALLOCATED(PAI_PM).AND.
     *    .NOT.ALLOCATED(HAMIDE)) STOP 'Error in CYLPAI (1)'
C
      !SUBROUTINE COMES FROM PAIMAC
        IF (IPAIAX.EQ.0) THEN
         DENS3D(1:LDBASE,1:LDBASE) = PAI_PM(1:LDBASE,1:LDBASE,0)
         DENS3D(LDBASE+1:2*LDBASE,LDBASE+1:2*LDBASE) =
     *    PAI_PM(1:LDBASE,1:LDBASE,1)
         IF (ALLOCATED(PAI_PP)) THEN
         DENS3D(1:LDBASE,LDBASE+1:2*LDBASE)=PAI_PP(1:LDBASE,1:LDBASE,0)
         DENS3D(LDBASE+1:2*LDBASE,1:LDBASE)=PAI_PP(1:LDBASE,1:LDBASE,1)
         ELSE
         DENS3D(1:LDBASE,LDBASE+1:2*LDBASE)=C_ZERO
         DENS3D(LDBASE+1:2*LDBASE,1:LDBASE)=C_ZERO
         END IF
      !SUBROUTINE COMES FROM INTEGD
        ELSE
         DENS3D(1:LDBASE,1:LDBASE)         =HAMIDE(1:LDBASE,1:LDBASE,1)
         DENS3D(LDBASE+1:2*LDBASE,1:LDBASE)=HAMIDE(1:LDBASE,1:LDBASE,0)
         IF (ALLOCATED(HAM2DE)) THEN
        !PRINT *, 'HELLO HAM2DE'
          DENS3D(1:LDBASE,LDBASE+1:2*LDBASE) =
     *     -HAM2DE(1:LDBASE,1:LDBASE,0)
          DENS3D(LDBASE+1:2*LDBASE,LDBASE+1:2*LDBASE) =
     *      HAM2DE(1:LDBASE,1:LDBASE,1)
         ELSE
          DENS3D(1:LDBASE,LDBASE+1:2*LDBASE) =
     *     -HAMIDE(1:LDBASE,1:LDBASE,0)
          DENS3D(LDBASE+1:2*LDBASE,LDBASE+1:2*LDBASE) =
     *      HAMIDE(1:LDBASE,1:LDBASE,1)
         ENDIF
        ENDIF
C
C=======================================================================
C     CALCULATING OMEGA AND PARITY FOR SPIN UP AND SPIN DOWN
C=======================================================================
C
      DO I=1,LDTRAN
         IOMEGA(I)=2*NBASEM(I)-1
         IOMEGA(I+LDTRAN)=2*NBASEM(I)+1
         IBASPA(I)=NBASPA(I)
         IBASPA(I+LDTRAN)=NBASPA(I)
      END DO
C
C=======================================================================
C     TRANSFORM THE MATRIX TO THE HFBTHO BASIS DENS3D->DENS2D
C=======================================================================
C
      ALLOCATE (BAUCYL(1:2*LDBASE,1:2*LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('BAUCYL','CYLPAI')
      ALLOCATE (DENS2D(1:2*LDTRAN,1:2*LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DENS2D','CYLPAI')
C
      CALL ZGEMM('N','N',2*LDBASE,2*LDTRAN,2*LDBASE,C_UNIT,DENS3D,
     *            2*LDBASE,TRANSM,2*LDBASE,C_ZERO,BAUCYL,2*LDBASE)
C
      DENS2D(:,:)=C_ZERO
C
      DO J=1,2*LDTRAN
         DO I=1,2*LDTRAN
C
            IF (IOMEGA(I).EQ.-IOMEGA(J).AND.
     *         (IBASPA(I).EQ. IBASPA(J).AND.ISIQTY.EQ.1.OR.
     *                                      ISIQTY.EQ.0)) THEN
C
                DO K=1,2*LDBASE
C
                  DENS2D(I,J)=DENS2D(I,J)+CONJG(TRANSP(K,I))*BAUCYL(K,J)
C
                END DO
C
            END IF
C
         END DO
      END DO
C
      DEALLOCATE(BAUCYL)
C
C=======================================================================
C     TRANSFORM BACK THE MATRIX TO THE HFODD BASIS DENS2D->DENS3D
C=======================================================================
C
      ALLOCATE (CYLBAU(1:2*LDTRAN,1:2*LDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CYLBAU','CYLPAI')
C
      CYLBAU(:,:)=C_ZERO
C
      DO I=1,2*LDTRAN
         DO J=1,2*LDTRAN
C
            IF (IOMEGA(I).EQ.-IOMEGA(J).AND.
     *         (IBASPA(I).EQ. IBASPA(J).AND.ISIQTY.EQ.1.OR.
     *                                      ISIQTY.EQ.0)) THEN
C
                DO K=1,2*LDBASE
C
                  CYLBAU(I,K)=CYLBAU(I,K)+DENS2D(I,J)*CONJG(TRANSP(K,J))
C
                END DO
C
            END IF
C
         END DO
      END DO
C
      CALL ZGEMM('N','N',2*LDBASE,2*LDBASE,2*LDTRAN,C_UNIT,TRANSM,
     *            2*LDBASE,CYLBAU,2*LDTRAN,C_ZERO,DENS3D,2*LDBASE)
C
C=======================================================================
C     REPLACE THE MATRIX (P-P DENSITY OR FIELD) BY THE AXIALIZED ONE
C=======================================================================
C
      IF(IPAIAX.EQ.0) THEN
        PAI_PM(1:LDBASE,1:LDBASE,0) = DENS3D(1:LDBASE,1:LDBASE)
        PAI_PM(1:LDBASE,1:LDBASE,1) =
     *   DENS3D(LDBASE+1:2*LDBASE,LDBASE+1:2*LDBASE)
        IF (ALLOCATED(PAI_PP)) THEN
         PAI_PP(1:LDBASE,1:LDBASE,0)=DENS3D(1:LDBASE,LDBASE+1:2*LDBASE)
         PAI_PP(1:LDBASE,1:LDBASE,1)=DENS3D(LDBASE+1:2*LDBASE,1:LDBASE)
        END IF
      ELSE
        HAMIDE(1:LDBASE,1:LDBASE,1) =DENS3D(1:LDBASE,1:LDBASE)
        HAMIDE(1:LDBASE,1:LDBASE,0) =DENS3D(LDBASE+1:2*LDBASE,1:LDBASE)
        IF (ALLOCATED(HAM2DE)) THEN
         HAM2DE(1:LDBASE,1:LDBASE,0)=-DENS3D(1:LDBASE,LDBASE+1:2*LDBASE)
         HAM2DE(1:LDBASE,1:LDBASE,1)=
     *   DENS3D(LDBASE+1:2*LDBASE,LDBASE+1:2*LDBASE)
        END IF
      END IF
C
C=======================================================================
      DEALLOCATE(TRANSM,TRANSP,CYLBAU,DENS3D,DENS2D)
C=======================================================================
C
      CALL CPUTIM('CYLPAI',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE CYLCAR(NOSCIL,ISIMPY,IF_THO)
C=======================================================================
      USE hfodd_interface
      USE CYLTRA
      USE MAF_PP
      USE MAF_PM
      USE MAPIDE
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *          C_UNIT,C_ZERO,PHASPI
C
C=======================================================================
      COMPLEX, DIMENSION(:,:), ALLOCATABLE ::
     *                         TRANSM,TRAINV,SPINDW,AUXMAT
C=======================================================================
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
C     THIS SUBROUTINE PERFORMS THE  'HFBTHO'  TO  'HFODD'  BASIS
C     TRANSFORMATION BY INVOKING FIRST A STANDARD CYLINDRICAL TO
C     CARTESIAN BASIS TRANSFORMATION FOLLOWED BY A UNITARY PHASE
C     TRANSFORMATION.
C
C     THE REQUIRED INPUTS FROM HFBTHO  ARE PASSED THROUGH MODULE
C     hfodd_interface AND ARE:
C      - NmxTHO         : PRINCIPAL QUANTUM NUMBER N.
C      - NsizeHFBTHO    : ACTUAL NUMBER OF STATES IN HFBTHO BASIS.
C      - validate_HFBTHO: 4D-ARRAY FLAGGING IF THE STATE CHARACTE-
C                         RIZED BY QUANTUM NUMBERS N,  nz, nr AND
C                         Lambda IS PART OF HFBTHO BASIS.
C      - HF_PHN,HF_PHP  : THE MATRICES OF THE HF MEAN-FIELD 'h' IN
C                         HFBTHO (NEUTRONS AND PROTONS).
C      - HF_PPN,HF_PPP  : THE MATRICES OF THE PAIRING FIELD 'delta'
C                         IN HFBTHO (NEUTRONS AND PROTONS).
C
C NOTA BENE: HFBTHO BASIS STATE COUNTING CONVENTIONS ARE DIFFERENT
C            FROM HFODD. IN HFODD ALL LOOPS OVER  NX, NY AND NZ GO
C            FROM 0 TO NOSCIL. IN  HFBTHO, ALL LOOPS CORRESPOND TO
C            A MAXIMUM QUANTUM NUMBER N = 50, EXCEPT NZ, WHICH CAN
C            NOT EXCEED NOSCIL. IN BOTH CODES THE BASIS CUT-OFF IS
C            ENERGY BASED, I.E., E(NX,NY,NZ) < ENECUT (HFODD)  AND
C            E(NR,NZ,LAMBDA) < ENECUT (HFBTHO).  THESE   DIFFERENT
C            CONVENTIONS DO NOT MATTER FOR   SPHERICAL  BASES. FOR
C            DEFORMED  BASES, THEY WOULD LEAD TO  DIFFERENT  STATE
C            COMPOSITION IF  SPECIAL  MEASURES WERE NOT TAKEN.  IN
C            THE CURRENT IMPLEMENTATION, THE 4D-ARRAY  indexHFBTHO
C            INDICATES IF A STATE WITH  GIVEN  CYLINDRICAL QUANTUM
C            NUMBERS IS PART OF HFBTHO BASIS.
C
C=======================================================================
C
      CALL CPUTIM('CYLCAR',1)
C
C=======================================================================
C      COMPUTING THE SIZE OF MATRICES FOR ARRAY ALLOCATIONS
C=======================================================================
C
      ICOUNT=0
C
      IF (IF_THO.EQ.0) THEN
C
          DO NTOT=0,NOSCIL
             DO MZ=0,NTOT
                NPER=NTOT-MZ
                DO NRHO=0,NPER
                   ICOUNT=ICOUNT+1
                END DO
             END DO
          END DO
C
      ELSE
C
          DO NTOT=0,NmxTHO
             DO MZ=0,NOSCIL
                NPER=NTOT-MZ
                DO NRHO=0,NPER
                   MPAR=NPER-2*NRHO
C
                                       NR=NRHO
                   IF (NRHO.GT.NPER/2) NR=NPER-NRHO
C
                   M=ABS(MPAR)
C
                   IF (validate_HFBTHO(NTOT,MZ,NR,M).EQ.1)
     *                 ICOUNT=ICOUNT+1
C
                END DO
             END DO
          END DO
C
      END IF
C
      LDTRAN=ICOUNT
C
C=======================================================================
C      CYLINDRICAL TO CARTESIAN  BASIS  TRANFORMATION. MATRIX OF THE
C      TRANSFORMATION IS STORED IN TRANSM, THE MATRIX OF THE INVERSE
C      TRANFORMATION (HERMITIAN CONJUGATE) IN TRAINV.
C=======================================================================
C
      IALLOC=0
C
      CALL THOXYZ(NmxTHO)
C
      NILXYZ=3
      CALL THOMAT(NOSCIL,NILXYZ,IF_THO,NmxTHO,LDTRAN)
C
      ALLOCATE (TRANSM(1:LDBASE,1:LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINUP','CYLCAR')
      ALLOCATE (TRAINV(1:LDTRAN,1:LDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WASPIN','CYLCAR')
C
      TRANSM(:,:)=AUXCYL(:,:)        ! cartesian -> cylindrical
C
      DO J=1,LDBASE
         DO I=1,LDTRAN
            TRAINV(I,J)=CONJG(AUXCYL(J,I)) ! cylindrical -> cartesian
         END DO
      END DO
C
      DEALLOCATE(AUXCYL)
C
C=======================================================================
C
      IF (.NOT. ALLOCATED(HF_PHN)) STOP 'Error in CYLCAR (1)'
      IF (.NOT. ALLOCATED(HF_PHP)) STOP 'Error in CYLCAR (2)'
      IF (.NOT. ALLOCATED(HF_PPN)) STOP 'Error in CYLCAR (3)'
      IF (.NOT. ALLOCATED(HF_PPP)) STOP 'Error in CYLCAR (4)'
C
C=======================================================================
C      TRANSFORMING THE MEAN-FIELD AND PAIRING FIELD MATRICES FROM
C      HFBTHO INTO CARTESIAN COORDINATES FOR EACH SPIN PROJECTION.
C=======================================================================
C
      ALLOCATE (SPINDW(1:LDTRAN,1:LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINDW','CYLCAR')
      ALLOCATE (AUXMAT(1:LDTRAN,1:LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXMAT','CYLCAR')
C
      C_UNIT=CMPLX(1.0D0,0.0D0)
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      DO MS_KET=0,NDSPIN
         DO MS_BRA=0,NDSPIN
C
C            Mean-field for neutrons
C
            AUXMAT = HF_PHN(1:LDTRAN,1:LDTRAN,MS_BRA,MS_KET)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDTRAN,
     *                         C_UNIT,AUXMAT,LDTRAN,
     *                         TRAINV,LDTRAN,C_ZERO,SPINDW,LDTRAN)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDTRAN,
     *                         C_UNIT,TRANSM,LDTRAN,
     *                         SPINDW,LDTRAN,C_ZERO,AUXMAT,LDTRAN)
C
            HF_PHN(1:LDTRAN,1:LDTRAN,MS_BRA,MS_KET) = AUXMAT
C
C            Mean-field for protons
C
            AUXMAT = HF_PHP(1:LDTRAN,1:LDTRAN,MS_BRA,MS_KET)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDTRAN,
     *                         C_UNIT,AUXMAT,LDTRAN,
     *                         TRAINV,LDTRAN,C_ZERO,SPINDW,LDTRAN)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDTRAN,
     *                         C_UNIT,TRANSM,LDTRAN,
     *                         SPINDW,LDTRAN,C_ZERO,AUXMAT,LDTRAN)
C
            HF_PHP(1:LDTRAN,1:LDTRAN,MS_BRA,MS_KET) = AUXMAT
C
C            Pairing field for neutrons
C
            AUXMAT = HF_PPN(1:LDTRAN,1:LDTRAN,MS_BRA,MS_KET)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDTRAN,
     *                         C_UNIT,AUXMAT,LDTRAN,
     *                         TRAINV,LDTRAN,C_ZERO,SPINDW,LDTRAN)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDTRAN,
     *                         C_UNIT,TRANSM,LDTRAN,
     *                         SPINDW,LDTRAN,C_ZERO,AUXMAT,LDTRAN)
C
            HF_PPN(1:LDTRAN,1:LDTRAN,MS_BRA,MS_KET) = AUXMAT
C
C            Pairing field for protons
C
            AUXMAT = HF_PPP(1:LDTRAN,1:LDTRAN,MS_BRA,MS_KET)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDTRAN,
     *                         C_UNIT,AUXMAT,LDTRAN,
     *                         TRAINV,LDTRAN,C_ZERO,SPINDW,LDTRAN)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDTRAN,
     *                         C_UNIT,TRANSM,LDTRAN,
     *                         SPINDW,LDTRAN,C_ZERO,AUXMAT,LDTRAN)
C
            HF_PPP(1:LDTRAN,1:LDTRAN,MS_BRA,MS_KET) = AUXMAT
C
         END DO
      END DO
C
      DEALLOCATE(TRANSM,TRAINV,SPINDW,AUXMAT)
C
C=======================================================================
C      COMBINING  SPIN-UP AND  SPIN-DOWN COMPONENTS OF THE MATRIX
C      ELEMENTS OF THE  MEAN-FIELD AND  PAIRING FIELD TO OBEY THE
C      PHASE CONVENTION OF HFODD (T-BASIS, SEE SUBROUTINE PHASES)
C=======================================================================
C
      IF (.NOT.ALLOCATED(FIL_PP)) THEN
          ALLOCATE (FIL_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FIL_PP','CYLCAR')
      END IF
      IF (.NOT.ALLOCATED(FIL_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (FIL_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FIL_PM','CYLCAR')
      END IF
      IF (.NOT.ALLOCATED(FIPIDE)) THEN
          ALLOCATE (FIPIDE(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FIPIDE','CYLCAR')
      END IF
C
      DO J_BASE=1,LDBASE
         DO I_BASE=1,LDBASE
C
C            Mean-field for neutrons and protons (t+ block)
C
            FIL_PP(I_BASE,J_BASE,0,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *HF_PHN(I_BASE,J_BASE,1,1)
     *                         *PHASPI(J_BASE,0,1,1)
     *     +
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *HF_PHN(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     +
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *HF_PHN(I_BASE,J_BASE,1,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     +
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *HF_PHN(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,1,1)
C
            FIL_PP(I_BASE,J_BASE,0,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *HF_PHP(I_BASE,J_BASE,1,1)
     *                         *PHASPI(J_BASE,0,1,1)
     *     +
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *HF_PHP(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     +
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *HF_PHP(I_BASE,J_BASE,1,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     +
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *HF_PHP(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,1,1)
C
C            Pairing field for neutrons and protons (t+ block)
C
            FIPIDE(I_BASE,J_BASE,0,0)=
     *
     *     -       CONJG(PHASPI(I_BASE,0,1,1))
     *                  *HF_PPN(I_BASE,J_BASE,1,1)
     *                         *PHASPI(J_BASE,0,1,1)
     *     -
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *HF_PPN(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     -
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *HF_PPN(I_BASE,J_BASE,1,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     -
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *HF_PPN(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,1,1)
C
            FIPIDE(I_BASE,J_BASE,0,1)=
     *
     *     -       CONJG(PHASPI(I_BASE,0,1,1))
     *                  *HF_PPP(I_BASE,J_BASE,1,1)
     *                         *PHASPI(J_BASE,0,1,1)
     *     -
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *HF_PPP(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     -
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *HF_PPP(I_BASE,J_BASE,1,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     -
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *HF_PPP(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,1,1)
C
         END DO
      END DO
C
      IF (ALLOCATED(HF_PHN)) DEALLOCATE(HF_PHN)
      IF (ALLOCATED(HF_PHP)) DEALLOCATE(HF_PHP)
      IF (ALLOCATED(HF_PPN)) DEALLOCATE(HF_PPN)
      IF (ALLOCATED(HF_PPP)) DEALLOCATE(HF_PPP)
C
C      Time-reversal symmetry is conserved by construction in HFBTHO
C
      DO J_BASE=1,LDBASE
         DO I_BASE=1,LDBASE
C
            FIL_PP(I_BASE,J_BASE,1,0)=CONJG(FIL_PP(I_BASE,J_BASE,0,0))
            FIL_PP(I_BASE,J_BASE,1,1)=CONJG(FIL_PP(I_BASE,J_BASE,0,1))
C
            FIPIDE(I_BASE,J_BASE,1,0)=CMPLX(0.0D0,0.0D0)
            FIPIDE(I_BASE,J_BASE,1,1)=CMPLX(0.0D0,0.0D0)
C
            IF (ISIMPY .NE. 1) THEN
C
                FIL_PM(I_BASE,J_BASE,1,0)=CMPLX(0.0D0,0.0D0)
                FIL_PM(I_BASE,J_BASE,0,0)=CMPLX(0.0D0,0.0D0)
C
                FIL_PM(I_BASE,J_BASE,1,1)=CMPLX(0.0D0,0.0D0)
                FIL_PM(I_BASE,J_BASE,0,1)=CMPLX(0.0D0,0.0D0)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('CYLCAR',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CARCYL(NOSCIL,IF_THO,BZ_THO,BP_THO,Parity,ITWCEN)
C=======================================================================
      USE hfodd_interface
      USE CYLTRA
      USE MAF_PP
      USE MAPIDE
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      LOGICAL
     *          Parity
      COMPLEX
     *          C_UNIT,C_ZERO,PHASPI
C
C=======================================================================
      COMPLEX, DIMENSION(:,:), ALLOCATABLE ::
     *                         TRANSM,TRAINV,SPINDW,AUXMAT
C=======================================================================
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /BELIMI/ ELIMIT(1:NDTWCE)
C
C=======================================================================
C
C     THIS SUBROUTINE PERFORMS THE  'HFODD'  TO  'HFBTHO'  BASIS
C     TRANSFORMATION BY INVOKING A PHASE TRANSFORMATION FOLLOWED
C     BY THE CARTESIAN TO CYLINDRICAL COORDINATE TRANSFORMATION.
C
C     THE ONLY REQUIRED INPUTS ARE THE MATRICES OF THE MEAN- AND
C     PAIRING FIELDS FOR PROTONS  AND NEUTRONS, WHICH ARE STORED
C     IN ARRAYS FIL_PP, FIL_PM  AND FIPIDE. UPON EXITING, ARRAYS
C     HF_PHN,  HF_PHP,  HF_PPN,  HF_PPP  CONTAIN  ALL  FIELDS IN
C     CYLINDRICAL COORDINATES (WITH HFODD CONVENTION, SEE BELOW),
C     STRIPPED OF ALL SUPERFLUOUS PHASES.
C
C NOTA BENE: HFBTHO BASIS STATE COUNTING CONVENTIONS ARE DIFFERENT
C            FROM HFODD. IN HFODD ALL LOOPS OVER  NX, NY AND NZ GO
C            FROM 0 TO NOSCIL. IN  HFBTHO, ALL LOOPS CORRESPOND TO
C            A MAXIMUM QUANTUM NUMBER N = 50, EXCEPT NZ, WHICH CAN
C            NOT EXCEED NOSCIL. IN BOTH CODES THE BASIS CUT-OFF IS
C            ENERGY BASED, I.E., E(NX,NY,NZ) < ENECUT (HFODD)  AND
C            E(NR,NZ,LAMBDA) < ENECUT (HFBTHO).  THESE   DIFFERENT
C            CONVENTIONS DO NOT MATTER FOR   SPHERICAL  BASES. FOR
C            DEFORMED  BASES, THEY WOULD LEAD TO  DIFFERENT  STATE
C            COMPOSITION IF  SPECIAL  MEASURES WERE NOT TAKEN.  IN
C            THE CURRENT IMPLEMENTATION, THE 4D-ARRAY  indexHFBTHO
C            INDICATES IF A STATE WITH  GIVEN  CYLINDRICAL QUANTUM
C            NUMBERS IS PART OF HFBTHO BASIS.
C
C=======================================================================
C
      CALL CPUTIM('CARCYL',1)
C
C=======================================================================
C
      IF (.NOT.ALLOCATED(FIL_PP)) STOP 'Error in CARCYL (1)'
      IF (.NOT.ALLOCATED(FIPIDE)) STOP 'Error in CARCYL (2)'
C
C=======================================================================
C      COMBINING SIMPLEX COMPONENTS OF THE MATRIX ELEMENTS OF THE
C      MEAN-FIELD AND PAIRING FIELD TO EXTRACT MATRIX ELEMENTS IN
C      VARIOUS SPIN BLOCKS (ms, ms')
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
C
      IF (.NOT.ALLOCATED(HF_PHN)) THEN
          ALLOCATE(HF_PHN(1:LDBASE,1:LDBASE,0:NDSPIN,0:NDSPIN),
     *                                            STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HF_PHN','CARCYL')
      END IF
      IF (.NOT.ALLOCATED(HF_PHP)) THEN
          ALLOCATE(HF_PHP(1:LDBASE,1:LDBASE,0:NDSPIN,0:NDSPIN),
     *                                            STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HF_PHP','CARCYL')
      END IF
      IF (.NOT.ALLOCATED(HF_PPN)) THEN
          ALLOCATE(HF_PPN(1:LDBASE,1:LDBASE,0:NDSPIN,0:NDSPIN),
     *                                            STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HF_PPN','CARCYL')
      END IF
      IF (.NOT.ALLOCATED(HF_PPP)) THEN
          ALLOCATE(HF_PPP(1:LDBASE,1:LDBASE,0:NDSPIN,0:NDSPIN),
     *                                            STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HF_PPP','CARCYL')
      END IF
C
C=======================================================================
C         CALCULATING THE PHASES ACCORDING TO SOME INGENIOUS CONVENTION
C=======================================================================
C
      CALL PHASES(ITWCEN)
C
C=======================================================================
C
      DO J_BASE=1,LDBASE
         DO I_BASE=1,LDBASE
C
C                             MEAN-FIELD
C
C            Mean-field for neutrons and protons (spin-up/spin-up block)
C
            HF_PHN(I_BASE,J_BASE,1,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *FIL_PP(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,1,1)
     *     +
     *             CONJG(PHASPI(I_BASE,1,1,1))
     *                  *FIL_PP(I_BASE,J_BASE,1,0)
     *                         *PHASPI(J_BASE,1,1,1)
C
            HF_PHP(I_BASE,J_BASE,1,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *FIL_PP(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,1,1)
     *     +
     *             CONJG(PHASPI(I_BASE,1,1,1))
     *                  *FIL_PP(I_BASE,J_BASE,1,1)
     *                         *PHASPI(J_BASE,1,1,1)
C
C            Mean-field for neutrons and protons (spin-down/spin-down block)
C
            HF_PHN(I_BASE,J_BASE,0,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *FIL_PP(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     +
     *             CONJG(PHASPI(I_BASE,1,0,1))
     *                  *FIL_PP(I_BASE,J_BASE,1,0)
     *                         *PHASPI(J_BASE,1,0,1)
C
            HF_PHP(I_BASE,J_BASE,0,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *FIL_PP(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,0,1)
     *     +
     *             CONJG(PHASPI(I_BASE,1,0,1))
     *                  *FIL_PP(I_BASE,J_BASE,1,1)
     *                         *PHASPI(J_BASE,1,0,1)
C
C            Mean-field for neutrons and protons (spin-up/spin-down block)
C
            HF_PHN(I_BASE,J_BASE,1,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *FIL_PP(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,0,1)
     *     +
     *             CONJG(PHASPI(I_BASE,1,1,1))
     *                  *FIL_PP(I_BASE,J_BASE,1,0)
     *                         *PHASPI(J_BASE,1,0,1)
C
            HF_PHP(I_BASE,J_BASE,1,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *FIL_PP(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,0,1)
     *     +
     *             CONJG(PHASPI(I_BASE,1,1,1))
     *                  *FIL_PP(I_BASE,J_BASE,1,1)
     *                         *PHASPI(J_BASE,1,0,1)
C
C            Mean-field for neutrons and protons (spin-down/spin-up block)
C
            HF_PHN(I_BASE,J_BASE,0,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *FIL_PP(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,1,1)
     *     +
     *             CONJG(PHASPI(I_BASE,1,0,1))
     *                  *FIL_PP(I_BASE,J_BASE,1,0)
     *                         *PHASPI(J_BASE,1,1,1)
C
            HF_PHP(I_BASE,J_BASE,0,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *FIL_PP(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,1,1)
     *     +
     *             CONJG(PHASPI(I_BASE,1,0,1))
     *                  *FIL_PP(I_BASE,J_BASE,1,1)
     *                         *PHASPI(J_BASE,1,1,1)
C
C                             PAIRING-FIELD
C
C            Pairing field for neutrons and protons (spin-up/spin-up block)
C
            HF_PPN(I_BASE,J_BASE,1,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *FIPIDE(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,1,1)
C
            HF_PPP(I_BASE,J_BASE,1,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *FIPIDE(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,1,1)
C
C            Pairing field for neutrons and protons (spin-down/spin-down block)
C
            HF_PPN(I_BASE,J_BASE,0,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *FIPIDE(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,0,1)
C
            HF_PPP(I_BASE,J_BASE,0,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *FIPIDE(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,0,1)
C
C            Pairing field for neutrons and protons (spin-up/spin-down block)
C
            HF_PPN(I_BASE,J_BASE,1,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *FIPIDE(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,0,1)
C
            HF_PPP(I_BASE,J_BASE,1,0)=
     *
     *             CONJG(PHASPI(I_BASE,0,1,1))
     *                  *FIPIDE(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,0,1)
C
C            Pairing field for neutrons and protons (spin-down/spin-up block)
C
            HF_PPN(I_BASE,J_BASE,0,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *FIPIDE(I_BASE,J_BASE,0,0)
     *                         *PHASPI(J_BASE,0,1,1)
C
            HF_PPP(I_BASE,J_BASE,0,1)=
     *
     *             CONJG(PHASPI(I_BASE,0,0,1))
     *                  *FIPIDE(I_BASE,J_BASE,0,1)
     *                         *PHASPI(J_BASE,0,1,1)
C
         END DO
      END DO
C
C=======================================================================
C      DEFINING THE HFBTHO BASIS BASED ON CURRENT INPUTS FROM HFODD:
C      NUMBER OF SHELLS, FREQUENCIES OF THE HO, CONSERVATION/BREAKING
C      OF PARITY, ENERGY CUT-OFF OF THE BASIS
C=======================================================================
C
      hbzero=HBMASS
      N_UNIT=NFIPRI
      HPERPE=HBAROX(1)
      HPARAL=HBAROZ(1)
      ELIMI1 = ELIMIT(1)
C
      Call Basis_THO(N_UNIT,NDTRAN,NDSPIN,NOSCIL,BP_THO,BZ_THO,HPERPE,
     *                                    HPARAL,Parity,ELIMI1,hbzero)
C
      NsizeHFBTHO=nt_tho
C
      IF (.NOT.ALLOCATED(validate_HFBTHO))
     *         ALLOCATE(validate_HFBTHO(0:nnm_tho,0:nnm_tho,0:nnm_tho,
     *                                                      0:nnm_tho))
C
      Do i = 1, NsizeHFBTHO
         N  = Nm_tho(i)
         nz = nz_tho(i)
         nr = nr_tho(i)
         ml = nl_tho(i)
         validate_HFBTHO(N, nz, nr, ml) = 1
      End Do
C
      LDTRAN=NsizeHFBTHO
C
C=======================================================================
C      CYLINDRICAL TO CARTESIAN  BASIS  TRANFORMATION. MATRIX OF THE
C      TRANSFORMATION IS STORED IN TRANSM, THE MATRIX OF THE INVERSE
C      TRANFORMATION (HERMITIAN CONJUGATE) IN TRAINV.
C=======================================================================
C
      IALLOC=0
C
      CALL THOXYZ(NOSCIL)
C
      NILXYZ=3
      CALL THOMAT(NOSCIL,NILXYZ,IF_THO,nnm_tho,LDTRAN)
C
      ALLOCATE (TRANSM(1:LDBASE,1:LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('TRANSM','CARCYL')
      ALLOCATE (TRAINV(1:LDTRAN,1:LDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('TRAINV','CARCYL')
C
      TRANSM(:,:)=AUXCYL(:,:)        ! cartesian -> cylindrical
C
      DO J=1,LDBASE
         DO I=1,LDTRAN
            TRAINV(I,J)=CONJG(AUXCYL(J,I)) ! cylindrical -> cartesian
         END DO
      END DO
C
      DEALLOCATE(AUXCYL)
C
C=======================================================================
C      TRANSFORMING THE MEAN-FIELD AND PAIRING FIELD MATRICES FROM
C      HFODD INTO CYLINDRICAL COORDINATES FOR EACH SPIN PROJECTION.
C=======================================================================
C
      ALLOCATE (SPINDW(1:LDBASE,1:LDTRAN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('SPINDW','CARCYL')
      ALLOCATE (AUXMAT(1:LDBASE,1:LDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXMAT','CARCYL')
C
      C_UNIT=CMPLX(1.0D0,0.0D0)
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      DO MS_KET=0,NDSPIN
         DO MS_BRA=0,NDSPIN
C
C            Mean-field for neutrons
C
            AUXMAT = HF_PHN(1:LDBASE,1:LDBASE,MS_BRA,MS_KET)
C
            CALL ZGEMM('N','N',LDBASE,LDTRAN,LDBASE,
     *                         C_UNIT,AUXMAT,LDBASE,
     *                         TRANSM,LDBASE,C_ZERO,SPINDW,LDBASE)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDBASE,
     *                         C_UNIT,TRAINV,LDTRAN,
     *                         SPINDW,LDBASE,C_ZERO,AUXMAT,LDBASE)
C
            HF_PHN(1:LDBASE,1:LDBASE,MS_BRA,MS_KET) = AUXMAT
C
C            Mean-field for protons
C
            AUXMAT = HF_PHP(1:LDBASE,1:LDBASE,MS_BRA,MS_KET)
C
            CALL ZGEMM('N','N',LDBASE,LDTRAN,LDBASE,
     *                         C_UNIT,AUXMAT,LDBASE,
     *                         TRANSM,LDBASE,C_ZERO,SPINDW,LDBASE)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDBASE,
     *                         C_UNIT,TRAINV,LDTRAN,
     *                         SPINDW,LDBASE,C_ZERO,AUXMAT,LDBASE)
C
            HF_PHP(1:LDBASE,1:LDBASE,MS_BRA,MS_KET) = AUXMAT
C
C            Pairing field for neutrons
C
            AUXMAT = HF_PPN(1:LDBASE,1:LDBASE,MS_BRA,MS_KET)
C
            CALL ZGEMM('N','N',LDBASE,LDTRAN,LDBASE,
     *                         C_UNIT,AUXMAT,LDBASE,
     *                         TRANSM,LDBASE,C_ZERO,SPINDW,LDBASE)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDBASE,
     *                         C_UNIT,TRAINV,LDTRAN,
     *                         SPINDW,LDBASE,C_ZERO,AUXMAT,LDBASE)
C
            HF_PPN(1:LDBASE,1:LDBASE,MS_BRA,MS_KET) = AUXMAT
C
C            Pairing field for protons
C
            AUXMAT = HF_PPP(1:LDBASE,1:LDBASE,MS_BRA,MS_KET)
C
            CALL ZGEMM('N','N',LDBASE,LDTRAN,LDBASE,
     *                         C_UNIT,AUXMAT,LDBASE,
     *                         TRANSM,LDBASE,C_ZERO,SPINDW,LDBASE)
C
            CALL ZGEMM('N','N',LDTRAN,LDTRAN,LDBASE,
     *                         C_UNIT,TRAINV,LDTRAN,
     *                         SPINDW,LDBASE,C_ZERO,AUXMAT,LDBASE)
C
            HF_PPP(1:LDBASE,1:LDBASE,MS_BRA,MS_KET) = AUXMAT
C
         END DO
      END DO
C
C=======================================================================
      DEALLOCATE(TRANSM,TRAINV,SPINDW,AUXMAT)
C=======================================================================
C
      CALL CPUTIM('CARCYL',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE THOPAI
C=======================================================================
      USE PD_DEN
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          PNEUTR,PPROTO,
     *          XNEUTR,XPROTO
C
      COMMON
     *       /DENTOT/ DENSIT(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHA(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('THOPAI',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE PAIRING FIELDS BASED ON THE REF.
C        DOBACZEWSKI ET AL. NP422 (1984) 103 REFERRED TO AS DFT.
C=======================================================================
C        ATTENTION: AT PRESENT, ONLY THE CENTRAL FIELDS COMING FROM  THE
C                   T0 AND T3 TERMS ARE PROGRAMED.
C=======================================================================
C
C        THE EFFECTIVE COUPLING CONSTANTS ARE CODED AS:
C                      'P'//'XXX'//'N'//'TYP'
C
C        WHERE THE SYMBOLS:  'P', 'XXX', 'N', AND 'TYP'
C        ARE EXPLAINED IN THE SUBROUTINE "ESKYRM"
C
C=======================================================================
C
      XOLDPA=0.0D0
C
      XNEWPA=1.0D0-XOLDPA
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
C=======================================================================
C              S  C  A  L  A  R     F I E L D S     F O L L O W
C=======================================================================
C=======================================================================
C              CENTRAL TERM (<= T0) - (SEE: DFT EQ.(A5.B))
C=======================================================================
C
               XNEUTR = PRHO_N * PD_RHO(IX,IY,IZ,0,1) / 2.0D0
               XPROTO = PRHO_P * PD_RHO(IX,IY,IZ,1,1) / 2.0D0
C
               PNEUTR = XNEUTR
               PPROTO = XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= T3)
C=======================================================================
C
               XNEUTR = PRHODN * PD_RHO(IX,IY,IZ,0,1) / 2.0D0
     *                         * DENSIT(IX,IY,IZ,1)**POWERN
               XPROTO = PRHODP * PD_RHO(IX,IY,IZ,1,1) / 2.0D0
     *                         * DENSIT(IX,IY,IZ,1)**POWERP
C
               PNEUTR = PNEUTR + XNEUTR
               PPROTO = PPROTO + XPROTO
C
               WD_CEN(IX,IY,IZ,0,1) = WD_CEN(IX,IY,IZ,0,1)*XOLDPA
     *                            + XNEWPA*PNEUTR
               WD_CEN(IX,IY,IZ,1,1) = WD_CEN(IX,IY,IZ,1,1)*XOLDPA
     *                            + XNEWPA*PPROTO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('THOPAI',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE REVIEW(NFIREV,VERSIO,IN_FIX,IZ_FIX,
     *                         SKYRME,GOGNAM,ISTAND,
     *           KETA_J,KETA_W,KETACM,KETA_M,KETA_P,KETA_T,KETAPA,
     *                                       NOZEPA,
     *           JETA_J,JETA_W,JETACM,JETA_M,JETA_P,JETA_T,JETAPA,
     *                                ITWOLI,KETA_R,
     *           LANODD,LANSCA,HBMSAT,RHOSAT,EFFSAT,
     *                  NMUMAX,NMUCON,NMUCOU,NMUPRI,
     *                                ICOUMD,ICOUMX,
     *                  ISCHIF,NSIMAX,NSICON,NSIPRI,
     *                  NMAMAX,NMACON,NMAPRI,NMAORD,
     *                  NASMAX,NASCON,NASPRI,NASORD,
     *                                       NRAORD,
     *                  NMURED,NMARED,NASRED,NSIRED,
     *                         LAMMAX,NOSCIL,NLIMIT,
     *                  DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                  FERFIN,FERFIP,IFEFIN,IFEFIP,
     *                  FE2FIN,FE2FIP,IF2FIN,IF2FIP,
     *                  FERALN,FERALP,IFERAN,IFERAP,
     *                                       NUQEVE,
     *                  INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *                  INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                         INSIMN,IRSIMN,IDSIMN,
     *                         INSIMP,IRSIMP,IDSIMP,
     *                         INSIQN,IPSIQN,IDSIQN,
     *                         INSIQP,IPSIQP,IDSIQP,
     *                                INSIZN,IDSIZN,
     *                                INSIZP,IDSIZP,
     *                                IFIBLN,INIBLN,
     *                                IFIBLP,INIBLP,
     *                                IQUNIL,NILXYZ,
     *                         ECUTOF,LIMQUA,LAMCUT,
     *                                       IPOTHO,
     *           IPAIRI,IPAHFB,ITWOBA,JPABCS,IMFHFB,
     *                                LIPKIN,LIPKIP,
     *                                LIPNON,LIPNOP,
     *           IROTAT,ITIREP,IREVIE,IQPSTA,MREVER,
     *                  FILREP,FILREC,FILWOO,
     *                  FILREV,FILCOU,FILWAV,FILKER,
     *                  FILYUP,FILYUC,
     *                  FILGOP,FILGOC,
     *                  FILGPP,FILGPC,
     *                  FILROP,FILROC,
     *                  FILLIP,FILLIC,
     *                  FILFIP,FILFIC,
     *                  FILQUA,FILRED,
     *                  FILBAP,FILBAC,
     *                  CMSXFC,CMSYFC,CMSZFC,
     *                  XMOMFC,YMOMFC,ZMOMFC,
     *                  EPSHER,
     *                  ICOMIX,INLKER,INRKER,
     *                  ICMPRI,IN_EXC,EPSMIX,
     *                         ISOADD,NBTKNT,
     *                  HOMEGA,FCHOM0,ENECUT,
     *                  CVOLFC,R0PARM,
     *                                ISOTRO,
     *                  NUMCOU,NUMETA,FURMAX,
     *                  ICOTYP,ICOUDI,ICOUEX,
     *           PIMASS,PNMASS,IYUTYP,I_YUKA,
     *           YUKAGT,YUKAG0,YUKAG1,YUKAG2,
     *                         I_GOGA,IGOGPA,
     *                         I_REGA,IREGPA,
     *                         I_SEPA,ISEPPA,
     *                         I_COUA,ICOUPA,
     *                  N3LORD,N3SERD,IDOTHC,
     *                  ISPHER,ISIMPY,ISIGNY,
     *                         IPARTY,ISIQTY,
     *                  ISIMTX,JSIMTY,ISIMTZ,
     *           NULAST,EPSITE,NUCONS,EPSCON,
     *                  INIROT,INIINV,INIKAR,
     *                  NUCHAO,NUPING,EPSPNG,
     *                  ICHFLI,IPAFLI,IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *           SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                         I_SLOW,SLOWAL,
     *           SLOWLD,SLOWTP,SLOWRP,SLOWLM,
     *           IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                  IS_YES,IS_PIN,IS_CHA,
     *    NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,
     *    NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,
     *                         LASTAN,LASTAP,
     *                  IAXIAP,KAPASY,INUNIL,
     *                                ITWCEN)
C=======================================================================
      USE HE_DEN
      USE TRUDEN
      USE TRUINT
      USE hfodd_sizes
      USE hfodd_twocen
C=======================================================================
      PARAMETER (NDMORD=3)
      PARAMETER (NDF2BC=5)
      PARAMETER (NDFANL=2)
      PARAMETER (NDFSTA=3)
C=======================================================================
C
      CHARACTER
     *          FILREP*68,FILREC*68,FILWOO*68,
     *          FILREV*68,FILCOU*68,FILWAV*68,FILKER*68,
     *          FILYUP*68,FILYUC*68,
     *          FILGOP*68,FILGOC*68,
     *          FILGPP*68,FILGPC*68,
     *          FILROP*68,FILROC*68,
     *          FILLIP*68,FILLIC*68,
     *          FILFIP*68,FILFIC*68,
     *          FILQUA*68,FILRED*68,
     *          FILBAP*68,FILBAC*68
      CHARACTER
     *          FILLEF*68,FILRIG*68
      CHARACTER
     *          SPKART*10,SPNILS*15,SPORDE*13,SPNILA*15
      CHARACTER
     *          QPNILS*15,QPORDD*13,QPNIL2*9
C
      CHARACTER
     *          SKYRME*4,GOGNAM*4,VERSIO*5
      CHARACTER
     *          PNKART*10,PNNILS*15,PNORDE*13
      CHARACTER
     *          NEUPRO(0:NDISOS)*1
C
      COMPLEX
     *          ALPHAC(0:NDLAMB,-NDLAMB:+NDLAMB)
      COMPLEX
     *          EGOGSD,EGOGSE,EGOGVD,EGOGVE,
     *          EGOTSD,EGOTSE,EGOTVD,EGOTVE,
     *          EGOSSD,EGOSSE,EGOSVD,EGOSVE,
     *          EGOPSD,EGOPSE,EGOPVD,EGOPVE,
     *          EGOMSD,EGOMSE,EGOMVD,EGOMVE
      COMPLEX
     *          E3BEVE,E3BODD
      COMPLEX
     *          E4BEVE,E4BODD
      COMPLEX
     *          EREGSD,EREGVD,EREGSE,EREGVE
      COMPLEX
     *          ERETSD,ERETVD,ERETSE,ERETVE,
     *          ERESSD,ERESVD,ERESSE,ERESVE,
     *          EREPSD,EREPVD,EREPSE,EREPVE,
     *          EREMSD,EREMVD,EREMSE,EREMVE
      COMPLEX
     *          EREGSP,EREGVP
      COMPLEX
     *          ESEPSD,ESEPVD,ESEPSE,ESEPVE
      COMPLEX
     *          ESPTSD,ESPTVD,ESPTSE,ESPTVE,
     *          ESPSSD,ESPSVD,ESPSSE,ESPSVE,
     *          ESPPSD,ESPPVD,ESPPSE,ESPPVE,
     *          ESPMSD,ESPMVD,ESPMSE,ESPMVE
      COMPLEX
     *          ESEPSP,ESEPVP
      COMPLEX
     *          DE_ORB(1:NDKART,0:NDISOS),DE_MAG(1:NDKART)
C
      DIMENSION
     *          IN_EXC(ND_EXC)
      DIMENSION
     *          INSIZN(1:NDBLOC),IDSIZN(1:NDBLOC),
     *          INSIZP(1:NDBLOC),IDSIZP(1:NDBLOC)
      DIMENSION
     *          INSIQN(1:NDBLOC),IPSIQN(1:NDBLOC),IDSIQN(1:NDBLOC),
     *          INSIQP(1:NDBLOC),IPSIQP(1:NDBLOC),IDSIQP(1:NDBLOC)
      DIMENSION
     *             CCPALL(NDCOUT), DCPALL(NDCOUT), ECPALL(NDCOUT)
      EQUIVALENCE
     *            (CCPALL,CRHO_T),(DCPALL,DRHO_T),(ECPALL,ERHO_T)
C
      COMMON
     *       /HERSTO/ HERMTS(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /INTMEM/ TWOWGT(1:NDGAUS,1:NDKART),
     *                TWOPNT(1:NDGAUS,1:NDKART)
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /SIGOCC/ N_OCCU(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS),
     *                N_OCVA(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMOCC/ L_OCCU(1:NDSTAT,0:NDREVE,0:NDISOS),
     *                L_OCVA(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIQOCC/ K_OCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *                K_OCVA(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIZOCC/ M_OCCU(1:2*NDSTAT,0:NDISOS),
     *                M_OCVA(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /MIGOCC/ NMOCCU(1:2*NDSTAT,0:NDPARI,0:NDREVE),
     *                NMOCVA(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIMOCC/ LMOCCU(1:2*NDSTAT,0:NDREVE),
     *                LMOCVA(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /MIQOCC/ KMOCCU(1:4*NDSTAT,0:NDPARI),
     *                KMOCVA(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /MIZOCC/ MMOCCU(1:4*NDSTAT),
     *                MMOCVA(1:4*NDSTAT)
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /QPLEVS/ QPENER(1:4*NDSTAT,0:NDISOS),
     *                QPOCCU(1:4*NDSTAT,0:NDISOS),
     *                QPPARR(1:4*NDSTAT,0:NDISOS),
     *                QPEEQU(1:4*NDSTAT,0:NDISOS),
     *                QPDEQU(1:4*NDSTAT,0:NDISOS),
     *                QPCORR(1:4*NDSTAT,0:NDISOS)
      COMMON
     *       /QPLABS/ QPORDD(1:4*NDSTAT,0:NDISOS),
     *                QPNILS(1:4*NDSTAT,0:NDISOS),
     *                QPNIL2(1:4*NDSTAT,0:NDISOS),
     *                QPNORM(1:4*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLABS/ SPKART(1:2*NDSTAT,0:NDISOS),
     *                SPNILS(1:2*NDSTAT,0:NDISOS),
     *                SPORDE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPRADI/ SPSIZE(1:2*NDSTAT,0:NDISOS,0:NDKART)
      COMMON
     *       /SPMOME/ SPMO20(1:2*NDSTAT,0:NDISOS),
     *                SPMO22(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNSTAT/ PNXALI(1:4*NDSTAT),
     *                PNZALI(1:4*NDSTAT),
     *                PNXSPI(1:4*NDSTAT),
     *                PNZSPI(1:4*NDSTAT)
      COMMON
     *       /PNLABS/ PNKART(1:4*NDSTAT),
     *                PNNILS(1:4*NDSTAT),
     *                PNORDE(1:4*NDSTAT)
      COMMON
     *       /PNRADI/ PNSIZE(1:4*NDSTAT,0:NDKART)
      COMMON
     *       /PNMOME/ PNMO20(1:4*NDSTAT),
     *                PNMO22(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(         0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIG/ NPFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFLIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIM/ NPFLIM(0:NDREVE,         0:NDISOS),
     *                NHFLIM(0:NDREVE,         0:NDISOS),
     *                NOFLIM(0:NDREVE,         0:NDISOS)
      COMMON
     *       /N_FLIQ/ NPFLIQ(0:NDPARI,         0:NDISOS),
     *                NHFLIQ(0:NDPARI,         0:NDISOS),
     *                NOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /N_FLIZ/ NPFLIZ(                  0:NDISOS),
     *                NHFLIZ(                  0:NDISOS),
     *                NOFLIZ(                  0:NDISOS)
      COMMON
     *       /N_MLIG/ NPMLIG(0:NDPARI,0:NDREVE),
     *                NHMLIG(0:NDPARI,0:NDREVE),
     *                NOMLIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MLIM/ NPMLIM(0:NDREVE),
     *                NHMLIM(0:NDREVE),
     *                NOMLIM(0:NDREVE)
      COMMON
     *       /N_MLIQ/ NPMLIQ(0:NDPARI),
     *                NHMLIQ(0:NDPARI),
     *                NOMLIQ(0:NDPARI)
      COMMON
     *       /N_MLIZ/ NPMLIZ,
     *                NHMLIZ,
     *                NOMLIZ
      COMMON
     *       /N_FILG/ NPFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFILG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FILZ/ NPFILZ(                  0:NDISOS),
     *                NHFILZ(                  0:NDISOS),
     *                NOFILZ(                  0:NDISOS)
      COMMON
     *       /CONVER/ ETOTFI(1:NDITER+1),ETOTSI(1:NDITER+1),
     *                                   ESTABI(1:NDITER+1),
     *                QUA20I(1:NDITER+1),QUA22I(1:NDITER+1),
     *                ANGUTI(1:NDITER+1)
      COMMON
     *       /RMSRAD/ RADI_N(0:NDKART),
     *                RADI_P(0:NDKART),
     *                RADI_T(0:NDKART)
      COMMON
     *       /RMSRAH/ RMSRAN(1:NDMORD),
     *                RMSRAP(1:NDMORD),
     *                RMSRAT(1:NDMORD)
      COMMON
     *       /RMSSHI/ RSHI_N(0:NDKART),
     *                RSHI_P(0:NDKART),
     *                RSHI_T(0:NDKART)
      COMMON
     *       /SHIFTR/ RSHIFT(1:NDKART)
      COMMON
     *       /EANGLE/ ALPEUL,BETEUL,GAMEUL
      COMMON
     *       /IANGLE/ ALPINI,BETINI,GAMINI
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BMULTI/ BMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                BMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                BMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /AMULTI/ AMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /WMULTI/ WMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /QSHIFT/ QSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BSHIFT/ BSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                BSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                BSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SSHIFT/ SSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                SSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                SSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ASHIFT/ ASHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                ASHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                ASHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QROTAT/ QROT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QROT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QROT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BROTAT/ BROT_N(0:NDMULT,-NDMULT:NDMULT),
     *                BROT_P(0:NDMULT,-NDMULT:NDMULT),
     *                BROT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SROTAT/ SROTNN(0:NDMULT,-NDMULT:NDMULT),
     *                SROTNP(0:NDMULT,-NDMULT:NDMULT),
     *                SROTNT(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /AROTAT/ AROTNN(0:NDMULT,-NDMULT:NDMULT),
     *                AROTNP(0:NDMULT,-NDMULT:NDMULT),
     *                AROTNT(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VCNSTR/ STIFFV(0:NDMULT,-NDMULT:NDMULT),
     *                VASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SCNSTR/ STIFFS(0:NDMULT,-NDMULT:NDMULT),
     *                SASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /GCNSTR/ STIFFG(0:NDMULT),
     *                GASKED(0:NDMULT),
     *                IFLAGG(0:NDMULT)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /SIFUNI/ SUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /VMUUNI/ VUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /ASMUNI/ BUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /SCALNG/ HOMSCA(1:NDKART,1:NDTWCE)
C
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /PAIINI/ FERINI(0:NDISOS),DELINI(0:NDISOS),FE2INI(0:NDISOS)
      COMMON
     *       /ALLENE/ EKIN_N,EKIN_P,EKIN_T,
     *                EPOT_N,EPOT_P,EPOT_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *                EREA_N,EREA_P,EREA_T,
     *                ELIP_N,ELIP_P,ELIP_T,
     *
     *                ECOULD,ECOULE,ECOULT,
     *                       ECOULS,ECOULV,
     *
     *                EMULCO,EMUSLO,EMUREA,
     *                ESIFCO,ESISLO,ESIREA,
     *                ESPICO,ESPSLO,ESPREA,
     *
     *                ENREAR,ECORCM,ECOR_R,
     *
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
      COMMON
     *       /E_TENS/ ETEVEN,ETEODD,
     *                ETOVEN,ETOODD
      COMMON
     *       /ETHREE/ E3BEVE,E3BODD
      COMMON
     *       /EFOURB/ E4BEVE,E4BODD
      COMMON
     *       /CCPSKY/ CRHO_T,CRHO_S,CRHODT,CRHODS,
     *                CLPR_T,CLPR_S,
     *                CTAU_T,CTAU_S,
     *                CSCU_T,CSCU_S,
     *                CDIV_T,CDIV_S,
     *                CSPI_T,CSPI_S,CSPIDT,CSPIDS,
     *                CLPS_T,CLPS_S,
     *                CCUR_T,CCUR_S,
     *                CKIS_T,CKIS_S,
     *                CROT_T,CROT_S,
     *                CSCT_T,CSCT_S,
     *                CKIT_T,CKIT_S,
     *                CSPT_T,CSPT_S
      COMMON
     *       /DCPSKY/ DRHO_T,DRHO_S,DRHODT,DRHODS,
     *                DLPR_T,DLPR_S,
     *                DTAU_T,DTAU_S,
     *                DSCU_T,DSCU_S,
     *                DDIV_T,DDIV_S,
     *                DSPI_T,DSPI_S,DSPIDT,DSPIDS,
     *                DLPS_T,DLPS_S,
     *                DCUR_T,DCUR_S,
     *                DKIS_T,DKIS_S,
     *                DROT_T,DROT_S,
     *                DSCT_T,DSCT_S,
     *                DKIT_T,DKIT_S,
     *                DSPT_T,DSPT_S
      COMMON
     *       /ECPSKY/ ERHO_T,ERHO_S,ERHODT,ERHODS,
     *                ELPR_T,ELPR_S,
     *                ETAU_T,ETAU_S,
     *                ESCU_T,ESCU_S,
     *                EDIV_T,EDIV_S,
     *                ESPI_T,ESPI_S,ESPIDT,ESPIDS,
     *                ELPS_T,ELPS_S,
     *                ECUR_T,ECUR_S,
     *                EKIS_T,EKIS_S,
     *                EROT_T,EROT_S,
     *                ESCT_T,ESCT_S,
     *                EKIT_T,EKIT_S,
     *                ESPT_T,ESPT_S
      COMMON
     *       /EN_GOG/ EGOGSD(0:NDISOS,0:NDISOS),
     *                EGOGSE(0:NDISOS,0:NDISOS),
     *                EGOGVD(0:NDISOS,0:NDISOS),
     *                EGOGVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_GTS/ EGOTSD,EGOTSE,EGOTVD,EGOTVE,
     *                EGOSSD,EGOSSE,EGOSVD,EGOSVE
     *
     *       /EN_GPM/ EGOPSD,EGOPSE,EGOPVD,EGOPVE,
     *                EGOMSD,EGOMSE,EGOMVD,EGOMVE
      COMMON
     *       /EGOGTT/ EGOGDT,EGOGET
      COMMON
     *       /PGOGTT/ EGOGPT
      COMMON
     *       /EN_REG/ EREGSD(0:NDISOS,0:NDISOS),
     *                EREGSE(0:NDISOS,0:NDISOS),
     *                EREGVD(0:NDISOS,0:NDISOS),
     *                EREGVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_RTS/ ERETSD,ERETSE,ERETVD,ERETVE,
     *                ERESSD,ERESSE,ERESVD,ERESVE
     *
     *       /EN_RPM/ EREPSD,EREPSE,EREPVD,EREPVE,
     *                EREMSD,EREMSE,EREMVD,EREMVE
      COMMON
     *       /PN_REG/ EREGSP(0:NDISOS),EREGVP(0:NDISOS)
      COMMON
     *       /EREGTT/ EREGDT,EREGET
      COMMON
     *       /PREGTT/ EREGPT
      COMMON
     *       /EN_SEP/ ESEPSD(0:NDISOS,0:NDISOS),
     *                ESEPSE(0:NDISOS,0:NDISOS),
     *                ESEPVD(0:NDISOS,0:NDISOS),
     *                ESEPVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_STS/ ESPTSD,ESPTSE,ESPTVD,ESPTVE,
     *                ESPSSD,ESPSSE,ESPSVD,ESPSVE
     *
     *       /EN_SPM/ ESPPSD,ESPPSE,ESPPVD,ESPPVE,
     *                ESPMSD,ESPMSE,ESPMVD,ESPMVE
      COMMON
     *       /PN_SEP/ ESEPSP(0:NDISOS),ESEPVP(0:NDISOS)
      COMMON
     *       /ESEPTT/ ESEPDT,ESEPET
      COMMON
     *       /PSEPTT/ ESEPPT
      COMMON
     *       /ISOENE/ EISOCO,EISSLO,EISREA
C
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /ANGSPI/ SPIN_N(1:NDKART),SPIN_P(1:NDKART),SPIN_T(1:NDKART)
      COMMON
     *       /LINMOM/ DLINSN(0:NDKART),DLINSP(0:NDKART),DLINST(0:NDKART)
     *               ,ELINSN(0:NDKART),ELINSP(0:NDKART),ELINST(0:NDKART)
     *               ,TLINSN(0:NDKART),TLINSP(0:NDKART),TLINST(0:NDKART)
     *               ,ALINLN(0:NDKART),ALINLP(0:NDKART),ALINLT(0:NDKART)
      COMMON
     *       /ROTMOM/ DROTSN(0:NDKART),DROTSP(0:NDKART),DROTST(0:NDKART)
     *               ,EROTSN(0:NDKART),EROTSP(0:NDKART),EROTST(0:NDKART)
     *               ,TROTSN(0:NDKART),TROTSP(0:NDKART),TROTST(0:NDKART)
     *               ,AROTLN(0:NDKART),AROTLP(0:NDKART),AROTLT(0:NDKART)
      COMMON
     *       /SHIANG/ ANGS_N(1:NDKART),ANGS_P(1:NDKART),ANGS_T(1:NDKART)
      COMMON
     *       /ICNSTR/ STIFFI(1:NDKART),
     *                ASKEDI(1:NDKART),
     *                IFLAGI(1:NDKART)
      COMMON
     *       /ICNTTR/ STIFTI(1:NDKART),
     *                ASKETI(1:NDKART),
     *                IFTAGI(1:NDKART)
      COMMON
     *       /TCNSTR/ STIFFT(1:NDKART),
     *                ASKEDT(1:NDKART),
     *                IFLAGT(1:NDKART)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /ACNSTR/ STIFFA,ASKEDA,IFLAGA
      COMMON
     *       /DEFORM/ ALPHAC,IREALA
      COMMON
     *       /ITERTS/ ITESTA,ITESTO,NOITER,NUMITE
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /ATWOBO/ TWOBOD,TWOINP,ITWOIN
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /SKYINP/ T0_INP,X0_INP,T1_INP,X1_INP,T2_INP,X2_INP,
     *                T3_INP,X3_INP,WW_INP,PO_INP
      COMMON
     *       /SKYERR/ T0_ERR,X0_ERR,T1_ERR,X1_ERR,T2_ERR,X2_ERR,
     *                T3_ERR,X3_ERR,WW_ERR,PO_ERR
      COMMON
     *       /SKYFAC/ T0_FAC,X0_FAC,T1_FAC,X1_FAC,T2_FAC,X2_FAC,
     *                T3_FAC,X3_FAC,WW_FAC,PO_FAC
      COMMON
     *       /CBRPA2/ T02CBR,X02CBR,
     *                T12CBR,X12CBR,
     *                T22CBR,X22CBR
     *       /CBRPA3/ T03CBR,X03CBR,
     *                T13CBR,X13CBR,
     *                T23CBR,X23CBR
     *       /CBRSWI/ I_2CBR,I_3CBR
      COMMON
     *       /SO_PAR/ W0_INP,W0PINP
      COMMON
     *       /SO_ERR/ W0_ERR,W0PERR
      COMMON
     *       /SO_FAC/ W0_FAC,W0PFAC
      COMMON
     *       /REGPAR/ REGWID
      COMMON
     *       /REGBIN/ REGBCC(NDREGA,NDFORC),IREREG
      COMMON
     *       /REGVIN/ REGVCC(NDREGA,NDFORC)
      COMMON
     *       /REJVER/ REJERR(NDREGA,NDFORC)
      COMMON
     *       /REJVAC/ REJFAC(NDREGA,NDFORC)
      COMMON
     *       /JREJAL/ IREREJ(4),NREREJ(4)
      COMMON
     *       /SEPPAR/ SEPWID(NDSEGA),SEPGAU(NDSEGA),NUSEGA
      COMMON
     *       /SEPBIN/ SEPVIC(NDSEPA,NDFORC),IVISEP
      COMMON
     *       /SEPVIN/ SEPVCC(NDSEPA,NDFORC),IRESEP
      COMMON
     *       /SEPVER/ SEPERR(NDSEPA,NDFORC),IERSEP
      COMMON
     *       /SEPFAC/ SEPFAC(NDSEPA,NDFORC),IFASEP
      COMMON
     *       /CHARGE/ ECHAR2
      COMMON
     *       /EXCHAN/ COULEX
      COMMON
     *       /OMEGAS/ OMEGAX,OMEGAY,OMEGAZ
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /LAND_G/ X0_LAN,X1_LAN,G0_LAN,G0PLAN,G1_LAN,G1PLAN
      COMMON
     *       /IKETRA/ IKEINV,IKEKAR
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /ALLABS/ SPNILA(1:2*NDSTAT,2*NDTRAN,0:NDISOS)
      COMMON
     *       /ALAMPL/ SPAMPL(1:2*NDSTAT,2*NDTRAN,0:NDISOS),
     *                SPAMPN(1:2*NDSTAT,        0:NDISOS)
      COMMON
     *       /NEWIGN/ NEWWIG
      COMMON
     *       /GYROSC/ GYRORP,GYRSPN,GYRSPP,IGYROS
      COMMON
     *       /CUSIZN/ NCUSIZ(0:NDISOS)
      COMMON
     *       /CUSIQN/ NCUSIQ(0:NDISOS,0:NDPARI)
      COMMON
     *       /GEFACT/ GESPIN(0:NDISOS),GEORBI(0:NDISOS)
      COMMON
     *       /KERNAM/ FILLEF(NDCONF),FILRIG(NDCONF),NUCONF,NAMKER
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /CENPOS/ CENCOR(1:NDKART,NDTWCE)
      COMMON
     *       /TWPOIN/ XZERLE(1:NDGAUS,1:NDKART,1:NDTWDD),
     *                XZERRI(1:NDGAUS,1:NDKART,1:NDTWDD),
     *                PNTWC4(1:NDGAUS,1:NDKART,1:NDTWHE)
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /GEF2BC/ GIN2BC,GSA2BC,IGY2BC
      COMMON
     *       /FORANL/ MAGANL(NDFANL)
      COMMON
     *       /GEFANL/ GJ2ANL,GSQANL,IGYANL
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /FSTFOR/ FSOSTR(NDGOGA,NDFORC),
     *                FTOSTR(NDGOGA,NDFORC),
     *                FTESTR(NDGOGA,NDFORC),FSTWID(NDGOGA)
C
C=======================================================================
C
      DATA
     *     IVEREV /150/
      DATA
     *     NEUPRO /'N','P'/
C
C=======================================================================
C
C         THIS SUBROUTINE WRITES ON DISC A REVIEW OF DATA  AND  RESULTS,
C         ADDING IN SEQUENCE THE FOLLOWING INFORMATION:
C
C         |IREVIE|= 0 ---> NO REVIEW FILE
C         |IREVIE|> 0 ---> SHORT REVIEW FILE (NO   SINGLE-PARTICLE DATA)
C         |IREVIE|> 1 ---> LONG  REVIEW FILE (WITH SINGLE-PARTICLE DATA)
C          IREVIE =-2 ---> LONG  REVIEW FILE (WITH  QUASI-PARTICLE DATA)
C         |IREVIE|> 2 ---> LARGE REVIEW FILE (WITH X & Z SINGLE-PARTICLE
C                                                        ALIGNMENT DATA)
C         |IREVIE|> 3 ---> LARGE REVIEW FILE (WITH PROT-NEUT  S.P. DATA)
C         |IREVIE|> 4 ---> LARGE REVIEW FILE (WITH PROT-NEUT ALIG. DATA)
C         |IREVIE|> 5 ---> LARGE REVIEW FILE (WITH INTEGRATION   POINTS)
C         |IREVIE|> 6 ---> LARGE REVIEW FILE (WITH INTEGRATION  WEIGHTS)
C         |IREVIE|> 7 ---> LARGE REVIEW FILE (WITH DENSITIES)
C
C=======================================================================
C        WRITING RESULTS TO THE REVIEW FILE
C=======================================================================
C
      WRITE(NFIREV,'(24(1H>),''                    '',3X,5X,24(1H<))')
C
      WRITE(NFIREV,'(24(1H>),''   REVIEW VERSION = '',I3,5X,24(1H<))')
     *
     *      IVEREV
C
      WRITE(NFIREV,'(24(1H>),''   CODE   VERSION = '',A5,3X,24(1H<))')
     *
     *      VERSIO
C
      WRITE(NFIREV,'(24(1H>),''                    '',3X,5X,24(1H<))')
C
      WRITE(NFIREV,'(''DIMENS'')')
      WRITE(NFIREV,'(6X,14I5)')
     *
     *      NDMAIN,NDBASE,NDGAUS,NDXHRM,NDYHRM,NDZHRM,
     *      NDSTAT,NDCOUL,NDPOLS,NDITER,NDCOUT,NDLAMB,
     *      NDMULT,NDTERM
C
      WRITE(NFIREV,'(''FILNAM'')')
      WRITE(NFIREV,'(6X,A68)')
     *
     *      FILREP,FILREC,FILWOO,FILREV,FILCOU,FILWAV,FILKER,
     *      FILYUP,FILYUC,FILLIP,FILLIC,FILFIP,FILFIC,
     *      FILGOP,FILGOC,FILGPP,FILGPC,FILROP,FILROC,
     *      FILQUA,FILRED,FILBAP,FILBAC
C
      WRITE(NFIREV,'(''NUCONF'')')
      WRITE(NFIREV,'(6X,2I5)')
     *
     *      NUCONF,NAMKER
C
      WRITE(NFIREV,'(6X,A68)')
     *
     *      (FILLEF(I),FILRIG(I),I=1,NUCONF)
C
      WRITE(NFIREV,'(''SKYRME'')')
      WRITE(NFIREV,'(6X,A4)')
     *
     *      SKYRME
C
      WRITE(NFIREV,'(''ISTAND'')')
      WRITE(NFIREV,'(6X,5I6,/,12X,4I6,/,12X,2I6,/,12X,2I6,/,12X,2I6,/,
     *                                                      12X,I6)')
     *
     *      ISTAND,KETA_J,KETA_W,KETACM,KETA_M,
     *             JETA_J,JETA_W,JETACM,JETA_M,
     *             KETA_P,JETA_P,
     *             KETA_T,JETA_T,
     *             KETAPA,JETAPA,
     *                    NOZEPA
C
      WRITE(NFIREV,'(''GOGNY'')')
      WRITE(NFIREV,'(6X,A4)')
     *
     *      GOGNAM
C
      WRITE(NFIREV,'(''TWOLIN'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      ITWOLI
C
      WRITE(NFIREV,'(''ROTCOR'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      KETA_R
C
      WRITE(NFIREV,'(''LANDAU'')')
      WRITE(NFIREV,'(6X,I6,3(1PE18.10),/,12X,6(1PE18.10),/,6X,I6)')
     *
     *      LANODD,HBMSAT,RHOSAT,EFFSAT,
     *      X0_LAN,X1_LAN,G0_LAN,G0PLAN,G1_LAN,G1PLAN,
     *      LANSCA
C
      WRITE(NFIREV,'(''IN_FIX'')')
      WRITE(NFIREV,'(6X,2I6)')
     *
     *      IN_FIX,IZ_FIX
C
      WRITE(NFIREV,'(''NOSCIL'')')
      WRITE(NFIREV,'(6X,3I6)')
     *
     *      NOSCIL,NLIMIT,LDBASE
C
      WRITE(NFIREV,'(''IPAIRI'')')
      WRITE(NFIREV,'(6X,13I6)')
     *
     *      IPAIRI,IROTAT,IREVIE,
     *      IPAHFB,JPABCS,IMFHFB,
     *      LIPKIN,LIPKIP,ITWOBA,
     *      ITIREP,LIPNON,LIPNOP,IQPSTA
C
      WRITE(NFIREV,'(''HBMASS'')')
      WRITE(NFIREV,'(6X,5(1PE18.10))')
     *
     *      HBMASS,HBMRPA,ECHAR2,COULEX,HBMINP
C
      WRITE(NFIREV,'(''TWOBOD'')')
      WRITE(NFIREV,'(6X,2(1PE18.10),I6)')
     *
     *      TWOBOD,TWOINP,ITWOIN
C
      WRITE(NFIREV,'(''THREEB'')')
      WRITE(NFIREV,'(6X,2(1PE18.10),I6)')
     *
     *      THREEB,THRINP,ITHRIN
C
      WRITE(NFIREV,'(''IGRAIN'')')
      WRITE(NFIREV,'(6X,5(1PE18.10),I6)')
     *
     *      TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
C
      WRITE(NFIREV,'(''FOURBD'')')
      WRITE(NFIREV,'(6X,2(1PE18.10),I6)')
     *
     *      FOURBD,FOUINP,IFOUIN
C
      WRITE(NFIREV,'(''SKYINP'')')
      WRITE(NFIREV,'(6X,6(1PE18.10))')
     *
     *       T0_INP,X0_INP,T1_INP,X1_INP,T2_INP,X2_INP,
     *       T3_INP,X3_INP,WW_INP,PO_INP
C
      WRITE(NFIREV,'(''SKYERR'')')
      WRITE(NFIREV,'(6X,6(1PE18.10))')
     *
     *       T0_ERR,X0_ERR,T1_ERR,X1_ERR,T2_ERR,X2_ERR,
     *       T3_ERR,X3_ERR,WW_ERR,PO_ERR
C
      WRITE(NFIREV,'(''SKYFAC'')')
      WRITE(NFIREV,'(6X,6(1PE18.10))')
     *
     *       T0_FAC,X0_FAC,T1_FAC,X1_FAC,T2_FAC,X2_FAC,
     *       T3_FAC,X3_FAC,WW_FAC,PO_FAC
C
      WRITE(NFIREV,'(''CC_CBR'')')
      WRITE(NFIREV,'(6X,6(1PE18.10),I6,6(1PE18.10),I6)')
     *
     *      T02CBR,X02CBR,
     *      T12CBR,X12CBR,
     *      T22CBR,X22CBR,I_2CBR,
     *      T03CBR,X03CBR,
     *      T13CBR,X13CBR,
     *      T23CBR,X23CBR,I_3CBR
C
      WRITE(NFIREV,'(''SO_PAR'')')
      WRITE(NFIREV,'(6X,2(1PE18.10))')
     *
     *      W0_INP,W0PINP
C
      WRITE(NFIREV,'(''SO_ERR'')')
      WRITE(NFIREV,'(6X,4(1PE18.10))')
     *
     *      W0_ERR,W0PERR,
     *      W0_FAC,W0PFAC
C
      WRITE(NFIREV,'(''IREREG'')')
      WRITE(NFIREV,'(6X,I6,1PE18.10)')
     *
     *     IREREG,REGWID
C
      WRITE(NFIREV,'(''REGVCC'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *   ((REGVCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                          ,INREGA=1,IREREG)
C
      WRITE(NFIREV,'(''REGBCC'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *   ((REGBCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                          ,INREGA=1,IREREG)
C
      WRITE(NFIREV,'(''REJERR'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *   ((REJERR(INREGA,INFORC),INFORC=1,NDFORC)
     *                          ,INREGA=1,IREREG)
C
      WRITE(NFIREV,'(''REJFAC'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *   ((REJFAC(INREGA,INFORC),INFORC=1,NDFORC)
     *                          ,INREGA=1,IREREG)
C
      WRITE(NFIREV,'(''JREJAL'')')
      WRITE(NFIREV,'(6X,4I6,6X,4I6)')
     *
     *   IREREJ,NREREJ
C
      WRITE(NFIREV,'(''IRESEP'')')
      WRITE(NFIREV,'(6X,I6,1PE18.10)')
     *
     *     IRESEP,SEPWID(1)
C
      WRITE(NFIREV,'(''SEPWID'')')
      WRITE(NFIREV,'(6X,I6,10(1PE18.10))')
     *
     *     NUSEGA,(SEPWID(IUSEGA),IUSEGA=1,NUSEGA)
C
      WRITE(NFIREV,'(''SEPGAU'')')
      WRITE(NFIREV,'(6X,I6,10(1PE18.10))')
     *
     *     NUSEGA,(SEPGAU(IUSEGA),IUSEGA=1,NUSEGA)
C
      WRITE(NFIREV,'(''SEPVCC'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *   ((SEPVCC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                          ,INSEPA=1,IRESEP)
C
      WRITE(NFIREV,'(''SEPVIC'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *   ((SEPVIC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                          ,INSEPA=1,IVISEP)
C
      WRITE(NFIREV,'(''SEPERR'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *   ((SEPERR(INSEPA,INFORC),INFORC=1,NDFORC)
     *                          ,INSEPA=1,IERSEP)
C
      WRITE(NFIREV,'(''SEPFAC'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *   ((SEPFAC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                          ,INSEPA=1,IFASEP)
C
      WRITE(NFIREV,'(''FSTSTR'')')
      WRITE(NFIREV,'((6X,2(1PE18.10)))')
     *
     *    (FSOSTR(1,INFORC),INFORC=1,NDFORC,2),
     *    (FTOSTR(1,INFORC),INFORC=1,NDFORC,2),
     *    (FTESTR(1,INFORC),INFORC=1,NDFORC,2)
C
      WRITE(NFIREV,'(''FSTWID'')')
      WRITE(NFIREV,'((6X,1PE18.10))')
     *
     *     FSTWID(1)
C
      WRITE(NFIREV,'(''CMSXFC'')')
      WRITE(NFIREV,'(6X,3(1PE18.10))')
     *
     *      CMSXFC,CMSYFC,CMSZFC
C
      WRITE(NFIREV,'(''XMOMFC'')')
      WRITE(NFIREV,'(6X,3(1PE18.10))')
     *
     *      XMOMFC,YMOMFC,ZMOMFC
C
      WRITE(NFIREV,'(''HBAROX'')')
      WRITE(NFIREV,'(6X,3(1PE18.10))')
     *
     *      (HBAROX(LTWCEN),HBAROY(LTWCEN),HBAROZ(LTWCEN),
     *                                                  LTWCEN=1,ITWCEN)
C
      WRITE(NFIREV,'(''HOMSCA'')')
      WRITE(NFIREV,'(6X,3(1PE18.10))')
     *
     *     ((HOMSCA(KARTEZ,LTWCEN),KARTEZ=1,NDKART),LTWCEN=1,ITWCEN)
C
      WRITE(NFIREV,'(''HOMLTH'')')
      WRITE(NFIREV,'(6X,3(1PE18.10))')
     *
     *     ((1.0D0/HOMSCA(KARTEZ,LTWCEN),KARTEZ=1,NDKART)
     *                                                 ,LTWCEN=1,ITWCEN)
C
      WRITE(NFIREV,'(''NXHERM'')')
      WRITE(NFIREV,'(6X,3I6)')
     *
     *      NXHERM,NYHERM,NZHERM

      WRITE(NFIREV,'(''NXMAXX'')')
      WRITE(NFIREV,'(6X,3I6)')
     *
     *      (NXMAXV(LTWCEN),NYMAXV(LTWCEN),NZMAXV(LTWCEN)
     *                                                 ,LTWCEN=1,ITWCEN)
C
      WRITE(NFIREV,'(''CENCOR'')')
      WRITE(NFIREV,'(6X,3(1PE18.10))')
     *
     *     ((CENCOR(KARTEZ,LTWCEN),KARTEZ=1,NDKART),LTWCEN=1,ITWCEN)
C
      WRITE(NFIREV,'(''EPSHER'')')
      WRITE(NFIREV,'(6X,3(1PE18.10))')
     *
     *      EPSHER
C
      WRITE(NFIREV,'(''ICOMIX'')')
      WRITE(NFIREV,'(6X,4I6,1PE18.10)')
     *
     *      ICOMIX,INLKER,INRKER,
     *      ICMPRI,EPSMIX
C
      WRITE(NFIREV,'(''IN_EXC'')')
      WRITE(NFIREV,'(6X,21I6)')
     *
     *      ND_EXC,IN_EXC
C
      WRITE(NFIREV,'(''INCONF'')')
      WRITE(NFIREV,'(6X,21I6)')
     *
     *      ILCONF,(INCONF(I),I=1,ILCONF)
C
      WRITE(NFIREV,'(''MICONF'')')
      WRITE(NFIREV,'(6X,21I6)')
     *
     *      MIXNUM,(MICONF(I),I=1,MIXNUM)
C
      WRITE(NFIREV,'(''NEWWIG'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      NEWWIG
C
      WRITE(NFIREV,'(''ISOADD'')')
      WRITE(NFIREV,'(6X,2I6)')
     *
     *      ISOADD,NBTKNT
C
      WRITE(NFIREV,'(''HOMEGA'')')
      WRITE(NFIREV,'(6X,5(1PE18.10))')
     *
     *      HOMEGA,FCHOM0,ENECUT,CVOLFC,R0PARM
C
      WRITE(NFIREV,'(''ISOTRO'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      ISOTRO
C
      WRITE(NFIREV,'(''NUMCOU'')')
      WRITE(NFIREV,'(6X,2I6,6X,1PE18.10)')
     *
     *      NUMCOU,NUMETA,FURMAX
C
      WRITE(NFIREV,'(''COULOM'')')
      WRITE(NFIREV,'(6X,3I6)')
     *
     *      ICOTYP,ICOUDI,ICOUEX
C
      WRITE(NFIREV,'(''YUKAWA'')')
      WRITE(NFIREV,'(6X,I6,6X,2(1PE18.10),6X,I6,6X,4(1PE18.10))')
     *
     *      I_YUKA,PIMASS,PNMASS,IYUTYP,
     *      YUKAGT,YUKAG0,YUKAG1,YUKAG2
C
      WRITE(NFIREV,'(''GOGENE'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      I_GOGA
C
      WRITE(NFIREV,'(''GOGPAI'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      IGOGPA
C
      WRITE(NFIREV,'(''REGUL.'')')
      WRITE(NFIREV,'(6X,2I6)')
     *
     *      I_REGA,N3LORD
C
      WRITE(NFIREV,'(''REGPAI'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      IREGPA
C
      WRITE(NFIREV,'(''COUL..'')')
      WRITE(NFIREV,'(6X,2I6)')
     *
     *      I_COUA,ICOUPA
C
      WRITE(NFIREV,'(''SEPAR.'')')
      WRITE(NFIREV,'(6X,2I6)')
     *
     *      I_SEPA,N3SERD
C
      WRITE(NFIREV,'(''SEPPAI'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      ISEPPA
C
      WRITE(NFIREV,'(''FSTMF.'')')
      WRITE(NFIREV,'(6X,4I6)')
     *
     *      (I_FSTA(I),I=1,NDFSTA)
C
      WRITE(NFIREV,'(''FSTPAI'')')
      WRITE(NFIREV,'(6X,4I6)')
     *
     *      (IFSTPA(I),I=1,NDFSTA)
C
      WRITE(NFIREV,'(''IDOTHC'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      IDOTHC
C
      WRITE(NFIREV,'(''NULAST'')')
      WRITE(NFIREV,'(6X,I6,12X,1PE18.10)')
     *
     *      NULAST,EPSITE
C
      WRITE(NFIREV,'(''NUCONS'')')
      WRITE(NFIREV,'(6X,I6,12X,1PE18.10)')
     *
     *      NUCONS,EPSCON
C
      WRITE(NFIREV,'(''NUCHAO'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      NUCHAO
C
      WRITE(NFIREV,'(''IPOTHO'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      IPOTHO
C
      WRITE(NFIREV,'(''NILXYZ'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      NILXYZ
C
      WRITE(NFIREV,'(''IQUNIL'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      IQUNIL
C
      WRITE(NFIREV,'(''NUPING'')')
      WRITE(NFIREV,'(6X,I6,12X,1PE18.10)')
     *
     *      NUPING,EPSPNG
C
      WRITE(NFIREV,'(''IFLIPI'')')
      WRITE(NFIREV,'(6X,6I6)')
     *
     *      ICHFLI,IPAFLI,IREFLI,
     *      ISPFLI,ISHFLI,IFLIPI
C
      WRITE(NFIREV,'(''N_FLIG'')')
      WRITE(NFIREV,'((6X,3(I6,3I4)))')
     *
     *   (((NPFLIG(IPARIT,IREVER,ICHARG),IREVER=0,NDREVE),
     *                                   IPARIT=0,NDPARI),
     *    ((NHFLIG(IPARIT,IREVER,ICHARG),IREVER=0,NDREVE),
     *                                   IPARIT=0,NDPARI),
     *    ((NOFLIG(IPARIT,IREVER,ICHARG),IREVER=0,NDREVE),
     *                                   IPARIT=0,NDPARI),
     *                                   ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''N_FLIM'')')
      WRITE(NFIREV,'((6X,3(I6,I4,8X)))')
     *
     *    ((NPFLIM(IREVER,ICHARG),IREVER=0,NDREVE),
     *     (NHFLIM(IREVER,ICHARG),IREVER=0,NDREVE),
     *     (NOFLIM(IREVER,ICHARG),IREVER=0,NDREVE),ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''N_FLIQ'')')
      WRITE(NFIREV,'((6X,3(I6,I4,8X)))')
     *
     *    ((NPFLIQ(IPARIT,ICHARG),IPARIT=0,NDPARI),
     *     (NHFLIQ(IPARIT,ICHARG),IPARIT=0,NDPARI),
     *     (NOFLIQ(IPARIT,ICHARG),IPARIT=0,NDPARI),ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''N_FLIZ'')')
      WRITE(NFIREV,'((6X,3(I6,8X)))')
     *
     *     (NPFLIZ(ICHARG),
     *      NHFLIZ(ICHARG),
     *      NOFLIZ(ICHARG),ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''N_MLIG'')')
      WRITE(NFIREV,'((6X,3(I6,3I4)))')
     *
     *    ((NPMLIG(IPARIT,IREVER),IREVER=0,NDREVE),
     *                            IPARIT=0,NDPARI),
     *    ((NHMLIG(IPARIT,IREVER),IREVER=0,NDREVE),
     *                            IPARIT=0,NDPARI),
     *    ((NOMLIG(IPARIT,IREVER),IREVER=0,NDREVE),
     *                            IPARIT=0,NDPARI)
C
      WRITE(NFIREV,'(''N_MLIM'')')
      WRITE(NFIREV,'((6X,3(I6,I4,8X)))')
     *
     *     (NPMLIM(IREVER),IREVER=0,NDREVE),
     *     (NHMLIM(IREVER),IREVER=0,NDREVE),
     *     (NOMLIM(IREVER),IREVER=0,NDREVE)
C
      WRITE(NFIREV,'(''N_MLIQ'')')
      WRITE(NFIREV,'((6X,3(I6,I4,8X)))')
     *
     *     (NPMLIQ(IPARIT),IPARIT=0,NDPARI),
     *     (NHMLIQ(IPARIT),IPARIT=0,NDPARI),
     *     (NOMLIQ(IPARIT),IPARIT=0,NDPARI)
C
      WRITE(NFIREV,'(''N_MLIZ'')')
      WRITE(NFIREV,'((6X,3(I6,8X)))')
     *
     *      NPMLIZ,
     *      NHMLIZ,
     *      NOMLIZ
C
      WRITE(NFIREV,'(''N_FILG'')')
      WRITE(NFIREV,'((6X,3(I6,3I4)))')
     *
     *   (((NPFILG(IPARIT,IREVER,ICHARG),IREVER=0,NDREVE),
     *                                   IPARIT=0,NDPARI),
     *    ((NHFILG(IPARIT,IREVER,ICHARG),IREVER=0,NDREVE),
     *                                   IPARIT=0,NDPARI),
     *    ((NOFILG(IPARIT,IREVER,ICHARG),IREVER=0,NDREVE),
     *                                   IPARIT=0,NDPARI),
     *                                   ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''N_FILZ'')')
      WRITE(NFIREV,'((6X,3(I6,8X)))')
     *
     *     (NPFILZ(ICHARG),
     *      NHFILZ(ICHARG),
     *      NOFILZ(ICHARG),ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''SLOWEV'')')
      WRITE(NFIREV,'(6X,4(1PE18.10))')
     *
     *      SLOWEV,SLOWOD,SLOWPA,SLOWLI
C
      WRITE(NFIREV,'(''SLOWLD'')')
      WRITE(NFIREV,'(6X,4(1PE18.10))')
     *
     *      SLOWLD,SLOWTP,SLOWRP,SLOWLM
C
      WRITE(NFIREV,'(''SLOWAL'')')
      WRITE(NFIREV,'(6X,I6,1PE18.10)')
     *
     *      I_SLOW,SLOWAL
C
      WRITE(NFIREV,'(''OMEGAY'')')
      WRITE(NFIREV,'(6X,2(1PE18.10))')
     *
     *      OMEGAY,OMISOY
C
      WRITE(NFIREV,'(''OMEXYZ'')')
      WRITE(NFIREV,'(6X,3(1PE18.10),I6)')
     *
     *      OMEGAX,OMEGAY,OMEGAZ,ITILAX
C
      WRITE(NFIREV,'(''OMOXYZ'')')
      WRITE(NFIREV,'(6X,3(1PE18.10),I6)')
     *
     *      OMOVAX,OMOVAY,OMOVAZ,IMOVAX
C
      WRITE(NFIREV,'(''OMIXYZ'')')
      WRITE(NFIREV,'(6X,3(1PE18.10),I6)')
     *
     *      OMISOX,OMISOY,OMISOZ,ITISAX
C
      WRITE(NFIREV,'(''NO_ORB'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      NO_ORB
C
      WRITE(NFIREV,'(''ALPHA'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      LAMMAX
      WRITE(NFIREV,'((6X,2('' ('',1PE16.8,'','',1PE16.8,'')'')))')
     *
     *      ((ALPHAC(L,M),M=-L,+L),L=0,LAMMAX)
C
C
      WRITE(NFIREV,'(''CCPALL'')')
      WRITE(NFIREV,'((6X,2(1PE18.10)))')
     *
     *      (CCPALL(I),I=1,NDCOUT)
C
      WRITE(NFIREV,'(''DCPALL'')')
      WRITE(NFIREV,'((6X,2(1PE18.10)))')
     *
     *      (DCPALL(I),I=1,NDCOUT)
C
      WRITE(NFIREV,'(''ECPALL'')')
      WRITE(NFIREV,'((6X,2(1PE18.10)))')
     *
     *      (ECPALL(I),I=1,NDCOUT)
C
      WRITE(NFIREV,'(''CCPPAI'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *      PRHO_N,PRHODN,PRHOSN,POWERN,
     *      PRHO_P,PRHODP,PRHOSP,POWERP
C
      WRITE(NFIREV,'(''ENEGOG'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *    ((REAL(EGOGSD(ICHAR1,ICHAR2)),
     *      REAL(EGOGSE(ICHAR1,ICHAR2)),
     *      REAL(EGOGVD(ICHAR1,ICHAR2)),
     *      REAL(EGOGVE(ICHAR1,ICHAR2)),ICHAR1=0,NDISOS),
     *                                  ICHAR2=0,NDISOS),
     *
     *      REAL(EGOTSD),REAL(EGOTSE),REAL(EGOTVD),REAL(EGOTVE),
     *      REAL(EGOSSD),REAL(EGOSSE),REAL(EGOSVD),REAL(EGOSVE),
     *      REAL(EGOPSD),REAL(EGOPSE),REAL(EGOPVD),REAL(EGOPVE),
     *      REAL(EGOMSD),REAL(EGOMSE),REAL(EGOMVD),REAL(EGOMVE),
     *
     *      EGOGDT,EGOGET,EGOGDT+EGOGET,EGOGPT
C
      WRITE(NFIREV,'(''ENEREG'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *    ((REAL(EREGSD(ICHAR1,ICHAR2)),
     *      REAL(EREGSE(ICHAR1,ICHAR2)),
     *      REAL(EREGVD(ICHAR1,ICHAR2)),
     *      REAL(EREGVE(ICHAR1,ICHAR2)),ICHAR1=0,NDISOS),
     *                                  ICHAR2=0,NDISOS),
     *
     *      REAL(ERETSD),REAL(ERETSE),REAL(ERETVD),REAL(ERETVE),
     *      REAL(ERESSD),REAL(ERESSE),REAL(ERESVD),REAL(ERESVE),
     *      REAL(EREPSD),REAL(EREPSE),REAL(EREPVD),REAL(EREPVE),
     *      REAL(EREMSD),REAL(EREMSE),REAL(EREMVD),REAL(EREMVE),
     *
     *      EREGDT,EREGET,EREGDT+EREGET,EREGPT
C
      WRITE(NFIREV,'(''PAIREG'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *     (REAL(EREGSP(ICHARG)),REAL(EREGVP(ICHARG)),ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''ENESEP'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *    ((REAL(ESEPSD(ICHAR1,ICHAR2)),
     *      REAL(ESEPSE(ICHAR1,ICHAR2)),
     *      REAL(ESEPVD(ICHAR1,ICHAR2)),
     *      REAL(ESEPVE(ICHAR1,ICHAR2)),ICHAR1=0,NDISOS),
     *                                  ICHAR2=0,NDISOS),
     *
     *      REAL(ESPTSD),REAL(ESPTSE),REAL(ESPTVD),REAL(ESPTVE),
     *      REAL(ESPSSD),REAL(ESPSSE),REAL(ESPSVD),REAL(ESPSVE),
     *      REAL(ESPPSD),REAL(ESPPSE),REAL(ESPPVD),REAL(ESPPVE),
     *      REAL(ESPMSD),REAL(ESPMSE),REAL(ESPMVD),REAL(ESPMVE),
     *
     *      ESEPDT,ESEPET,ESEPDT+ESEPET,ESEPPT
C
      WRITE(NFIREV,'(''PAISEP'')')
      WRITE(NFIREV,'((6X,4(1PE18.10)))')
     *
     *     (REAL(ESEPSP(ICHARG)),REAL(ESEPVP(ICHARG)),ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''SYMETR'')')
      WRITE(NFIREV,'(6X,8I6)')
     *
     *      ISIGNY,ISIMTX,ISIMTZ,ISIMPY,IPARTY,ISIQTY,JSIMTY,ISPHER
C
      WRITE(NFIREV,'(''ITESTA'')')
      WRITE(NFIREV,'(6X,4I6)')
     *
     *      ITESTA,ITESTO,NOITER,NUMITE
C
      WRITE(NFIREV,'(''CONFIN'')')
      WRITE(NFIREV,'(6X,3I6)')
     *
     *      IS_YES,IS_PIN,IS_CHA
C
      WRITE(NFIREV,'(''CONVER'')')
      WRITE(NFIREV,'((6X,I6,6(1PE18.10)))')
     *
     *      (ITESTA-1+I,ETOTFI(I),ETOTSI(I),ESTABI(I),
     *                  QUA20I(I),QUA22I(I),
     *                  ANGUTI(I),I=1,NUMITE-ITESTA+1)
C
      WRITE(NFIREV,'(''RMSRAD'')')
      WRITE(NFIREV,'((6X,I6,6X,3(1PE18.10)))')
     *
     *     (KARTEZ,RADI_N(KARTEZ),RADI_P(KARTEZ),RADI_T(KARTEZ),
     *                                                  KARTEZ=0,NDKART)
C
      WRITE(NFIREV,'(''RMSRAH'')')
      WRITE(NFIREV,'((6X,I6))') NRAORD
      WRITE(NFIREV,'((6X,I6,6X,3(1PE18.10)))')
     *
     *     (NUMORD,RMSRAN(NUMORD),RMSRAP(NUMORD),RMSRAT(NUMORD),
     *                                                  NUMORD=1,NRAORD)
C
      WRITE(NFIREV,'(''SHIRAD'')')
      WRITE(NFIREV,'((6X,I6,6X,3(1PE18.10)))')
     *
     *     (KARTEZ,RSHI_N(KARTEZ),RSHI_P(KARTEZ),RSHI_T(KARTEZ),
     *                                                  KARTEZ=0,NDKART)
C
      WRITE(NFIREV,'(''SHIFT_'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *     (RSHIFT(KARTEZ),KARTEZ=1,NDKART)
C
      WRITE(NFIREV,'(''EULER_'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *      ALPEUL,BETEUL,GAMEUL
C
      WRITE(NFIREV,'(''REULER'')')
      WRITE(NFIREV,'((6X,3(1PE18.10),I6))')
     *
     *      ALPINI,BETINI,GAMINI,INIROT
C
      WRITE(NFIREV,'(''INIINV'')')
      WRITE(NFIREV,'((6X,2I6))')
     *
     *      INIINV,INIKAR
C
      WRITE(NFIREV,'(''IKEINV'')')
      WRITE(NFIREV,'((6X,2I6))')
     *
     *      IKEINV,IKEKAR
C
      WRITE(NFIREV,'(''ISCHIF'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      ISCHIF
C
      WRITE(NFIREV,'(''NUMRED'')')
      WRITE(NFIREV,'(6X,4I6)')
     *
     *      NMURED,NMARED,NSIRED,NASRED
C
      WRITE(NFIREV,'(''GYROSC'')')
      WRITE(NFIREV,'((6X,3(1PE18.10),I6))')
     *
     *      GYRORP,GYRSPN,GYRSPP,IGYROS
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.06A) AND (3.10K), SAVING OF THE
C                    DATA UNDER KEYWORD 'GYROSC' IN SUBROUTINE  'REVIEW'
C                    WAS  CORRUPTING  THE  DATA  SAVED   UNDER   KEYWORD
C                    'QMULTI'. THIS BUG WAS CORRECTED ON  10/02/2022  IN
C                    VERSION (3.10L).
C=======================================================================
C
      WRITE(NFIREV,'(''GYR2BC'')')
      WRITE(NFIREV,'((6X,2(1PE18.10),I6))')
     *
     *      GIN2BC,GSA2BC,IGY2BC
C
      WRITE(NFIREV,'(''MAG2BC'')')
      WRITE(NFIREV,'(6X,5I6)')
     *
     *      MAG2BC
C
      WRITE(NFIREV,'(''GYRANL'')')
      WRITE(NFIREV,'((6X,2(1PE18.10),I6))')
     *
     *      GJ2ANL,GSQANL,IGYANL
C
      WRITE(NFIREV,'(''MAGANL'')')
      WRITE(NFIREV,'(6X,2I6)')
     *
     *      MAGANL
C
      WRITE(NFIREV,'(''QMULTI'')')
      WRITE(NFIREV,'(6X,17I6)')
     *
     *      NMUMAX,NMUCON,NMUCOU,NMUPRI,
     *      NSIMAX,NSICON,       NSIPRI,
     *      NMAMAX,NMACON,       NMAPRI,
     *      NMAORD,NRAORD,
     *      NASMAX,NASCON,       NASPRI,
     *      NASORD
C
      WRITE(NFIREV,'(''ICOUMA'')')
      WRITE(NFIREV,'(6X,2I6)')
     *
     *      ICOUMD,ICOUMX
C
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *      ((L,M,QMUL_N(L,M),QMUL_P(L,M),QMUL_T(L,M),M=0,L),L=0,NMUMAX)
C
      WRITE(NFIREV,'(''QMULT-'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,QMUL_N(L,M),QMUL_P(L,M),QMUL_T(L,M),M=-L,-1),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''QSHIMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,QSHI_N(L,M),QSHI_P(L,M),QSHI_T(L,M),M=-L,L),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''QROTMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,QROT_N(L,M),QROT_P(L,M),QROT_T(L,M),M=-L,L),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''BMULMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,BMUL_N(L,M),BMUL_P(L,M),BMUL_T(L,M),M=-L,L),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''BSHIMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,BSHI_N(L,M),BSHI_P(L,M),BSHI_T(L,M),M=-L,L),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''BROTMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,BROT_N(L,M),BROT_P(L,M),BROT_T(L,M),M=-L,L),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''SMULMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,SMUL_N(L,M),SMUL_P(L,M),SMUL_T(L,M),M=-L,L),L=1,NSIMAX)
C
      WRITE(NFIREV,'(''SSHIMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,SSHI_N(L,M),SSHI_P(L,M),SSHI_T(L,M),M=-L,L),L=1,NSIMAX)
C
      WRITE(NFIREV,'(''SROTMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,SROTNN(L,M),SROTNP(L,M),SROTNT(L,M),M=-L,L),L=1,NSIMAX)
C
      WRITE(NFIREV,'(''AMULMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,AMUL_N(L,M,0),AMUL_P(L,M,0),AMUL_T(L,M,0),M=-L,L),
     *                                                       L=1,NMAMAX)
C
      WRITE(NFIREV,'(''WMULMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,WMUL_N(L,M,0),WMUL_P(L,M,0),WMUL_T(L,M,0),M=-L,L),
     *                                                       L=1,NASMAX)
C
      WRITE(NFIREV,'(''AMULOR'')')
      WRITE(NFIREV,'((6X,3I6,3(1PE18.10)))')
     *
     *   (((L,M,K,AMUL_N(L,M,K),AMUL_P(L,M,K),AMUL_T(L,M,K),M=-L,L),
     *                                                      L=1,NMAMAX),
     *                                                      K=0,NMAORD)
C
      WRITE(NFIREV,'(''WMULOR'')')
      WRITE(NFIREV,'((6X,3I6,3(1PE18.10)))')
     *
     *   (((L,M,K,WMUL_N(L,M,K),WMUL_P(L,M,K),WMUL_T(L,M,K),M=-L,L),
     *                                                      L=1,NASMAX),
     *                                                      K=0,NASORD)
C
      WRITE(NFIREV,'(''ASHIMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,ASHI_N(L,M),ASHI_P(L,M),ASHI_T(L,M),M=-L,L),L=1,NMAMAX)
C
      WRITE(NFIREV,'(''AROTMO'')')
      WRITE(NFIREV,'((6X,2I6,3(1PE18.10)))')
     *
     *    ((L,M,AROTNN(L,M),AROTNP(L,M),AROTNT(L,M),M=-L,L),L=1,NMAMAX)
C
      WRITE(NFIREV,'(''QUNITS'')')
      WRITE(NFIREV,'((6X,2I6,1PE18.10))')
     *
     *      ((L,M,QUNITS(L,M),M=0,L),L=0,NMUMAX)
C
      WRITE(NFIREV,'(''SUNITS'')')
      WRITE(NFIREV,'((6X,2I6,1PE18.10))')
     *
     *      ((L,M,SUNITS(L,M),M=0,L),L=0,NSIMAX)
C
      WRITE(NFIREV,'(''VUNITS'')')
      WRITE(NFIREV,'((6X,2I6,1PE18.10))')
     *
     *      ((L,M,VUNITS(L,M),M=0,L),L=0,NSIMAX)
C
      WRITE(NFIREV,'(''AUNITS'')')
      WRITE(NFIREV,'((6X,2I6,1PE18.10))')
     *
     *      ((L,M,AUNITS(L,M),M=0,L),L=0,NMAMAX)
C
      WRITE(NFIREV,'(''BUNITS'')')
      WRITE(NFIREV,'((6X,2I6,1PE18.10))')
     *
     *      ((L,M,BUNITS(L,M),M=0,L),L=0,NASMAX)
C
      WRITE(NFIREV,'(''STIFFQ'')')
      WRITE(NFIREV,'((6X,2I6,2(1PE18.10),I6))')
     *
     *      ((L,M,STIFFQ(L,M),QASKED(L,M),IFLAGQ(L,M),M=0,L),L=0,NMUMAX)
C
      WRITE(NFIREV,'(''STIFFV'')')
      WRITE(NFIREV,'((6X,2I6,2(1PE18.10),I6))')
     *
     *    ((L,M,STIFFV(L,M),VASKED(L,M),IFLAGV(L,M),M=-L,+L),L=0,NMUMAX)
C
      WRITE(NFIREV,'(''STIFF-'')')
      WRITE(NFIREV,'((6X,2I6,2(1PE18.10),I6))')
     *
     *    ((L,M,STIFFQ(L,M),QASKED(L,M),IFLAGQ(L,M),M=-L,-1),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''STIFFS'')')
      WRITE(NFIREV,'((6X,2I6,2(1PE18.10),I6))')
     *
     *    ((L,M,STIFFS(L,M),SASKED(L,M),IFLAGS(L,M),M=-L,+L),L=0,NSIMAX)
C
      WRITE(NFIREV,'(''STIFFG'')')
      WRITE(NFIREV,'((6X,I6,2(1PE18.10),I6))')
     *
     *     (L,STIFFG(L),GASKED(L),IFLAGG(L),L=0,NMUMAX)
C
      WRITE(NFIREV,'(''QLINEA'')')
      WRITE(NFIREV,'((6X,2I6,2(1PE18.10),I6))')
     *
     *    ((L,M,GALMUQ(L,M),QLINEA(L,M),IFLALQ(L,M),M=-L,+L),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''VLINEA'')')
      WRITE(NFIREV,'((6X,2I6,2(1PE18.10),I6))')
     *
     *    ((L,M,GALMUV(L,M),VLINEA(L,M),IFLALV(L,M),M=-L,+L),L=1,NMUMAX)
C
      WRITE(NFIREV,'(''SLINEA'')')
      WRITE(NFIREV,'((6X,2I6,2(1PE18.10),I6))')
     *
     *    ((L,M,GALMUS(L,M),SLINEA(L,M),IFLALS(L,M),M=-L,+L),L=0,NSIMAX)
C
      WRITE(NFIREV,'(''PAIRNG'')')
      WRITE(NFIREV,'((6X,5(1PE18.10)))')
     *
     *      GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N,
     *      GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
C
      WRITE(NFIREV,'(''FERFIX'')')
      WRITE(NFIREV,'((6X,2(1PE18.10),2I6))')
     *
     *      FERFIN,FERFIP,IFEFIN,IFEFIP
C
      WRITE(NFIREV,'(''FERALM'')')
      WRITE(NFIREV,'((6X,2(1PE18.10),2I6))')
     *
     *      FERALN,FERALP,IFERAN,IFERAP
C
      WRITE(NFIREV,'(''NUQEVE'')')
      WRITE(NFIREV,'((6X,I6))')
     *
     *      NUQEVE
C
      WRITE(NFIREV,'(''FE2FIX'')')
      WRITE(NFIREV,'((6X,2(1PE18.10),2I6))')
     *
     *      FE2FIN,FE2FIP,IF2FIN,IF2FIP
C
      WRITE(NFIREV,'(''DELFIX'')')
      WRITE(NFIREV,'((6X,2(1PE18.10),2I6))')
     *
     *      DELFIN,DELFIP,IDEFIN,IDEFIP
C
      WRITE(NFIREV,'(''SIGBLO'')')
      WRITE(NFIREV,'(6X,8I6)')
     *
     *      INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *      INSIGP,IPSIGP,ISSIGP,IDSIGP
C
      WRITE(NFIREV,'(''SIMBLO'')')
      WRITE(NFIREV,'(6X,6I6)')
     *
     *      INSIMN,IRSIMN,IDSIMN,
     *      INSIMP,IRSIMP,IDSIMP
C
      WRITE(NFIREV,'(''SIQBLO'')')
      WRITE(NFIREV,'(6X,6I6)')
     *
     *     (INSIQN(NUBLOC),IPSIQN(NUBLOC),IDSIQN(NUBLOC),
     *      INSIQP(NUBLOC),IPSIQP(NUBLOC),IDSIQP(NUBLOC),
     *                                                  NUBLOC=1,NDBLOC)
C
      WRITE(NFIREV,'(''SIZBLO'')')
      WRITE(NFIREV,'(6X,4I6)')
     *
     *     (INSIZN(NUBLOC),IDSIZN(NUBLOC),
     *      INSIZP(NUBLOC),IDSIZP(NUBLOC),NUBLOC=1,NDBLOC)
C
      WRITE(NFIREV,'(''INIBLO'')')
      WRITE(NFIREV,'(6X,4I6)')
     *
     *      IFIBLN,INIBLN,
     *      IFIBLP,INIBLP
C
      WRITE(NFIREV,'(''BLOALI'')')
      WRITE(NFIREV,'(6X,6I6)')
     *
     *      NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,LASTAN,
     *      NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,LASTAP
C
      WRITE(NFIREV,'(''IAXIAP'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      IAXIAP
C
      WRITE(NFIREV,'(''KAPASY'')')
      WRITE(NFIREV,'(6X,I6)')
     *
     *      KAPASY
C
      WRITE(NFIREV,'(''CUTOFF'')')
      WRITE(NFIREV,'(6X,1PE18.10,4I6)')
     *
     *      ECUTOF,LIMQUA,LAMCUT
C
      WRITE(NFIREV,'(''CUSIZ '')')
      WRITE(NFIREV,'(6X,2I6)')
     *
     *      NCUSIZ
C
      WRITE(NFIREV,'(''CUSIQ '')')
      WRITE(NFIREV,'(6X,4I6)')
     *
     *      NCUSIQ
C
      WRITE(NFIREV,'(''PAIINI'')')
      WRITE(NFIREV,'((6X,6(1PE18.10)))')
     *
     *      (FERINI(ICHARG),ICHARG=0,NDISOS),
     *      (DELINI(ICHARG),ICHARG=0,NDISOS),
     *      (FE2INI(ICHARG),ICHARG=0,NDISOS)
C
      WRITE(NFIREV,'(''ENERGY'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                EKIN_N,EKIN_P,EKIN_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *
     *                ECOULD,ECOULE,ECOULT,
     *
     *                EMULCO,EMUSLO,EMUREA,
     *                ESPICO,ESPSLO,ESPREA,
     *
     *                              ENREAR
C
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
C
      WRITE(NFIREV,'(''E_TENS'')')
      WRITE(NFIREV,'((6X,2(1PE18.10)))')
     *
     *                ETEVEN,ETEODD,
     *                ETOVEN,ETOODD
C
      WRITE(NFIREV,'(''E3BODY'')')
      WRITE(NFIREV,'((6X,2(1PE18.10)))')
     *
     *                REAL(E3BEVE),REAL(E3BODD)
C
      WRITE(NFIREV,'(''E4BODY'')')
      WRITE(NFIREV,'((6X,2(1PE18.10)))')
     *
     *                REAL(E4BEVE),REAL(E4BODD)
C
      WRITE(NFIREV,'(''ECOULE'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                ECOULS,ECOULV,ECOULE
C
      WRITE(NFIREV,'(''ENEISO'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                EISOCO,EISSLO,EISREA
C
      WRITE(NFIREV,'(''ECORCM'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                ECORCM
C
      WRITE(NFIREV,'(''ECOR_R'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                ECOR_R
C
      WRITE(NFIREV,'(''ESIFCO'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                ESIFCO,ESISLO,ESIREA
C
      WRITE(NFIREV,'(''P-REAR'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                EREA_N,EREA_P,EREA_T
C
      WRITE(NFIREV,'(''LIPKIN'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                ELIP_N,ELIP_P,ELIP_T
C
      WRITE(NFIREV,'(''POTIAL'')')
      WRITE(NFIREV,'((6X,3(1PE18.10)))')
     *
     *                EPOT_N,EPOT_P,EPOT_T
C
      WRITE(NFIREV,'(''ANGSPI'')')
      WRITE(NFIREV,'(3((6X,1PE18.10)))')
     *
     *      ANGU_N(2),ANGU_P(2),ANGU_T(2),
     *      SPIN_N(2),SPIN_P(2),SPIN_T(2),
     *
     *      ANGU_N(1),ANGU_P(1),ANGU_T(1),
     *      SPIN_N(1),SPIN_P(1),SPIN_T(1),
     *
     *      ANGU_N(3),ANGU_P(3),ANGU_T(3),
     *      SPIN_N(3),SPIN_P(3),SPIN_T(3)
C
      WRITE(NFIREV,'(''SHISPI'')')
      WRITE(NFIREV,'((6X,I6,6X,3(1PE18.10)))')
     *
     *     (KARTEZ,ANGS_N(KARTEZ),ANGS_P(KARTEZ),ANGS_T(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
C
      WRITE(NFIREV,'(''LINEMO'')')
      WRITE(NFIREV,'((6X,I6,6X,3(1PE18.10)))')
     *
     *     (KARTEZ,ALINLN(KARTEZ),ALINLP(KARTEZ),ALINLT(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
     *     ,   0  ,ALINLN(   0  ),ALINLP(   0  ),ALINLT(   0  ),
     *
     *     (KARTEZ,DLINSN(KARTEZ),DLINSP(KARTEZ),DLINST(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
     *     ,   0  ,DLINSN(   0  ),DLINSP(   0  ),DLINST(   0  ),
     *
     *     (KARTEZ,ELINSN(KARTEZ),ELINSP(KARTEZ),ELINST(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
     *     ,   0  ,ELINSN(   0  ),ELINSP(   0  ),ELINST(   0  ),
     *
     *     (KARTEZ,TLINSN(KARTEZ),TLINSP(KARTEZ),TLINST(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
     *     ,   0  ,TLINSN(   0  ),TLINSP(   0  ),TLINST(   0  )
C
      WRITE(NFIREV,'(''ROTAMO'')')
      WRITE(NFIREV,'((6X,I6,6X,3(1PE18.10)))')
     *
     *     (KARTEZ,AROTLN(KARTEZ),AROTLP(KARTEZ),AROTLT(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
     *     ,   0  ,AROTLN(   0  ),AROTLP(   0  ),AROTLT(   0  ),
     *
     *     (KARTEZ,DROTSN(KARTEZ),DROTSP(KARTEZ),DROTST(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
     *     ,   0  ,DROTSN(   0  ),DROTSP(   0  ),DROTST(   0  ),
     *
     *     (KARTEZ,EROTSN(KARTEZ),EROTSP(KARTEZ),EROTST(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
     *     ,   0  ,EROTSN(   0  ),EROTSP(   0  ),EROTST(   0  ),
     *
     *     (KARTEZ,TROTSN(KARTEZ),TROTSP(KARTEZ),TROTST(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
     *     ,   0  ,TROTSN(   0  ),TROTSP(   0  ),TROTST(   0  )
C
      WRITE(NFIREV,'(''STIFFI'')')
      WRITE(NFIREV,'(6X,2(1PE18.10),I6)')
     *
     *      STIFFI(2),ASKEDI(2),IFLAGI(2)
C
      WRITE(NFIREV,'(''STIFFA'')')
      WRITE(NFIREV,'(6X,2(1PE18.10),I6)')
     *
     *      STIFFA,ASKEDA,IFLAGA
C
      WRITE(NFIREV,'(''STIF3D'')')
      WRITE(NFIREV,'((6X,I6,6X,2(1PE18.10),I6))')
     *
     *      (KARTEZ,STIFFI(KARTEZ),ASKEDI(KARTEZ),IFLAGI(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
C
      WRITE(NFIREV,'(''STIF3T'')')
      WRITE(NFIREV,'((6X,I6,6X,2(1PE18.10),I6))')
     *
     *      (KARTEZ,STIFTI(KARTEZ),ASKETI(KARTEZ),IFTAGI(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
C
      WRITE(NFIREV,'(''STIFFT'')')
      WRITE(NFIREV,'((6X,I6,6X,2(1PE18.10),I6))')
     *
     *      (KARTEZ,STIFFT(KARTEZ),ASKEDT(KARTEZ),IFLAGT(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
C
      WRITE(NFIREV,'(''DALSPI'')')
      WRITE(NFIREV,'((6X,I6,6X,2(1PE18.10),I6))')
     *
     *      (KARTEZ,GALSPI(KARTEZ),DALSPI(KARTEZ),IFLALI(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
C
      WRITE(NFIREV,'(''DALISO'')')
      WRITE(NFIREV,'((6X,I6,6X,2(1PE18.10),I6))')
     *
     *      (KARTEZ,GALISO(KARTEZ),DALISO(KARTEZ),IFLALT(KARTEZ),
     *                                                  KARTEZ=1,NDKART)
C
      WRITE(NFIREV,'(''NUMBSP'')')
      WRITE(NFIREV,'(6X,5I6)')
     *
     *      MREVER,((NUMBSP(IREVER,ICHARG),ICHARG=0,NDISOS),
     *                                     IREVER=0,MREVER)
C
      WRITE(NFIREV,'(''CONFIG'')')
C
      DO ICHARG=0,NDISOS
         DO IREVER=0,MREVER
            DO IPARIT=0,NDPARI
C
               WRITE(NFIREV,'((6X,3I6,3X,100(50I2,/,24X)))')
     *
     *         ICHARG,IREVER,IPARIT,(N_OCCU(I,IPARIT,IREVER,ICHARG),
     *                                    I=1,NUMBSP(IREVER,ICHARG))
            END DO
         END DO
      END DO
C
      DO ICHARG=0,NDISOS
         DO IREVER=0,MREVER
            DO IPARIT=0,NDPARI
C
               WRITE(NFIREV,'((6X,3I6,3X,100(50I2,/,24X)))')
     *
     *         ICHARG,IREVER,IPARIT,(N_OCVA(I,IPARIT,IREVER,ICHARG),
     *                                    I=1,NUMBSP(IREVER,ICHARG))
            END DO
         END DO
      END DO
C
      WRITE(NFIREV,'(''CONFIM'')')
C
      DO ICHARG=0,NDISOS
         DO IREVER=0,MREVER
C
            WRITE(NFIREV,'((6X,2I6,9X,100(50I2,/,24X)))')
     *
     *            ICHARG,IREVER,(L_OCCU(I,IREVER,ICHARG),
     *                         I=1,NUMBSP(IREVER,ICHARG))
         END DO
      END DO
C
      DO ICHARG=0,NDISOS
         DO IREVER=0,MREVER
C
            WRITE(NFIREV,'((6X,2I6,9X,100(50I2,/,24X)))')
     *
     *            ICHARG,IREVER,(L_OCVA(I,IREVER,ICHARG),
     *                         I=1,NUMBSP(IREVER,ICHARG))
         END DO
      END DO
C
      WRITE(NFIREV,'(''CONFIQ'')')
C
      DO ICHARG=0,NDISOS
         DO IPARIT=0,NDPARI
C
            WRITE(NFIREV,'((6X,2I6,9X,100(50I2,/,24X)))')
     *
     *            ICHARG,IPARIT,(K_OCCU(I,IPARIT,ICHARG),
     *                         I=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG))
         END DO
      END DO
C
      DO ICHARG=0,NDISOS
         DO IPARIT=0,NDPARI
C
            WRITE(NFIREV,'((6X,2I6,9X,100(50I2,/,24X)))')
     *
     *            ICHARG,IPARIT,(K_OCVA(I,IPARIT,ICHARG),
     *                         I=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG))
         END DO
      END DO
C
      WRITE(NFIREV,'(''CONFIZ'')')
C
      DO ICHARG=0,NDISOS
C
         WRITE(NFIREV,'((6X,I6,9X,100(50I2,/,24X)))')
     *
     *         ICHARG,(M_OCCU(I,ICHARG),
     *             I=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG))
      END DO
C
      DO ICHARG=0,NDISOS
C
         WRITE(NFIREV,'((6X,I6,9X,100(50I2,/,24X)))')
     *
     *         ICHARG,(M_OCVA(I,ICHARG),
     *             I=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG))
      END DO
C
      WRITE(NFIREV,'(''COMMIG'')')
C
      DO IREVER=0,MREVER
         DO IPARIT=0,NDPARI
C
            WRITE(NFIREV,'((6X,2I6,3X,100(50I2,/,24X)))')
     *
     *      IREVER,IPARIT,(NMOCCU(I,IPARIT,IREVER),
     *                         I=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1))
         END DO
      END DO
C
      DO IREVER=0,MREVER
         DO IPARIT=0,NDPARI
C
            WRITE(NFIREV,'((6X,2I6,3X,100(50I2,/,24X)))')
     *
     *      IREVER,IPARIT,(NMOCVA(I,IPARIT,IREVER),
     *                  I=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1))
         END DO
      END DO
C
      WRITE(NFIREV,'(''COMMIM'')')
C
      DO IREVER=0,MREVER
C
         WRITE(NFIREV,'((6X,I6,9X,100(50I2,/,24X)))')
     *
     *         IREVER,(LMOCCU(I,IREVER),
     *              I=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1))
      END DO
C
      DO IREVER=0,MREVER
C
         WRITE(NFIREV,'((6X,I6,9X,100(50I2,/,24X)))')
     *
     *         IREVER,(LMOCVA(I,IREVER),
     *              I=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1))
      END DO
C
      WRITE(NFIREV,'(''COMMIQ'')')
C
      DO IPARIT=0,NDPARI
C
         WRITE(NFIREV,'((6X,I6,9X,100(50I2,/,24X)))')
     *
     *         IPARIT,(KMOCCU(I,IPARIT),
     *           I=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1))
      END DO
C
      DO IPARIT=0,NDPARI
C
         WRITE(NFIREV,'((6X,I6,9X,100(50I2,/,24X)))')
     *
     *         IPARIT,(KMOCVA(I,IPARIT),
     *           I=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1))
      END DO
C
      WRITE(NFIREV,'(''COMMIZ'')')
C
      WRITE(NFIREV,'((6X,9X,100(50I2,/,24X)))')
     *
     *      (MMOCCU(I),
     *          I=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1))
C
      WRITE(NFIREV,'((6X,9X,100(50I2,/,24X)))')
     *
     *      (MMOCVA(I),
     *          I=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1))
C
C=======================================================================
C
      IF (ABS(IREVIE).LE.1) RETURN
C
C=======================================================================
C
      WRITE(NFIREV,'(''SPENER'')')
      WRITE(NFIREV,'((6X,3I6,2(1PE18.10),2X,A13,2X,A10,2X,A15,
     *                       3(1PE18.10),
     *                       7(1PE14.6)))')
     *
     *      (((ICHARG,IREVER,I,SPENER(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPOCCU(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPORDE(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPKART(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPNILS(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPPARI(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPALIG(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPSPAL(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPMO20(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPMO22(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                        (SPSIZE(I+IREVER*NUMBSP(0,ICHARG),ICHARG,
     *                                                          KARTEZ),
     *                                KARTEZ=0,NDKART),
     *                         SPSIMP(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                       I=1,NUMBSP(IREVER,ICHARG)),
     *                IREVER=0,MREVER),
     *         ICHARG=0,NDISOS)
C
C=======================================================================
C
      IF (INUNIL.GT.0) THEN
C
          WRITE(NFIREV,'(''ALLNIL'')')
          WRITE(NFIREV,'((6X,I6))')
     *
     *    INUNIL
C
          DO ICHARG=0,NDISOS
             DO IREVER=0,MREVER
                DO I=1,NUMBSP(IREVER,ICHARG)
C
                   WRITE(NFIREV,'((6X,3I6,2E14.6,2X,F8.2,2X,
     *                                 99(I3,2X,A15,F8.2)))')
     *
     *             ICHARG,IREVER,I,
     *             SPENER(I+IREVER*NUMBSP(0,ICHARG),  ICHARG),
     *             SPZALI(I+IREVER*NUMBSP(0,ICHARG),  ICHARG),
     *             SPAMPN(I+IREVER*NUMBSP(0,ICHARG),  ICHARG),
     *          (J,SPNILA(I+IREVER*NUMBSP(0,ICHARG),J,ICHARG),
     *         100*SPAMPL(I+IREVER*NUMBSP(0,ICHARG),J,ICHARG)/
     *             SPAMPN(I+IREVER*NUMBSP(0,ICHARG)  ,ICHARG),
     *                                     J=1,MIN(INUNIL,99))
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      IF (IREVIE.EQ.-2) THEN
C
          WRITE(NFIREV,'(''QPENER'')')
          WRITE(NFIREV,'((6X,3I6,2(1PE18.10),2X,A13,
     *                       4(1PE18.10)))')
     *
     *      (((ICHARG,IREVER,I,QPENER(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                         QPOCCU(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                         QPORDD(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                         QPPARR(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                         QPEEQU(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                         QPDEQU(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                         QPCORR(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                       I=1,NUMBQP(IREVER,ICHARG)),
     *                IREVER=0,MREVER),
     *         ICHARG=0,NDISOS)
C
          IF (IQUNIL.EQ.1) THEN
C
              WRITE(NFIREV,'(''QPNILS'')')
              WRITE(NFIREV,'((6X,A15,2X,A9))')
     *
     *      (((ICHARG,IREVER,I,QPNILS(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                         QPNIL2(I+IREVER*NUMBQP(0,ICHARG),ICHARG),
     *                       I=1,NUMBQP(IREVER,ICHARG)),
     *                IREVER=0,MREVER),
     *         ICHARG=0,NDISOS)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ABS(IREVIE).LE.2) RETURN
C
C=======================================================================
C
      WRITE(NFIREV,'(''SPXZAL'')')
      WRITE(NFIREV,'((6X,3I6,4(1PE18.10)))')
     *
     *      (((ICHARG,IREVER,I,SPXALI(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPXSPI(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPZALI(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                         SPZSPI(I+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                       I=1,NUMBSP(IREVER,ICHARG)),
     *                IREVER=0,MREVER),
     *         ICHARG=0,NDISOS)
C
C=======================================================================
C
      IF (ABS(IREVIE).LE.3) RETURN
C
C=======================================================================
C
      WRITE(NFIREV,'(''PNENER'')')
      WRITE(NFIREV,'((6X,2I6,2(1PE18.10),2X,A13,2X,A10,2X,A15,
     *                       3(1PE18.10),
     *                       8(1PE14.6)))')
     *
     *       ((IREVER,I,PNENER(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNOCCU(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNORDE(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNKART(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNNILS(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNPARI(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNALIG(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNSPAL(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNMO20(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNMO22(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                 (PNSIZE(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),
     *          KARTEZ),
     * KARTEZ=0,NDKART),
     *                  PNSIMP(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNISOS(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                I=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)),
     *         IREVER=0,MREVER)
C
C=======================================================================
C
      IF (ABS(IREVIE).LE.4) RETURN
C
C=======================================================================
C
      WRITE(NFIREV,'(''PNXZAL'')')
      WRITE(NFIREV,'((6X,2I6,4(1PE18.10)))')
     *
     *       ((IREVER,I,PNXALI(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNXSPI(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNZALI(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNZSPI(I+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                I=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)),
     *         IREVER=0,MREVER)
C
C=======================================================================
C
      IF (ABS(IREVIE).LE.5) RETURN
C
C=======================================================================
C
      WRITE(NFIREV,'(''HRPNTX'')')
      WRITE(NFIREV,'((6X,10(1PE18.10)))')
     *     (FOURPT(IGAUSS,1),IGAUSS=1,NXHERM)

      WRITE(NFIREV,'(''HRPNTY'')')
      WRITE(NFIREV,'((6X,10(1PE18.10)))')
     *     (FOURPT(IGAUSS,2),IGAUSS=1,NYHERM)
C
      WRITE(NFIREV,'(''HRPNTZ'')')
      WRITE(NFIREV,'((6X,10(1PE18.10)))')
     *     (FOURPT(IGAUSS,3),IGAUSS=1,NZHERM)
C
C=======================================================================
C
      IF (ABS(IREVIE).LE.6) RETURN
C
C=======================================================================
C
      WRITE(NFIREV,'(''HRWETX'')')
      WRITE(NFIREV,'((6X,10(1PE18.10)))')
     *     (FOURWG(IGAUSS,1),IGAUSS=1,NXHERM)
C
      WRITE(NFIREV,'(''HRWETY'')')
      WRITE(NFIREV,'((6X,10(1PE18.10)))')
     *     (FOURWG(IGAUSS,2),IGAUSS=1,NYHERM)
C
      WRITE(NFIREV,'(''HRWETZ'')')
      WRITE(NFIREV,'((6X,10(1PE18.10)))')
     *     (FOURWG(IGAUSS,3),IGAUSS=1,NZHERM)
C
C=======================================================================
C
      IF (ABS(IREVIE).LE.7) RETURN
C
C=======================================================================
C
      WRITE(NFIREV,'(''DENSIT IX IY IZ'',
     * 5X,''X(FM)'',5X,''Y(FM)'',5X,''Z(FM)'',
     * 2(4(  5X,''D'',A1,''_'',A3,''(IX,IY,IZ)''                  ),
     *   3(9(3X,''D'',A1,''_'',A3,''(IX,IY,IZ,'',         I1,'')''),
     *     3(2(1X,''D'',A1,''_'',A3,''(IX,IY,IZ,'',I1,'','',I1,'')''))))
     *  ,3(  3X,''D'',A1,''_'',A3,''(IX,IY,IZ,'',         I1,'')'')
     *                                                               )')
     *
     *        (NEUPRO(ICHARG),'RHO',
     *         NEUPRO(ICHARG),'TAU',
     *         NEUPRO(ICHARG),'LPR',
     *         NEUPRO(ICHARG),'DIV',(
     *         NEUPRO(ICHARG),'SPI',K,
     *         NEUPRO(ICHARG),'ORB',K,
     *         NEUPRO(ICHARG),'KIS',K,
     *         NEUPRO(ICHARG),'GRR',K,
     *         NEUPRO(ICHARG),'LPS',K,
     *         NEUPRO(ICHARG),'ROS',K,
     *         NEUPRO(ICHARG),'ROC',K,
     *         NEUPRO(ICHARG),'CUR',K,
     *         NEUPRO(ICHARG),'KIF',K,(
     *         NEUPRO(ICHARG),'SCU',K,L,
     *         NEUPRO(ICHARG),'DES',K,L,
     *                                                      L=1,NDKART),
     *                                                   K=1,NDKART),
     *                                           ICHARG=0,NDISOS),(
     *                    'E','MAG',K,
     *                                                   K=1,NDKART)
C
      IF (ITWCEN.EQ.1) THEN
C
          DO IX=1,NXHERM
             DO IY=1,NYHERM
                DO IZ=1,NZHERM
C
C=======================================================================
C              ATTENTION: ONLY THE DENSITIES OF THE FIRST CENTER ARE
C                         PRINTED BELOW
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 3.04K AND  3.18U,  THE  TRUE-SPACE
C                    POSITIONS DEFINED IN  SUBROUTINE  "REVIEW"  IN  THE
C                    VARIABLES "POSIT." WERE INCORRECTLY DIVIDED BY  THE
C                    FACTOR OF SQRT(2), WHILE THIS  FACTOR  HAS  ALREADY
C                    BEEN INCLUDED IN ARRAYS  "FOURPT"  DEFINED IN ARRAY
C                    "PNTACT" OF SUBROUTINE "DEFINT" FOR NOBODY=2.  THIS
C                    BUG WAS CORRECTED IN VERSION 3.18V ON 19/05/2023.
C=======================================================================
C
                   POSITX=FOURPT(IX,1)/HOMSCA(1,1)
                   POSITY=FOURPT(IY,2)/HOMSCA(2,1)
                   POSITZ=FOURPT(IZ,3)/HOMSCA(3,1)
C
                   DE_MAG(:)=0
C
                   DO ICHARG=0,NDISOS
C
                      DE_ORB(1,ICHARG)=
     *                             POSITY*DE_CUR(IX,IY,IZ,3,ICHARG,1)
     *                            -POSITZ*DE_CUR(IX,IY,IZ,2,ICHARG,1)
                      DE_ORB(2,ICHARG)=
     *                             POSITZ*DE_CUR(IX,IY,IZ,1,ICHARG,1)
     *                            -POSITX*DE_CUR(IX,IY,IZ,3,ICHARG,1)
                      DE_ORB(3,ICHARG)=
     *                             POSITX*DE_CUR(IX,IY,IZ,2,ICHARG,1)
     *                            -POSITY*DE_CUR(IX,IY,IZ,1,ICHARG,1)
C
                      DO K=1,NDKART
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 3.14U AND 3.19F, THE MAGNETIZATION
C                    DENSITY "DE_MAG" WAS  PRINTED  USING  THE  "DE_SPI"
C                    ARRAYS, WHICH CONTAIN TWICE SPIN DENSITIES, THAT IS
C                    THE  FACTOR  OF  1/2  WAS  MISSING.  THIS  BUG  WAS
C                    CORRECTED IN VERSION 3.19G ON 20/06/2023.
C=======================================================================
C
                        DE_MAG(K)=DE_MAG(K)+
     *                     GESPIN(ICHARG)*DE_SPI(IX,IY,IZ,K,ICHARG,1)/2+
     *                     GEORBI(ICHARG)*DE_ORB(         K,ICHARG)
C
                      END DO
C
                   END DO
C
                   WRITE(NFIREV,'((6X,3I3,3F10.6,101(1PE21.10)))')
     *
     *         IX,IY,IZ,POSITX,POSITY,POSITZ,(
     *         REAL(DE_RHO(IX,IY,IZ,    ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_TAU(IX,IY,IZ,    ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_LPR(IX,IY,IZ,    ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_DIV(IX,IY,IZ,    ICHARG,1))*EXPAUX(IX,IY,IZ,1),(
     *         REAL(DE_SPI(IX,IY,IZ,K,  ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_ORB(         K,  ICHARG  ))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_KIS(IX,IY,IZ,K,  ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_GRR(IX,IY,IZ,K,  ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_LPS(IX,IY,IZ,K,  ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_ROS(IX,IY,IZ,K,  ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_ROC(IX,IY,IZ,K,  ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_CUR(IX,IY,IZ,K,  ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_KIF(IX,IY,IZ,K,  ICHARG,1))*EXPAUX(IX,IY,IZ,1),(
     *         REAL(DE_SCU(IX,IY,IZ,K,L,ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *         REAL(DE_DES(IX,IY,IZ,K,L,ICHARG,1))*EXPAUX(IX,IY,IZ,1),
     *                                                      L=1,NDKART),
     *                                                   K=1,NDKART),
     *                                           ICHARG=0,NDISOS),(
     *         REAL(DE_MAG(         K         ))*EXPAUX(IX,IY,IZ,1),
     *                                                   K=1,NDKART)
C
                END DO
             END DO
          END DO
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          DO IX=1,NXHERM
             DO IY=1,NYHERM
                DO IZ=1,NZHERM
C
                   POSITX=FOURPT(IX,1)*sqrt(2.0d0)
                   POSITY=FOURPT(IY,2)*sqrt(2.0d0)
                   POSITZ=FOURPT(IZ,3)*sqrt(2.0d0)
C
                   DE_MAG(:)=0
C
                   DO ICHARG=0,NDISOS
C
                      DE_ORB(1,ICHARG)=
     *                             POSITY*REVCUR(IX,IY,IZ,3,ICHARG)
     *                            -POSITZ*REVCUR(IX,IY,IZ,2,ICHARG)
                      DE_ORB(2,ICHARG)=
     *                             POSITZ*REVCUR(IX,IY,IZ,1,ICHARG)
     *                            -POSITX*REVCUR(IX,IY,IZ,3,ICHARG)
                      DE_ORB(3,ICHARG)=
     *                             POSITX*REVCUR(IX,IY,IZ,2,ICHARG)
     *                            -POSITY*REVCUR(IX,IY,IZ,1,ICHARG)
C
                      DO K=1,NDKART
C
                        DE_MAG(K)=DE_MAG(K)+
     *                     GESPIN(ICHARG)*REVSPI(IX,IY,IZ,K,ICHARG)/2+
     *                     GEORBI(ICHARG)*DE_ORB(         K,ICHARG)
C
                      END DO
C
                   END DO
C
                   WRITE(NFIREV,'((6X,3I3,3F10.6,101(1PE21.10)))')
     *
     *             IX,IY,IZ,POSITX,POSITY,POSITZ,(
     *             REAL(REVRHO(IX,IY,IZ,    ICHARG)),
     *             REAL(REVTAU(IX,IY,IZ,    ICHARG)),
     *             REAL(REVLPR(IX,IY,IZ,    ICHARG)),
     *             REAL(REVDIV(IX,IY,IZ,    ICHARG)),(
     *             REAL(REVSPI(IX,IY,IZ,K,  ICHARG)),
     *             REAL(DE_ORB(         K,  ICHARG)),
     *             REAL(REVKIS(IX,IY,IZ,K,  ICHARG)),
     *             REAL(REVGRR(IX,IY,IZ,K,  ICHARG)),
     *             REAL(REVLPS(IX,IY,IZ,K,  ICHARG)),
     *             REAL(REVROS(IX,IY,IZ,K,  ICHARG)),
     *             REAL(REVROC(IX,IY,IZ,K,  ICHARG)),
     *             REAL(REVCUR(IX,IY,IZ,K,  ICHARG)),
     *             REAL(REVKIF(IX,IY,IZ,K,  ICHARG)),(
     *             REAL(REVSCU(IX,IY,IZ,K,L,ICHARG)),
     *             REAL(REVDES(IX,IY,IZ,K,L,ICHARG)),
     *                  L=1,NDKART),K=1,NDKART),ICHARG=0,NDISOS),(
     *             REAL(DE_MAG(K)),K=1,NDKART)
C
                END DO
             END DO
          END DO
C
      END IF
C
      IF (ALLOCATED(REVRHO))  DEALLOCATE(REVRHO,REVTAU,REVLPR,REVDIV,
     *                                   REVKIS,REVGRR,REVLPS,REVROS,
     *                                   REVROC,REVCUR,REVKIF,REVSCU,
     *                                                 REVDES,REVSPI)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE IOCLOS(NFIWOO,NFIREP,NFIREV,NFIREC,NFICOU,NFIWAV,
     *                  NFIKER,NFIYUP,NFIYUC,NFIGOC,NFIGOP,NFIGPC,
     *                  NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *                  NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP)
C
      LOGICAL
     *          INCWOO,INCREP,INCREV,INCREC,INCCOU,INCWAV,INCKER,
     *          INCYUP,INCYUC,INCGOP,INCGOC,INCGPC,INCGPP,INCROP,
     *          INCROC,INCLIP,INCLIC,INCFIP,INCFIC,INCISO,INCQUA,
     *          INCRED,INCBAP,INCBAC
C
C=======================================================================
C      CHECK IF FILES ARE ALREADY OPENED. IF YES, CLOSE THEM FIRST
C      TO AVOID POSSIBLE CONFLICTS OF UNIT/FILENAME ALLOCATIONS.
C=======================================================================
C
      INCWOO=.FALSE.
      INCREP=.FALSE.
      INCREV=.FALSE.
      INCREC=.FALSE.
      INCCOU=.FALSE.
      INCWAV=.FALSE.
      INCKER=.FALSE.
      INCYUP=.FALSE.
      INCYUC=.FALSE.
      INCGOP=.FALSE.
      INCGOC=.FALSE.
      INCGPC=.FALSE.
      INCGPP=.FALSE.
      INCROP=.FALSE.
      INCROC=.FALSE.
      INCLIP=.FALSE.
      INCLIC=.FALSE.
      INCFIP=.FALSE.
      INCFIC=.FALSE.
      INCISO=.FALSE.
      INCQUA=.FALSE.
      INCRED=.FALSE.
C
      inquire(unit=NFIWOO,opened=INCWOO)
                             IF (INCWOO) CLOSE(NFIWOO)
      inquire(unit=NFIREP,opened=INCREP)
                             IF (INCREP) CLOSE(NFIREP)
      inquire(unit=NFIREV,opened=INCREV)
                             IF (INCREV) CLOSE(NFIREV)
      inquire(unit=NFIREC,opened=INCREC)
                             IF (INCREC) CLOSE(NFIREC)
      inquire(unit=NFICOU,opened=INCCOU)
                             IF (INCCOU) CLOSE(NFICOU)
      inquire(unit=NFIWAV,opened=INCWAV)
                             IF (INCWAV) CLOSE(NFIWAV)
      inquire(unit=NFIKER,opened=INCKER)
                             IF (INCKER) CLOSE(NFIKER)
      inquire(unit=NFIYUP,opened=INCYUP)
                             IF (INCYUP) CLOSE(NFIYUP)
      inquire(unit=NFIYUC,opened=INCYUC)
                             IF (INCYUC) CLOSE(NFIYUC)
      inquire(unit=NFIGOP,opened=INCGOP)
                             IF (INCGOP) CLOSE(NFIGOP)
      inquire(unit=NFIGOC,opened=INCGOC)
                             IF (INCGOC) CLOSE(NFIGOC)
      inquire(unit=NFIGPP,opened=INCGPP)
                             IF (INCGPP) CLOSE(NFIGPP)
      inquire(unit=NFIGPC,opened=INCGPC)
                             IF (INCGPC) CLOSE(NFIGPC)
      inquire(unit=NFIROP,opened=INCROP)
                             IF (INCROP) CLOSE(NFIROP)
      inquire(unit=NFIROC,opened=INCROC)
                             IF (INCROC) CLOSE(NFIROC)
      inquire(unit=NFILIP,opened=INCLIP)
                             IF (INCLIP) CLOSE(NFILIP)
      inquire(unit=NFILIC,opened=INCLIC)
                             IF (INCLIC) CLOSE(NFILIC)
      inquire(unit=NFIFIP,opened=INCFIP)
                             IF (INCFIP) CLOSE(NFIFIP)
      inquire(unit=NFIFIC,opened=INCFIC)
                             IF (INCFIC) CLOSE(NFIFIC)
      inquire(unit=NFIISO,opened=INCISO)
                             IF (INCISO) CLOSE(NFIISO)
      inquire(unit=NFIQUA,opened=INCQUA)
                             IF (INCQUA) CLOSE(NFIQUA)
      inquire(unit=NFIRED,opened=INCRED)
                             IF (INCRED) CLOSE(NFIRED)
      inquire(unit=NFIBAP,opened=INCBAP)
                             IF (INCBAP) CLOSE(NFIBAP)
      inquire(unit=NFIBAC,opened=INCBAC)
                             IF (INCBAC) CLOSE(NFIBAC)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE IOFILE(IREAWS,ICONTI,IFCONT,IYCONT,ILCONT,IGCONT,
     *                  IGPCON,IECONT,IWRIRE,IWRILI,IWRIYU,IWRIGO,
     *                  IWRIRO,IWRIFI,IWRISO,IWRIQU,IWRIRM,
     *
     *                  LIPKIN,LIPKIP,I_YUKA,I_GOGA,IGOGPA,I_REGA,
     *                  INDFIL,INDJOB,IREVIE,IF_THO,NEWGOG,
     *
     *                  NFIWOO,NFIREP,NFIREC,NFIREV,NFICOU,NFIWAV,
     *                  NFIKER,NFIYUP,NFIYUC,NFIGOP,NFIGOC,NFIGPC,
     *                  NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *                  NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP,
     *                  NFIFER,
     *
     *                  FILWOO,FILREP,FILREC,FILREV,FILCOU,FILWAV,
     *                  FILKER,FILYUP,FILYUC,FILGOP,FILGOC,FILGPC,
     *                  FILGPP,FILROP,FILROC,FILLIP,FILLIC,FILFIP,
     *                  FILFIC,FILISO,FILQUA,FILRED)
      CHARACTER
     *          FILREP*68,FILREC*68,FILWOO*68,FILREV*68,FILCOU*68,
     *          FILISO*68,FILWAV*68,FILKER*68,FILYUP*68,FILYUC*68,
     *          FILGOP*68,FILGOC*68,FILGPC*68,FILGPP*68,FILROP*68,
     *          FILROC*68,FILLIP*68,FILLIC*68,FILFIP*68,FILFIC*68,
     *          FILQUA*68,FILRED*68
      CHARACTER
     *          FILOLD*68
      COMMON
     *      /CFIPRI/ NFIPRI
C
      DATA
     *     FILOLD /'DUMMY FILE NAME'/
      DATA
     *     IOPREV /0/
C=======================================================================
C         OPENING FILES
C=======================================================================
C
      NFIWOO=10
      NFIREP=11
      NFIREV=12
      NFIISO=13
C
      NFIDUM=1012
C
      NFIREC=91
C
      NFICOU=22
      NFIWAV=23
      NFIKER=24
      NFIYUP=25
      NFIYUC=26
      NFILIP=27
      NFILIC=28
      NFIFIP=29
      NFIFIC=30
      NFIGOP=31
      NFIGOC=32
      NFIGPC=310
      NFIGPP=320
      NFIROP=33
      NFIROC=34
      NFIQUA=35
      NFIFER=36
      NFIRED=37
      NFIBAP=38
      NFIBAC=39
C
C=======================================================================
C      CHECK IF FILES ARE ALREADY OPENED. IF YES, CLOSE THEM FIRST
C      TO AVOID POSSIBLE CONFLICTS OF UNIT/FILENAME ALLOCATIONS.
C=======================================================================
C
      CALL IOCLOS(NFIWOO,NFIREP,NFIDUM,NFIREC,NFICOU,NFIWAV,
     *            NFIKER,NFIYUP,NFIYUC,NFIGOC,NFIGOP,NFIGPC,
     *            NFIGPP,NFIROP,NFIROC,NFILIP,NFILIC,NFIFIP,
     *            NFIFIC,NFIISO,NFIQUA,NFIRED,NFIBAC,NFIBAP)
C
C=======================================================================
C      In case of parallel MPI environment, overwriting all filenames
C      to avoid all processes trying to access the same files
C      N.B. THIS SHOULD BE MODIFIED IN THE FUTURE WHEN SEVERAL
C           PROCESSORS RUN THE SAME HFB CALCULATIONS: ONLY THE
C           MASTER SHOULD OPEN/READ/WRITE/CLOSE THE FILES
C=======================================================================
C
#if(USE_MPI==1)
C
      WRITE(FILREV,'(''HFODD_'',i8.8,''.REV'')') INDJOB
      WRITE(FILREC,'(''HFODD_'',i8.8,''.REC'')') INDJOB
      WRITE(FILREP,'(''HFODD_'',i8.8,''.REP'')') INDJOB
      WRITE(FILWOO,'(''WOODS_'',i8.8,''.WFN'')') INDJOB
      WRITE(FILCOU,'(''HFODD_'',i8.8,''.COU'')') INDJOB
      WRITE(FILWAV,'(''HFODD_'',i8.8,''.WFN'')') INDJOB
      WRITE(FILKER,'(''HFODD_'',i8.8,''.KER'')') INDJOB
      WRITE(FILYUC,'(''HFODD_'',i8.8,''.YUC'')') INDJOB
      WRITE(FILYUP,'(''HFODD_'',i8.8,''.YUP'')') INDJOB
      WRITE(FILGOC,'(''HFODD_'',i8.8,''.GOC'')') INDJOB
      WRITE(FILGOP,'(''HFODD_'',i8.8,''.GOP'')') INDJOB
      WRITE(FILGPC,'(''HFODD_'',i8.8,''.GPC'')') INDJOB
      WRITE(FILGPP,'(''HFODD_'',i8.8,''.GPP'')') INDJOB
      WRITE(FILROC,'(''HFODD_'',i8.8,''.ROC'')') INDJOB
      WRITE(FILROP,'(''HFODD_'',i8.8,''.ROP'')') INDJOB
      WRITE(FILLIC,'(''HFODD_'',i8.8,''.LIC'')') INDJOB
      WRITE(FILLIP,'(''HFODD_'',i8.8,''.LIP'')') INDJOB
      WRITE(FILFIC,'(''HFODD_'',i8.8,''.FIC'')') INDJOB
      WRITE(FILFIP,'(''HFODD_'',i8.8,''.FIP'')') INDJOB
C
      IF (ICONTI.EQ.1) THEN
C
          WRITE(FILREC,'(''./rec/HFODD_'',i8.8,''.REC'')') INDJOB
          WRITE(FILREP,'(''./restart/HFODD_'',i8.8,''.REC'')') INDFIL
C
      END IF
C
      IF (ILCONT.EQ.1.AND.(LIPKIN.EQ.1.OR.LIPKIP.EQ.1)) THEN
C
          WRITE(FILLIP,'(''./lic/HFODD_'',i8.8,''.LIC'')') INDFIL
C
      END IF
C
      IF (IF_THO.EQ.2) THEN
C
          WRITE(FILREC,'(''./rec/HFODD_'',i8.8,''.REC'')') INDJOB
          WRITE(FILREP,'(''./restart/HFODD_'',i8.8,''.REC'')') INDFIL
          WRITE(FILFIP,'(''./fip/HFODD_'',i8.8,''.FIC'')') INDFIL
C
      END IF
C
#endif
C
C=======================================================================
C
      IERROR=0
C
C=======================================================================
C         OPENING THE COMMON FILREP AND FILREC FILE
C=======================================================================
C
      IF (FILREP.EQ.FILREC) THEN
C
          NFIREP=NFIREC
C
          IF (ICONTI.EQ.1.OR.IF_THO.EQ.2) THEN
C
              IERROR=0
              OPEN(NFIREP,FILE=FILREP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILREP
C
                   STOP ' FILE FILREP NOT FOUND ON DISC'
C
              END IF
C
          ELSE
C
              IF (IWRIRE.NE.-1) THEN
                 OPEN(NFIREC,FILE=FILREC,STATUS='UNKNOWN',
     *                         FORM='UNFORMATTED')
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C         OPENING THE FILREP FILE
C=======================================================================
C
          IF (ICONTI.EQ.1.OR.IF_THO.EQ.2) THEN
C
              IERROR=0
              OPEN(NFIREP,FILE=FILREP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILREP
C
                  STOP ' FILE FILREP NOT FOUND ON DISC'
C
              END IF
C
          END IF
C
C=======================================================================
C         OPENING THE FILREC FILE
C=======================================================================
C
          IF (IWRIRE.NE.-1) THEN
              OPEN(NFIREC,FILE=FILREC,STATUS='UNKNOWN',
     *                    FORM='UNFORMATTED')
           END IF
C
      END IF
C
C=======================================================================
C         OPENING THE COMMON FILYUP AND FILYUC FILE
C=======================================================================
C
      IF (FILYUP.EQ.FILYUC) THEN
C
          NFIYUP=NFIYUC
C
          IF (IYCONT.EQ.1.AND.IFCONT.NE.1.AND.I_YUKA.GE.2) THEN
C
              IERROR=0
              OPEN(NFIYUP,FILE=FILYUP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILYUP
C
                  STOP ' FILE FILYUP NOT FOUND ON DISC'
C
              END IF
C
          ELSE
C
              IF (IWRIYU.NE.-1.AND.I_YUKA.GE.2) THEN
                  OPEN(NFIYUC,FILE=FILYUC,STATUS='UNKNOWN',
     *                        FORM='UNFORMATTED')
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C         OPENING THE FILYUP FILE
C=======================================================================
C
          IF (IYCONT.EQ.1.AND.IFCONT.NE.1.AND.I_YUKA.GE.2) THEN
C
              IERROR=0
              OPEN(NFIYUP,FILE=FILYUP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILYUP
C
                  STOP ' FILE FILYUP NOT FOUND ON DISC'
C
              END IF
C
          END IF
C
C=======================================================================
C         OPENING THE FILYUC FILE
C=======================================================================
C
          IF (IWRIYU.NE.-1.AND.I_YUKA.GE.2) THEN
              OPEN(NFIYUC,FILE=FILYUC,STATUS='UNKNOWN',
     *                    FORM='UNFORMATTED')
          END IF
C
      END IF
C
C=======================================================================
C         OPENING THE COMMON FILGOP AND FILGOC FILE
C=======================================================================
C
      IF (FILGOP.EQ.FILGOC) THEN
C
          NFIGOP=NFIGOC
C
          IF (IGCONT.EQ.1.AND.(I_GOGA.GE.2.AND.NEWGOG.EQ.0)) THEN
C
              IERROR=0
              OPEN(NFIGOP,FILE=FILGOP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                 WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                        ''FILE NOT FOUND ON DISC'',
     *                                                    2X,26(1H/),/,
     *                        1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                        1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                        1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                        1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                    2X,26(1H/))')
     *                 FILGOP
C
                 STOP ' FILE FILGOP NOT FOUND ON DISC'
C
              END IF
C
          ELSE
C
              IF (IWRIGO.NE.-1.AND.(I_GOGA.GE.2.AND.NEWGOG.EQ.0)) THEN
                  OPEN(NFIGOC,FILE=FILGOC,STATUS='UNKNOWN',
     *                        FORM='UNFORMATTED')
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C         OPENING THE FILGOP FILE
C=======================================================================
C
          IF (IGCONT.EQ.1.AND.(I_GOGA.GE.2.AND.NEWGOG.EQ.0)) THEN
C
              IERROR=0
              OPEN(NFIGOP,FILE=FILGOP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILGOP
C
                  STOP ' FILE FILGOP NOT FOUND ON DISC'
C
              END IF
C
          END IF
C
C=======================================================================
C         OPENING THE FILGOC FILE
C=======================================================================
C
          IF (IWRIGO.NE.-1.AND.(I_GOGA.GE.2.AND.NEWGOG.EQ.0)) THEN
              OPEN(NFIGOC,FILE=FILGOC,STATUS='UNKNOWN',
     *                    FORM='UNFORMATTED')
          END IF
C
      END IF
C
C=======================================================================
C         OPENING THE COMMON FILGPP AND FILGPC FILE
C=======================================================================
C
      IF (FILGPP.EQ.FILGPC) THEN
C
          NFIGPP=NFIGPC
C
          IF (IGPCON.EQ.1.AND.IGOGPA.GE.2) THEN
C
              IERROR=0
              OPEN(NFIGPP,FILE=FILGPP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILGPP
C
                  STOP ' FILE FILGPP NOT FOUND ON DISC'
C
              END IF
C
          ELSE
C
              IF (IWRIGO.NE.-1.AND.IGOGPA.GE.2) THEN
                  OPEN(NFIGPC,FILE=FILGPC,STATUS='UNKNOWN',
     *                        FORM='UNFORMATTED')
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C         OPENING THE FILGPP FILE
C=======================================================================
C
          IF (IGPCON.EQ.1.AND.IGOGPA.GE.2) THEN
C
              IERROR=0
              OPEN(NFIGPP,FILE=FILGPP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILGPP
C
                  STOP ' FILE FILGPP NOT FOUND ON DISC'
C
              END IF
C
          END IF
C
C=======================================================================
C         OPENING THE FILGPC FILE
C=======================================================================
C
          IF (IWRIGO.NE.-1.AND.IGOGPA.GE.2) THEN
              OPEN(NFIGPC,FILE=FILGPC,STATUS='UNKNOWN',
     *                    FORM='UNFORMATTED')
          END IF
C
      END IF
C
C=======================================================================
C         OPENING THE COMMON FILROP AND FILROC FILE
C=======================================================================
C
      IF (FILROP.EQ.FILROC) THEN
C
          NFIROP=NFIROC
C
          IF (IECONT.EQ.1.AND.I_REGA.GE.2) THEN
C
              IERROR=0
              OPEN(NFIROP,FILE=FILROP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILROP
C
                  STOP ' FILE FILROP NOT FOUND ON DISC'
C
              END IF
C
          ELSE
C
              IF (IWRIRO.NE.-1.AND.I_REGA.GE.2) THEN
                  OPEN(NFIROC,FILE=FILROC,STATUS='UNKNOWN',
     *                        FORM='UNFORMATTED')
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C         OPENING THE FILROP FILE
C=======================================================================
C
          IF (IECONT.EQ.1.AND.I_REGA.GE.2) THEN
C
              IERROR=0
              OPEN(NFIROP,FILE=FILROP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILROP
C
                  STOP ' FILE FILROP NOT FOUND ON DISC'
C
              END IF
C
          END IF
C
C=======================================================================
C         OPENING THE FILROC FILE
C=======================================================================
C
          IF (IWRIRO.NE.-1.AND.I_REGA.GE.2) THEN
              OPEN(NFIROC,FILE=FILROC,STATUS='UNKNOWN',
     *                    FORM='UNFORMATTED')
          END IF
C
      END IF
C
C=======================================================================
C         OPENING THE COMMON FILLIP AND FILLIC FILE
C=======================================================================
C
      IF (FILLIP.EQ.FILLIC) THEN
C
          NFILIP=NFILIC
C
          IF (((ILCONT.EQ.1.AND.IFCONT.NE.1).OR.IF_THO.EQ.2).AND.
     *         (LIPKIN.EQ.1.OR.LIPKIP.EQ.1)) THEN
C
              IERROR=0
              OPEN(NFILIP,FILE=FILLIP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILLIP
C
                  STOP ' FILE FILLIP NOT FOUND ON DISC'
C
              END IF
C
          ELSE
C
              IF (IWRILI.NE.-1.AND.(LIPKIN.EQ.1.OR.LIPKIP.EQ.1).AND.
     *           (IWRILI.NE.1.OR.IWRIFI.EQ.-1)) THEN
                  OPEN(NFILIC,FILE=FILLIC,STATUS='UNKNOWN',
     *                        FORM='UNFORMATTED')
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C         OPENING THE FILLIP FILE
C=======================================================================
C
          IF (((ILCONT.EQ.1.AND.IFCONT.NE.1).OR.IF_THO.EQ.2).AND.
     *         (LIPKIN.EQ.1.OR.LIPKIP.EQ.1)) THEN
C
              IERROR=0
              OPEN(NFILIP,FILE=FILLIP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILLIP
C
                  STOP ' FILE FILLIP NOT FOUND ON DISC'
C
              END IF
C
          END IF
C
C=======================================================================
C         OPENING THE FILLIC FILE
C=======================================================================
C
          IF (IWRILI.NE.-1.AND.(LIPKIN.EQ.1.OR.LIPKIP.EQ.1).AND.
     *       (IWRILI.NE.1.OR.IWRIFI.EQ.-1)) THEN
              OPEN(NFILIC,FILE=FILLIC,STATUS='UNKNOWN',
     *                    FORM='UNFORMATTED')
          END IF
C
      END IF
C
C=======================================================================
C         OPENING THE COMMON FILFIP AND FILFIC FILE
C=======================================================================
C
      IF (FILFIP.EQ.FILFIC) THEN
C
          NFIFIP=NFIFIC
C
          IF (IFCONT.EQ.1.OR.IF_THO.EQ.2) THEN
C
              IERROR=0
              OPEN(NFIFIP,FILE=FILFIP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILFIP
C
                  STOP ' FILE FILFIP NOT FOUND ON DISC'
C
              END IF
C
          ELSE
C
              IF (IWRIFI.NE.-1) THEN
                  OPEN(NFIFIC,FILE=FILFIC,STATUS='UNKNOWN',
     *                        FORM='UNFORMATTED')
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C         OPENING THE FILFIP FILE
C=======================================================================
C
          IF (IFCONT.EQ.1.OR.IF_THO.EQ.2) THEN
C
              IERROR=0
              OPEN(NFIFIP,FILE=FILFIP,STATUS='OLD',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                         ''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                         1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                         1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                     2X,26(1H/))')
     *                 FILFIP
C
                  STOP ' FILE FILFIP NOT FOUND ON DISC'
C
              END IF
C
          END IF
C
C=======================================================================
C         OPENING THE FILFIC FILE
C=======================================================================
C
          IF (IWRIFI.NE.-1) THEN
              OPEN(NFIFIC,FILE=FILFIC,STATUS='UNKNOWN',
     *                    FORM='UNFORMATTED')
          END IF
C
      END IF
C
C=======================================================================
C         OPENING THE FILQUA FILE
C=======================================================================
C
      IF (IWRIQU.NE.-1) THEN
C
          OPEN(NFIQUA,FILE=FILQUA,STATUS='UNKNOWN',FORM='UNFORMATTED')
C
      END IF
C
C=======================================================================
C         OPENING THE FILRED FILE
C=======================================================================
C
      IF (IWRIRM.EQ.1) THEN
C
          OPEN(NFIRED,FILE=FILRED,STATUS='UNKNOWN',FORM='FORMATTED')
C
      END IF
C
C=======================================================================
C         OPENING THE FILISO FILE
C=======================================================================
C
      IF (IWRISO.EQ.1) THEN
C
          OPEN (NFIISO,FILE=FILISO,STATUS='UNKNOWN',FORM='FORMATTED')
C
          WRITE(NFIISO,'(132(1H*),/,
     *                  1H*,/,
     *                  1H*,1X,''ITER'',3X,''EULER ANGLES'',6X,
     *                         ''Q1-1'',5X,''Q10'',5X,''Q11'',5X,
     *                         ''Q2-2'',4X,''Q2-1'',5X,''Q20'',5X,
     *                                      ''Q21'',5X,''Q22'',4X,
     *                         ''J_X'',3X,''J_Y'',3X,''J_Z'',4X,
     *                         ''S_X'',3X,''S_Y'',3X,''S_Z'',3X,
     *                         ''<WJ'',2X,''<ZJ'',2X,''<NP'',/,1H*)')
C
      END IF
C
C=======================================================================
C         OPENING THE REVIEW FILE IF IT HAS NOT BEEN OPENED (IOPREV=0).
C         OTHERWISE, IT IS REOPENED WHENEVER THE FILE NAME IS MODIFIED.
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.64) AND (2.68C)  THE  REVIEW
C                       FILE BELOW WAS OPENED AT EVERY DATA  SET.  AS  A
C                       CONSEQUENCE, THE INFORMATION IN THE REVIEW  FILE
C                       FOR DIFFERENT DATA SETS WAS NOT PILED UP.
C                       THIS BUG WAS CORRECTED ON 28/08/2013 IN  VERSION
C                       (2.68D).
C=======================================================================
C
      IF (IREVIE.NE.0) THEN
C
          IF (IOPREV.EQ.0) THEN
C
              OPEN (NFIREV,FILE=FILREV,STATUS='UNKNOWN',
     *                                 FORM='FORMATTED')
C
              FILOLD=FILREV
              IOPREV=1
C
          ELSE
C
              IF (FILREV.NE.FILOLD) THEN
C
                  CLOSE (NFIREV)
C
                  OPEN  (NFIREV,FILE=FILREV,STATUS='UNKNOWN',
     *                                      FORM='FORMATTED')
C
                  FILOLD=FILREV
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NOTABS(FILDUM,FILCUT)
C
      CHARACTER
     *          FILWRK*80,FILDUM*80,FILCUT*68
C
C=======================================================================
C        THIS SUBROUTINE REMOVES TRAILING SPACES, AND LEADING  TABS  AND
C        SPACES, FROM THE FILE NAME, AND CHANGES  THE  INSIDE  TABS  AND
C        SPACES INTO UNDERSCORES.
C=======================================================================
C
      FILWRK=trim(FILDUM)
C
      DO ICHARA=1,LEN(trim(FILDUM))
C
         IF (IACHAR(FILWRK(ICHARA:ICHARA)).EQ.9.OR.
     *       IACHAR(FILWRK(ICHARA:ICHARA)).EQ.1) THEN
C
             FILWRK(ICHARA:ICHARA)=' '
         ELSE
             GO TO 1
C
         END IF
C
      END DO
C
    1 CONTINUE
C
      FILWRK=ADJUSTL(FILWRK)
C
      FILCUT=trim(FILWRK)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NAMELI(IN_FIX,IZ_FIX,SKYRME,GOGNAM,ISTAND,
     *                  KETA_J,KETA_W,KETACM,KETA_M,KETA_P,
     *                                KETA_T,KETAPA,NOZEPA,
     *                                ITWOLI,KETA_R,
     *                                KETAJ2,KETAT2,
     *           LANODD,LANSCA,HBMSAT,RHOSAT,EFFSAT,
     *           ILIBAS,INBASI,IZBASI,FCHOM0,R0PARM,
     *                                       IOPTGS,
     *           IPAIRI,IPAHFB,ITWOBA,IPABCS,IMFHFB,
     *                                       IPNMIX,
     *                                LIPKIN,LIPKIP,
     *                                LIPNON,LIPNOP,
     *                         IPNPRJ,NPPNPN,NPPNPP,
     *                  IROTAT,ITIREP,IREVIE,IQPSTA,
     *                  DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                  FERFIN,FERFIP,IFEFIN,IFEFIP,
     *                  FE2FIN,FE2FIP,IF2FIN,IF2FIP,
     *                  FERALN,FERALP,IFERAN,IFERAP,
     *                                       NUQEVE,
     *                  INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *                  INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                         INSIMN,IRSIMN,IDSIMN,
     *                         INSIMP,IRSIMP,IDSIMP,
     *                         INSIQN,IPSIQN,IDSIQN,
     *                         INSIQP,IPSIQP,IDSIQP,
     *                                INSIZN,IDSIZN,
     *                                INSIZP,IDSIZP,
     *                                IFIBLN,INIBLN,
     *                                IFIBLP,INIBLP,
     *                                       IREAWS,
     *                         ICONTI,IPCONT,IOCONT,
     *                         ISCONT,ITCONT,IACONT,
     *                  IYCONT,IGCONT,IGPCON,IECONT,
     *           ILCONT,IFCONT,IMCONT,IRCONT,IBCONT,
     *           NUCHAO,NUPING,EPSPNG,EPSITE,EPSCON,
     *                  ISPHER,ISIMPY,ISIGNY,IPARTY,
     *                         ISIMTX,ISIMTY,ISIMTZ,
     *                  IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                         NOITER,NULAST,NUCONS,
     *                  ISYMDE,INIROT,INIINV,INIKAR,
     *                         IRENMA,IRENIN,IDOGOA,
     *                         IFRWAV,ITOWAV,IWRWAV,
     *                                ISAKER,ICHKER,
     *                         IPRROT,IPRISO,IPRIS3,
     *                         IPRNUM,IPRVEC,IPRPTY,
     *                                IPROMI,IPROMA,
     *                         NUAKNO,NUBKNO,KPROJE,
     *                         NATKNO,NBTKNO,KSOSTZ,
     *                  NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *                                KSOSMI,KSOSMA,
     *                         ISOSAD,EPSISO,ICSKIP,
     *           IFERME,IBETME,IIFERR,ITFERR,ISFERR,
     *                  IPAKER,IPAK3D,IPAALL,KFIKER,
     *                  NUASTA,NUASTO,NUGSTA,NUGSTO,
     *                  NATSTA,NATSTO,NGTSTA,NGTSTO,
     *                  NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *                         ICUTOV,CUTOVE,CUTOVF,
     *                         IONISH,ISLPRI,ISUPRI,
     *                         IENPRI,ISRPRI,IMIPRI,
     *                         IKEPRI,IRMPRI,IELPRI,
     *                  QMUCUT,QMACUT,QASCUT,QSICUT,
     *                         NOSCIL,NLIMIT,ENECUT,
     *                         NUMCOU,NUMETA,FURMAX,
     *                  ICOTYP,ICOUDI,ICOUEX,E_EFFE,
     *                  PIMASS,PNMASS,IYUTYP,I_YUKA,
     *                  YUKAGT,YUKAG0,YUKAG1,YUKAG2,
     *                                I_GOGA,IGOGPA,
     *                                I_REGA,IREGPA,
     *                                I_SEPA,ISEPPA,
     *                                I_COUA,ICOUPA,
     *                                N3SERD,IDOTHC,
     *                  I1LINE,IPRSTA,IPRMID,IPRSTO,
     *                  IDESTA,IDEMID,IDESTO,IDEDIS,
     *                                INTRIP,IVIPRI,
     *                         IPRI_N,IPRI_P,IPRI_T,
     *                         NMUCON,NMUCOU,NMUPRI,
     *                                ICOUMD,ICOUMX,
     *                         ISCHIF,NSICON,NSIPRI,
     *                         NMACON,NMAPRI,NMAORD,
     *                         NASCON,NASPRI,NASORD,
     *                                       NRAORD,
     *                  NMURED,NMARED,NASRED,NSIRED,
     *                         NEXBET,IPRIBE,IPRIBL,
     *                  IWRIOL,IWRISO,IWRIRE,IWRIBA,
     *                         IWRIYU,IWRIGO,IWRIRO,
     *                  IWRILI,IWRIFI,IWRIQU,IWRIRM,
     *                         FILISO,FILREP,FILREC,
     *                         FILWOO,FILREV,FILCOU,
     *                                FILWAV,FILKER,
     *                                FILYUP,FILYUC,
     *                                FILGOP,FILGOC,
     *                                FILGPP,FILGPC,
     *                                FILROP,FILROC,
     *                                FILLIP,FILLIC,
     *                         FILFIP,FILFIC,FILFER,
     *                                FILQUA,FILRED,
     *                                FILBAP,FILBAC,
     *                         ICHFLI,IPAFLI,IREFLI,
     *                         ISPFLI,ISHFLI,IFLIPI,
     *                  SLOWEV,SLOWOD,SLOWPA,SLOWLI,
     *                                ICOULI,ICOULO,
     *                                FACTGN,FACTGP,
     *                                EMINAL,EMAXAL,
     *                  EMAXQU,ECUTOF,LIMQUA,LAMCUT,
     *                                IQUNIL,NILXYZ,
     *                                       IAVRGG,
     *                                       IPOTHO,
     *                                       EPSHER,
     *                         ICOMIX,INLKER,INRKER,
     *                         ICMPRI,IN_EXC,EPSMIX,
     *                                ISOADD,NBTKNT,
     *                         IFSHEL,IF_RPA,IFRTHO,
     *                  PRHD_T,PRHDDT,PRHDST,POWDRT,
     *                                       IFRAGM,
     *           DELTAE,XLOCMX,V2_MIN,ITRMAX,NTHETA,
     *                  MIN_QP,IDEALL,IDELOC,IDECON,
     *                         ILIPON,ILIPOP,GAUSHI,
     *                                I_SLOW,SLOWAL,
     *                  SLOWLD,SLOWTP,SLOWRP,SLOWLM,
     *           NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,
     *           NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,
     *                                LASTAN,LASTAP,
     *                         IAXIAP,KAPASY,INUNIL,
     *                                       IADBAT,
     *                                NEWGOG,NEWCOU,
     *                                       ITWCEN,
     *                                IEIGCU,EIGCUT,
     *                                NLIMTW,ENECTW,
     *                                       IFRCNT)
C=======================================================================
      USE hfodd_sizes
      USE colcoord
C=======================================================================
      PARAMETER (NDF2BC=5)
      PARAMETER (NDFANL=2)
      PARAMETER (NDFSTA=3)
C=======================================================================
C
      CHARACTER
     *          FILREP*68,FILREC*68,FILWOO*68,
     *          FILREV*68,FILCOU*68,FILISO*68,FILWAV*68,FILKER*68,
     *          FILYUP*68,FILYUC*68,
     *          FILGOP*68,FILGOC*68,
     *          FILGPP*68,FILGPC*68,
     *          FILROP*68,FILROC*68,
     *          FILLIP*68,FILLIC*68,
     *          FILFIP*68,FILFIC*68,
     *          FILFER*68,FILQUA*68,
     *          FILBAP*68,FILBAC*68,
     *          FILRED*68
      CHARACTER
     *          FILLEF*68,FILRIG*68
      CHARACTER
     *          FILDUM*80
      CHARACTER
     *          KEYWOR*10,SKYRME*4,GOGNAM*4
      CHARACTER
     *          MYDATE*8,MYTIME*10,MYZONE*5
      CHARACTER
     *          LINE*80,NIBLOL*15
C
      INTEGER   icolmult(2:nccmult,0:nccmult)
C
      DIMENSION
     *          MYVALU(8)
      DIMENSION
     *          IN_EXC(ND_EXC)
      DIMENSION
     *          INSIZN(1:NDBLOC),IDSIZN(1:NDBLOC),
     *          INSIZP(1:NDBLOC),IDSIZP(1:NDBLOC)
      DIMENSION
     *          INSIQN(1:NDBLOC),IPSIQN(1:NDBLOC),IDSIQN(1:NDBLOC),
     *          INSIQP(1:NDBLOC),IPSIQP(1:NDBLOC),IDSIQP(1:NDBLOC)
      DIMENSION
     *             STSALL(NDCOUT), SPMALL(NDCOUT)
      DIMENSION
     *             ATSALL(NDCOUT), APMALL(NDCOUT)
      DIMENSION
     *             CENREA(NDKART,2)
      DIMENSION
     *             IROAUX(2),ALTWRE(2),BETWRE(2),GATWRE(2)
      DIMENSION
     *             BAXREA(NDTWCE),BAYREA(NDTWCE),BAZREA(NDTWCE)
      EQUIVALENCE
     *            (STSALL,SRHO_T),(SPMALL,SRHO_P)
      EQUIVALENCE
     *            (ATSALL,ARHO_T),(APMALL,ARHO_P)
C=======================================================================
      COMMON
     *       /SIMKPH/ KPSIMP(NDPAHO,0:NDISOS),KPSIMM(NDPAHO,0:NDISOS),
     *                KHSIMP(NDPAHO,0:NDISOS),KHSIMM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIGKPH/ KPPPSP(NDPAHO,0:NDISOS),KPPPSM(NDPAHO,0:NDISOS),
     *                KPPMSP(NDPAHO,0:NDISOS),KPPMSM(NDPAHO,0:NDISOS),
     *                KHPPSP(NDPAHO,0:NDISOS),KHPPSM(NDPAHO,0:NDISOS),
     *                KHPMSP(NDPAHO,0:NDISOS),KHPMSM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIQKPH/ KPSIQP(NDPAHO,0:NDISOS),KPSIQM(NDPAHO,0:NDISOS),
     *                KHSIQP(NDPAHO,0:NDISOS),KHSIQM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIZKPH/ KPNONE(NDPAHO,0:NDISOS),
     *                KHNONE(NDPAHO,0:NDISOS)
      COMMON
     *       /MIGKPH/ LPPPSP(NDPAHO),LPPPSM(NDPAHO),
     *                LPPMSP(NDPAHO),LPPMSM(NDPAHO),
     *                LHPPSP(NDPAHO),LHPPSM(NDPAHO),
     *                LHPMSP(NDPAHO),LHPMSM(NDPAHO)
      COMMON
     *       /MIMKPH/ LPSIMP(NDPAHO),LPSIMM(NDPAHO),
     *                LHSIMP(NDPAHO),LHSIMM(NDPAHO)
      COMMON
     *       /MIQKPH/ LPSIQP(NDPAHO),LPSIQM(NDPAHO),
     *                LHSIQP(NDPAHO),LHSIQM(NDPAHO)
      COMMON
     *       /MIZKPH/ LPNONE(NDPAHO),
     *                LHNONE(NDPAHO)
      COMMON
     *       /SIGKVA/ KVASIG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /SIMKVA/ KVASIM(         0:NDSIMP,0:NDISOS)
      COMMON
     *       /SIQKVA/ KVASIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /SIZKVA/ KVASIZ(                  0:NDISOS)
      COMMON
     *       /SIZMVA/ MVASIZ(0:NDISOS)
      COMMON
     *       /SIQALR/ LALSIQ(-NDALIB:NDALIB,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQALI/ KALSIQ(-NDALIB:NDALIB,0:NDPARI,0:NDISOS),
     *                MALSIQ(-NDALIB:NDALIB,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIZALR/ LALSIZ(-NDALIB:NDALIB,0:NDISOS)
      COMMON
     *       /SIZALI/ KALSIZ(-NDALIB:NDALIB,0:NDISOS),
     *                MALSIZ(-NDALIB:NDALIB,0:NDISOS)
      COMMON
     *       /MIGKVA/ KVAMIG(0:NDPARI,0:NDSIGN)
      COMMON
     *       /MIMKVA/ KVAMIM(0:NDSIMP)
      COMMON
     *       /MIQKVA/ KVAMIQ(0:NDPARI)
      COMMON
     *       /K_FLIG/ KPFLIG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KHFLIG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KOFLIG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /K_FLIM/ KPFLIM(         0:NDSIMP,0:NDISOS),
     *                KHFLIM(         0:NDSIMP,0:NDISOS),
     *                KOFLIM(         0:NDSIMP,0:NDISOS)
      COMMON
     *       /K_FLIQ/ KPFLIQ(0:NDPARI,         0:NDISOS),
     *                KHFLIQ(0:NDPARI,         0:NDISOS),
     *                KOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /K_FLIZ/ KPFLIZ(                  0:NDISOS),
     *                KHFLIZ(                  0:NDISOS),
     *                KOFLIZ(                  0:NDISOS)
      COMMON
     *       /K_MLIG/ KPMLIG(0:NDPARI,0:NDSIGN),
     *                KHMLIG(0:NDPARI,0:NDSIGN),
     *                KOMLIG(0:NDPARI,0:NDSIGN)
      COMMON
     *       /K_MLIM/ KPMLIM(0:NDSIMP),
     *                KHMLIM(0:NDSIMP),
     *                KOMLIM(0:NDSIMP)
      COMMON
     *       /K_MLIQ/ KPMLIQ(0:NDPARI),
     *                KHMLIQ(0:NDPARI),
     *                KOMLIQ(0:NDPARI)
      COMMON
     *       /K_MLIZ/ KPMLIZ,
     *                KHMLIZ,
     *                KOMLIZ
      COMMON
     *       /K_FILG/ KPFILG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KHFILG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KOFILG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /K_FILZ/ KPFILZ(                  0:NDISOS),
     *                KHFILZ(                  0:NDISOS),
     *                KOFILZ(                  0:NDISOS)
      COMMON
     *       /VACCNF/ IVACUM
      COMMON
     *       /STSSKY/ SRHO_T,SRHO_S,SRHODT,SRHODS,
     *                SLPR_T,SLPR_S,
     *                STAU_T,STAU_S,
     *                SSCU_T,SSCU_S,
     *                SDIV_T,SDIV_S,
     *                SSPI_T,SSPI_S,SSPIDT,SSPIDS,
     *                SLPS_T,SLPS_S,
     *                SCUR_T,SCUR_S,
     *                SKIS_T,SKIS_S,
     *                SROT_T,SROT_S,
     *                SSCT_T,SSCT_S,
     *                SKIT_T,SKIT_S,
     *                SSPT_T,SSPT_S
      COMMON
     *       /SPMSKY/ SRHO_P,SRHO_M,SRHODP,SRHODM,
     *                SLPR_P,SLPR_M,
     *                STAU_P,STAU_M,
     *                SSCU_P,SSCU_M,
     *                SDIV_P,SDIV_M,
     *                SSPI_P,SSPI_M,SSPIDP,SSPIDM,
     *                SLPS_P,SLPS_M,
     *                SCUR_P,SCUR_M,
     *                SKIS_P,SKIS_M,
     *                SROT_P,SROT_M,
     *                SSCT_P,SSCT_M,
     *                SKIT_P,SKIT_M,
     *                SSPT_P,SSPT_M
      COMMON
     *       /ATSSKY/ ARHO_T,ARHO_S,ARHODT,ARHODS,
     *                ALPR_T,ALPR_S,
     *                ATAU_T,ATAU_S,
     *                ASCU_T,ASCU_S,
     *                ADIV_T,ADIV_S,
     *                ASPI_T,ASPI_S,ASPIDT,ASPIDS,
     *                ALPS_T,ALPS_S,
     *                ACUR_T,ACUR_S,
     *                AKIS_T,AKIS_S,
     *                AROT_T,AROT_S,
     *                ASCT_T,ASCT_S,
     *                AKIT_T,AKIT_S,
     *                ASPT_T,ASPT_S
      COMMON
     *       /APMSKY/ ARHO_P,ARHO_M,ARHODP,ARHODM,
     *                ALPR_P,ALPR_M,
     *                ATAU_P,ATAU_M,
     *                ASCU_P,ASCU_M,
     *                ADIV_P,ADIV_M,
     *                ASPI_P,ASPI_M,ASPIDP,ASPIDM,
     *                ALPS_P,ALPS_M,
     *                ACUR_P,ACUR_M,
     *                AKIS_P,AKIS_M,
     *                AROT_P,AROT_M,
     *                ASCT_P,ASCT_M,
     *                AKIT_P,AKIT_M,
     *                ASPT_P,ASPT_M
      COMMON
     *       /INTINP/ TEINPU,TOINPU
      COMMON
     *       /READAL/ ALPHRE(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /NILPAR/ CNILSN,DNILSN,CNILSP,DNILSP,
     *                HBANIX,HBANIY,HBANIZ,NILDAT
      COMMON
     *       /OMEGAS/ OMEGAX,OMEGAY,OMEGAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /IANGLE/ ALPINI,BETINI,GAMINI
      COMMON
     *       /ICNSTR/ STIFFI(1:NDKART),
     *                ASKEDI(1:NDKART),
     *                IFLAGI(1:NDKART)
      COMMON
     *       /ICNTTR/ STIFTI(1:NDKART),
     *                ASKETI(1:NDKART),
     *                IFTAGI(1:NDKART)
      COMMON
     *       /TCNSTR/ STIFFT(1:NDKART),
     *                ASKEDT(1:NDKART),
     *                IFLAGT(1:NDKART)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /ACNSTR/ STIFFA,ASKEDA,IFLAGA
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VCNSTR/ STIFFV(0:NDMULT,-NDMULT:NDMULT),
     *                VASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SCNSTR/ STIFFS(0:NDMULT,-NDMULT:NDMULT),
     *                SASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /GCNSTR/ STIFFG(0:NDMULT),
     *                GASKED(0:NDMULT),
     *                IFLAGG(0:NDMULT)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /PAIINI/ FERINI(0:NDISOS),DELINI(0:NDISOS),FE2INI(0:NDISOS)
      COMMON
     *       /ISOFER/ FERISO(0:NDKART)
      COMMON
     *       /ISOFE_/ FE_RAD,FE_THE,FE_PHI,FE_OFF
      COMMON
     *       /CCPRHD/ PRHD_N,PRHDDN,PRHDSN,POWDRN,
     *                PRHD_P,PRHDDP,PRHDSP,POWDRP
      COMMON
     *       /LAND_G/ X0_LAN,X1_LAN,G0_LAN,G0PLAN,G1_LAN,G1PLAN
      COMMON
     *       /REGPAR/ REGWID
      COMMON
     *       /REJVIN/ REJVCC(NDREGA,NDFORC)
      COMMON
     *       /REJVER/ REJERR(NDREGA,NDFORC)
      COMMON
     *       /REJVAC/ REJFAC(NDREGA,NDFORC)
      COMMON
     *       /REJTIN/ REJTCC(NDREGA,NDFORC)
      COMMON
     *       /FSTFOR/ FSOSTR(NDGOGA,NDFORC),
     *                FTOSTR(NDGOGA,NDFORC),
     *                FTESTR(NDGOGA,NDFORC),FSTWID(NDGOGA)
      COMMON
     *       /JREJAL/ IREREJ(4),NREREJ(4)
      COMMON
     *       /SEPPAR/ SEPWID(NDSEGA),SEPGAU(NDSEGA),NUSEGA
      COMMON
     *       /SEPBIN/ SEPVIC(NDSEPA,NDFORC),IVISEP
      COMMON
     *       /SEPVER/ SEPERR(NDSEPA,NDFORC),IERSEP
      COMMON
     *       /SEPFAC/ SEPFAC(NDSEPA,NDFORC),IFASEP
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /ATWOBO/ TWOBOD,TWOINP,ITWOIN
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /SKYDAT/ T0_DAT,X0_DAT,T1_DAT,X1_DAT,T2_DAT,X2_DAT,
     *                T3_DAT,X3_DAT,WW_DAT,PO_DAT
      COMMON
     *       /SKYERR/ T0_ERR,X0_ERR,T1_ERR,X1_ERR,T2_ERR,X2_ERR,
     *                T3_ERR,X3_ERR,WW_ERR,PO_ERR
      COMMON
     *       /SKYFAC/ T0_FAC,X0_FAC,T1_FAC,X1_FAC,T2_FAC,X2_FAC,
     *                T3_FAC,X3_FAC,WW_FAC,PO_FAC
      COMMON
     *       /CBRPA2/ T02CBR,X02CBR,
     *                T12CBR,X12CBR,
     *                T22CBR,X22CBR
     *       /CBRPA3/ T03CBR,X03CBR,
     *                T13CBR,X13CBR,
     *                T23CBR,X23CBR
     *       /CBRSWI/ I_2CBR,I_3CBR
      COMMON
     *       /SO_PAR/ W0_INP,W0PINP
      COMMON
     *       /SO_ERR/ W0_ERR,W0PERR
      COMMON
     *       /SO_FAC/ W0_FAC,W0PFAC
      COMMON
     *       /CFIREA/ NFIREA
      COMMON
     *       /DISTAN/ DISTAX,DISTAY,DISTAZ
      COMMON
     *       /ROTATT/ ROTATX,ROTATY,ROTATZ
      COMMON
     *       /RINORM/ HBMRIN(NDKART)
      COMMON
     *       /RINROT/ ROTRIN(NDKART)
      COMMON
     *       /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMIX/ ALPHAM,BROTRI
     *       /BROMAT/ NOIINP,MIXMAT
      COMMON
     *       /DPOWER/ POWERD
      COMMON
     *       /IKETRA/ IKEINV,IKEKAR
      COMMON
     *       /NEWIGN/ NEWWIG
      COMMON
     *       /CFIPRI/ NFIPRI
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
      COMMON
     *       /STRUTI_PARAMS/ GSTRUN,GSTRUP,HOMFAC,EPSRTN
     *       /STRUTI_POLYNO/ NPOLYN
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /T_FLAG/ IFTEMP
      COMMON
     *       /GCTEMP/ TEMP_T
C@@@ TEMP -TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
     *       /NCKFLA/ IFNECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /AUTOBA/ IBASIS
      COMMON
     *       /EDFINP/ IF_EDF
      COMMON
     *       /QUOCCU/ PARACC,CORLIM,DERLIM,OCCLIM,MAXQUA,IPQBCS
      COMMON
     *       /JPA2HF/ DEL2HF(0:NDISOS),IPA2HF(0:NDISOS)
      COMMON
     *       /IDENTU/ IDENSU,JDENSU
      COMMON
     *       /IPRIAM/ ILIMAM,IALLAM
      COMMON
     *       /ALLPRI/ IPRALL
      COMMON
     *       /GYROSC/ GYRORP,GYRSPN,GYRSPP,IGYROS
      COMMON
     *       /CUSIZN/ NCUSIZ(0:NDISOS)
      COMMON
     *       /CUSIQN/ NCUSIQ(0:NDISOS,0:NDPARI)
      COMMON
     *       /BLOCNI/ NIBLOC(       0:NDISOS),NIBLOM(NDBLOC,0:NDISOS),
     *                NIBLOE(NDBLOC,0:NDISOS),NIBLOL(NDBLOC,0:NDISOS)
      COMMON
     *       /KERNAM/ FILLEF(NDCONF),FILRIG(NDCONF),NUCONF,NAMKER
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /DIQ_GA/ DIQCOD,DIQCOE,DIQCOP,IDIQGA
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /CENPOS/ CENCOR(1:NDKART,NDTWCE)
      COMMON
     *       /FRCONS/ FRGSTF(0:NDISOS,1:NDTWCE),
     *                FRGASK(0:NDISOS,1:NDTWCE),
     *                IFLFRG(0:NDISOS,1:NDTWCE),
     *                CLMFRA(0:NDISOS,1:NDTWCE),
     *                AVEFRA(0:NDISOS,1:NDTWCE)
      COMMON
     *       /QTWCNS/ STQTWC(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QTWCAS(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                IFLQTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                GALMTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
      COMMON
     *       /ROTFRG/ ALFFRA(1:NDTWCE),BETFRA(1:NDTWCE),
     *                GAMFRA(1:NDTWCE),IROFRG(1:NDTWCE)
      COMMON
     *       /ADBRUN/ IABNTE,IABCOL,IABICH,IABMOD,IFAMON
      COMMON
     *       /ADBPRC/ DABPRS,ETAFAM,XCHIMX
      COMMON /ADBFLE/ SFIADB, SFJADB
      CHARACTER SFIADB*68, SFJADB*68
      COMMON
     *       /TOMOPI/ ITOMOZ,IOBSCH,IDESCH,INDENS
      COMMON
     *       /TOMOPH/ PTOMOX,PTOMOY,PTOMOZ
      COMMON
     *       /TOMSIC/ ITOMSC
      COMMON
     *       /TOMSLC/ P0VECX,P0VECY,P0VECZ,
     *                P1VECX,P1VECY,P1VECZ,
     *                P2VECX,P2VECY,P2VECZ
      COMMON
     *       /TOMIMK/ ITOMII,ITOMMM,ITOMKK,NTOMNB,NTOMNA
      COMMON
     *       /TOMMEN/ NCMESH
      COMMON
     *       /TOMMES/ PINTSC, PWIDTH, PHEIGH
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /GEF2BC/ GIN2BC,GSA2BC,IGY2BC
      COMMON
     *       /FORANL/ MAGANL(NDFANL)
      COMMON
     *       /GEFANL/ GJ2ANL,GSQANL,IGYANL
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /INTCHE/ RANGX,NPOINT
C=======================================================================
      DIMENSION
     *          SEPTIC(NDSEPA,NDFORC)
C=======================================================================
C
      INTEGER, SAVE :: IREXYZ
      INTEGER, SAVE :: IRERTP
C
      INTEGER, SAVE :: INPZMN
      INTEGER, SAVE :: INPZMP
      INTEGER, SAVE :: INPZBN
      INTEGER, SAVE :: INPZBP
C
      INTEGER, SAVE :: INPQMN
      INTEGER, SAVE :: INPQMP
      INTEGER, SAVE :: INPQBN
      INTEGER, SAVE :: INPQBP
C
      INTEGER, SAVE :: IRE3BU
      INTEGER, SAVE :: IRE3BY
C
      INTEGER, SAVE :: IREJCO
      INTEGER, SAVE :: IREJTX
C
      INTEGER, SAVE :: ISEPCO
      INTEGER, SAVE :: ISEPTX
      INTEGER, SAVE :: ISEPAC
      INTEGER, SAVE :: ISEPAT
C
C=======================================================================
C
      DATA NO_RUN /0/,MAXGAU /-1/,NUPAHO /1/
C
      DATA IREXYZ /0/
      DATA IRERTP /0/
C
      DATA INPZMN /0/
      DATA INPZMP /0/
      DATA INPZBN /0/
      DATA INPZBP /0/
C
      DATA INPQMN /0/
      DATA INPQMP /0/
      DATA INPQBN /0/
      DATA INPQBP /0/
C
      DATA IRE3BU /0/
      DATA IRE3BY /0/
C
      DATA IREJCO /0/
      DATA IREJTX /0/
C
      DATA ISEPCO /0/
      DATA ISEPTX /0/
      DATA ISEPAC /0/
      DATA ISEPAT /0/
C
      DATA ISPINY /0/
      DATA ISPXYZ /0/
C
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
      DEGRAD=180.0/PI
C
   1  CONTINUE
C
      READ(NFIREA,'(A10)',END=2) KEYWOR
C
C=======================================================================
C         READING THE NEUTRON AND PROTON NUMBERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NUCLID'.OR.trim(KEYWOR).EQ.'NUCLIDE') THEN
C
          READ(NFIREA,*) IN_FIX,IZ_FIX
C
      END IF
C
C=======================================================================
C         READING THE ITERATION NUMBER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ITERATIONS') THEN
C
          READ(NFIREA,*) NOITER
C
      END IF
C
C=======================================================================
C         READING THE BROYDEN DATA (STANDARD BROYDEN ON FIELDS)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BROYDEN') THEN
C
          READ(NFIREA,*) IBROYD,N_DUMM,A_DUMM,B_DUMM
C
          IF (IBROYD.GE.1.AND.N_DUMM.GT.0) THEN
C
              N_ITER=N_DUMM
              ALPHAM=A_DUMM
              BROTRI=B_DUMM
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE BROYDEN DATA (MATRIX ELEMENTS)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BROYDENMAT') THEN
C
          READ(NFIREA,*) NOIINP,MIXMAT
C
      END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C=======================================================================
C         READING THE DATA ABOUT THE CONSTRAINT ON THE NECK
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NECK_CONST'.OR.
     *    trim(KEYWOR).EQ.'NECK-CONST') THEN
C
          READ(NFIREA,*) IFNECK,Q0NECK,G_NECK
C
      END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C=======================================================================
C         READING THE FLAG SWITCHING ON THE UNEDF PARAMETERIZATIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'UNEDF_PROJ'.OR.
     *    trim(KEYWOR).EQ.'UNEDF-PROJ') THEN
C
          READ(NFIREA,*) IF_EDF
C
      END IF
C=======================================================================
C         CHOOSING TO ADJUST THE BASIS AUTOMATICALLY BASED ON Q2
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BASISAUTOM') THEN
C
          READ(NFIREA,*) IBASIS
C
      END IF
C
C=======================================================================
C         CHOOSING TO COMPUTE THE MASS OF THE FISSION FRAGMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MASSFRAGME') THEN
C
          READ(NFIREA,*) IFRAGM
C
      END IF
C
C=======================================================================
C         CHOOSING TO COMPUTE AND RECORD DENSITIES OF FISSION FRAGMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FRAGDENSIT') THEN
C
          READ(NFIREA,*) IDEALL,IDELOC,IDECON
C
      END IF
C
C=======================================================================
C         CHOOSING TO ROTATE SELECTED PAIRS OF Q.P. WAVE-FUNCTIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'QPROTATION') THEN
C
          READ(NFIREA,*) MIN_QP,DELTAE,XLOCMX,V2_MIN,ITRMAX,NTHETA
C
      END IF
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C=======================================================================
C         READING THE TEMPERATURE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FINITETEMP') THEN
C
          READ(NFIREA,*) TEMP_T
C
          IF (ABS(TEMP_T).GT.1.D-12) IFTEMP=1
C
      END IF
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C=======================================================================
C         READING THE SWITCH TO SHELL CORRECTION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SHELLCORCT') THEN
C
          READ(NFIREA,*) IFSHEL
C
      END IF
C
      IF (trim(KEYWOR).EQ.'SHELLPARAM') THEN
C
          READ(NFIREA,*) GSTRUN,GSTRUP,HOMFAC,NPOLYN
C
      END IF
C
C@@@ SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C         READING THE SWITCH THAT DECIDES IF ONE RUNS/READS A HFBTHO
C         CALCULATION.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'HFBTHOISON') THEN
C
          READ(NFIREA,*) IFRTHO,CBETHO
C
      END IF
C
C@@@ HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO - HFBTHO
C=======================================================================
C         READING THE ITERATION STABILITY PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ITERAT_EPS'.OR.
     *    trim(KEYWOR).EQ.'ITERAT-EPS') THEN
C
          READ(NFIREA,*) EPSITE
C
      END IF
C
C=======================================================================
C         READING THE MAXIMAL NUMBER OF ITERATIONS FOR STABILITY TEST
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAXANTIOSC') THEN
C
          READ(NFIREA,*) NULAST
C
      END IF
C
C=======================================================================
C         READING THE MAXIMAL NUMBER OF ITERATIONS FOR
C         THE CONSTANT-STABILITY TEST
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAXANTICON') THEN
C
          READ(NFIREA,*) EPSCON,NUCONS
C
      END IF
C
C=======================================================================
C
C         THE CODE IS ABLE TO DETECT THE PING-PONG DIVERGENCE  WHICH
C         OCCURS WHEN THE ITERATION SCHEME GIVES ALTERNATING RESULTS
C         IN EVERY SECOND ITERATION.  UPON CONTINUING THE ITERATION,
C         BOTH SEQUENCES OF RESULTS,  THE EVEN SEQUENCE AND THE  ODD
C         SEQUENCE, BECOME PERFECTLY STABLE AND THE CORRECT SOLUTION
C         IS NEVER ATTAINED.
C
C         THE CODE RECOGNIZES SUCH A DIVERGENCE BY  CALCULATING  THE
C         AVERAGES AND VARIANCES OF THE STABILITY ENERGY, SEPARATELY
C         IN THE EVEN AND IN THE ODD SEQUENCES, OVER "NUPING"  PAIRS
C         OF  ITERATIONS. THE PING-PONG DIVERGENCE IS SIGNALLED WHEN
C         BOTH VARIANCES BECOME A FACTOR  "EPSPNG"  SMALLER THAN THE
C         ABSOLUTE VALUE OF THE DIFFERENCE OF AVERAGES, I.E.,
C
C         DISEVE < EPSPNG * ABS(AVREVE-AVRODD)
C         DISODD < EPSPNG * ABS(AVREVE-AVRODD)
C
C         UPON DISCOVERING THE PING-PONG DIEVERGENCE THE CODE ABORTS
C         THE ITERATION AND PRINTS THE TABLE OF MAXIMUM  DIFFERENCES
C         OF  SINGLE-PARTICLE  OBSERVABLES BETWEEN THE TWO SEQUENCES
C         OF ITERATIONS. THE MAXIMUM DIFFERENCES ARE DETERMINED  FOR
C         STATES IN EVERY   CHARGE - PARITY - SIGNATURE  BLOCK,  AND
C         SEPARATELY FOR PARTICLE AND HOLE STATES.  WHENEVER  SUCH A
C         MAXIMUM DIFFERENCE IS FOUND FOR A PARTICLE AND A HOLE WITH
C         ADJACENT  INDICES,  SUCH A PAIR IS PROPOSED AS A CANDIDATE
C         FOR THE DIABATIC BLOCKING CALCULATION.
C
C=======================================================================
C         READING DATA FOR THE PING-PONG DIVERGENCE TEST
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PING_PONG'.OR.
     *    trim(KEYWOR).EQ.'PING-PONG') THEN
C
          READ(NFIREA,*) EPSPNG,NUPING
C
      END IF
C
C=======================================================================
C=======================================================================
C
C         THE CODE IS ABLE TO DETECT THE  CHAOTIC  DIVERGENCE  WHICH
C         OCCURS WHEN THE ITERATION SCHEME GIVES CHAOTICALLY VARYING
C         RESULTS.
C
C         THE CODE RECOGNIZES SUCH A DIVERGENCE BY FINDING THE MAXIMA
C         IN THE SEQUENCE OF ABSOLUTE VALUES OF THE STABILITY ENERGY.
C         THE CHAOTIC DIVERGENCE IS SIGNALLED WHEN THERE ARE AT LEAST
C         "NUCHAO" INCRESES IN THE SEQUENCE OF MAXIMA FOUND.
C
C=======================================================================
C         READING DATA FOR THE CHAOTIC DIVERGENCE TEST
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CHAOTIC') THEN
C
          READ(NFIREA,*) NUCHAO
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER REQUESTING CALCULATION OF THE
C         QUASIPARTICLE STABILITY ENERGY (KARIM'S MAGIC FORMULA)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'QUASISTABI') THEN
C
          READ(NFIREA,*) IQPSTA
C
      END IF
C
C=======================================================================
C         READING THE SWITCH DEFINING THE INCLUSION OF THE HO POTENTIAL
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'INSERT_HO'.OR.
     *    trim(KEYWOR).EQ.'INSERT-HO') THEN
C
          READ(NFIREA,*) IPOTHO
C
      END IF
C
C=======================================================================
C         READING THE DEFINITION OF THE PHASE SPACE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHASESPACE') THEN
C
          READ(NFIREA,*) ((NUMBSP(IREVER,ICHARG),IREVER=0,NDREVE),
     *                                           ICHARG=0,NDISOS)
C
      END IF
C
C=======================================================================
C         READING THE SKYRME-SET ACRONYM
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SKYRME_SET'.OR.
     *    trim(KEYWOR).EQ.'SKYRME-SET') THEN
C
          READ(NFIREA,'(12X,A4)') SKYRME
C
      END IF
C
C=======================================================================
C         THE 2-BODY ZERO-RANGE COUPLING CONSTANT IS  IDENTICAL  TO  THE
C         SKYRME PARAMETER T0 AND IS ADDED TO IT BEFORE OTHER OPERATIONS
C         ON THE COUPLING CONSTANTS ARE PERFORMED. IT IS ONLY INTRODUCED
C         FOR CONVENIENCE OF HANDLING THE INPUT DATA.
C=======================================================================
C         READING THE ZERO-RANGE 2-BODY COUPLING CONSTANT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'2BODYDELTA') THEN
C
          READ(NFIREA,*) TWOINP,ITWOIN
C
      END IF
C
C=======================================================================
C         THE 3-BODY AND 4-BODY COUPLING CONSTANTS ARE DEFINED ACCORDING
C         TO DEFINITIONS INTRODUCED IN  PHYS.  SCR.  T154, 014013 (2013)
C         WITH THRINP = U0 (READ) OR THREEB (USED)
C         AND  FOUINP = V0 (READ) OR FOURBD (USED)
C=======================================================================
C         READING THE ZERO-RANGE 3-BODY COUPLING CONSTANT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'3BODYDELTA') THEN
C
          READ(NFIREA,*) THRINP,ITHRIN
C
      END IF
C
C=======================================================================
C         READING THE ZERO-RANGE 4-BODY COUPLING CONSTANT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'4BODYDELTA') THEN
C
          READ(NFIREA,*) FOUINP,IFOUIN
C
      END IF
C
C=======================================================================
C         THE 3-BODY GRADIENT COUPLING CONSTANTS ARE DEFINED ACCORDING
C         TO DEFINITIONS INTRODUCED IN  PHYS.  REV.  C88, 064326 (2013)
C         WITH TGRA10 = U1
C         WITH TGRA11 = Y1
C         WITH TGRA20 = U2
C         WITH TGRA21 = Y21
C         WITH TGRA22 = Y22
C=======================================================================
C         READING THE ZERO-RANGE 3-BODY COUPLING CONSTANTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'3BODYGRAD') THEN
C
          IRE3BU=1
C
          IF (IRE3BY.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS 3BODYGRAD AND 3BODYGRUY ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' 3BODYGRAD AND 3BODYGRUY SIMULTANEOUSLY IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
C
      END IF
C
      IF (trim(KEYWOR).EQ.'3BODYGRUY') THEN
C
          IRE3BY=1
C
          IF (IRE3BU.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS 3BODYGRAD AND 3BODYGRUY ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' 3BODYGRAD AND 3BODYGRUY SIMULTANEOUSLY IN NAMELI 2'
C
          END IF
C
          READ(NFIREA,*) TGRA10,TU1_Y1,TGRA20,TU2Y21,TU2Y22,IGRAIN
C
          IF (TGRA10.NE.0.0D0) THEN
              TGRA11=TU1_Y1/TGRA10
          ELSE
              IF (IGRAIN.EQ.1) THEN
                  WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' FOR KEYWORD 3BODYGRUY, TGRA10=0 IS''
     *                                                  ,1X,20(1H/),/,
     *                1X,20(1H/),'' FORBIDDEN IN THE INPUT  DATA  FILE''
     *                                                  ,1X,20(1H/),/)')
                  STOP 'TGRA10=0 FORBIDDEN IN NAMELI'
              END IF
          END IF
C
          IF (TGRA20.NE.0.0D0) THEN
              TGRA21=TU2Y21/TGRA20
              TGRA22=TU2Y22/TGRA20
          ELSE
              IF (IGRAIN.EQ.1) THEN
                  WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' FOR KEYWORD 3BODYGRUY, TGRA20=0 IS''
     *                                                  ,1X,20(1H/),/,
     *                1X,20(1H/),'' FORBIDDEN IN THE INPUT  DATA  FILE''
     *                                                  ,1X,20(1H/),/)')
                  STOP 'TGRA20=0 FORBIDDEN IN NAMELI'
              END IF
          END IF
C
      END IF
C
C=======================================================================
C         READING THE SKYRME PARAMETER SET REQUIRED BY ACRONYM "INPU"
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SKYRMEINPU') THEN
C
          READ(NFIREA,*) T0_DAT,X0_DAT,T1_DAT,X1_DAT,T2_DAT,X2_DAT,
     *                   T3_DAT,X3_DAT,WW_DAT,PO_DAT
C
      END IF
C
C=======================================================================
C         READING THE ERRORS TO CORRECT THE SKYRME PARAMETER SET
C         REQUIRED BY ACRONYM "INPU"
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SKYRME_ERR') THEN
C
          READ(NFIREA,*) T0_ERR,X0_ERR,T1_ERR,X1_ERR,T2_ERR,X2_ERR,
     *                   T3_ERR,X3_ERR,WW_ERR,PO_ERR
C
      END IF
C
C=======================================================================
C         READING THE FACTORS TO CORRECT THE SKYRME PARAMETER SET
C         REQUIRED BY ACRONYM "INPU"
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SKYRME_FAC') THEN
C
          READ(NFIREA,*) T0_FAC,X0_FAC,T1_FAC,X1_FAC,T2_FAC,X2_FAC,
     *                   T3_FAC,X3_FAC,WW_FAC,PO_FAC
C
      END IF
C
C=======================================================================
C         READING THE CHARGE-SYMMETRY-BREAKING COUPLING CONSTANTS
C         FOR CENTRAL TERM OF CLASS II
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CHARBREAK2') THEN
C
          READ(NFIREA,*) T02CBR,X02CBR,I_2CBR
C
      END IF
C
C=======================================================================
C         READING THE CHARGE-SYMMETRY-BREAKING COUPLING CONSTANTS
C         CLASS II
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CBR_CC_CL2'.OR.
     *    trim(KEYWOR).EQ.'CBR-CC-CL2') THEN
C
          READ(NFIREA,*) I_2CBR,
     *                   T02CBR,X02CBR,
     *                   T12CBR,X12CBR,
     *                   T22CBR,X22CBR
C
      END IF
C
C=======================================================================
C         READING THE CHARGE-SYMMETRY-BREAKING COUPLING CONSTANTS
C         FOR CENTRAL TERM OF CLASS III
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CHARBREAK3') THEN
C
          READ(NFIREA,*) T03CBR,X03CBR,I_3CBR
C
      END IF
C
C=======================================================================
C         READING THE CHARGE-SYMMETRY-BREAKING COUPLING CONSTANTS
C         CLASS III
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CBR_CC_CL3'.OR.
     *    trim(KEYWOR).EQ.'CBR-CC-CL3') THEN
C
          READ(NFIREA,*) I_3CBR,
     *                   T03CBR,X03CBR,
     *                   T13CBR,X13CBR,
     *                   T23CBR,X23CBR
C
      END IF
C
C=======================================================================
C         READING THE SWITCHES DEFINING THE STANDARD SKYRME-SET
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SKYRME_STD'.OR.
     *    trim(KEYWOR).EQ.'SKYRME-STD') THEN
C
          READ(NFIREA,*) ISTAND,KETA_J,KETA_W,KETACM,KETA_M
C
      END IF
C
C=======================================================================
C         READING THE SWITCH DEFINING THE (NON)STANDARD POWER OF THE
C         DENSITY-DEPENDENT TERM
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'POWERDENSI') THEN
C
          READ(NFIREA,*) POWERD,KETA_P
C
      END IF
C
C=======================================================================
C         READING THE SWITCH DEFINING THE (NON)STANDARD TENSOR
C         INTERACTIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SKYRMETENS') THEN
C
          READ(NFIREA,*) TEINPU,TOINPU,KETA_T
C
      END IF
C
C=======================================================================
C         READING THE SWITCH DEFINING THE SKYRME PAIRING INTERACTION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SKYRMEPAIR') THEN
C
          READ(NFIREA,*) KETAPA
C
      END IF
C
C=======================================================================
C         READING THE SWITCH REMOVING THE ZERO-RANGE PAIRING INTERACTION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NOZEROPAIR') THEN
C
          READ(NFIREA,*) NOZEPA
C
      END IF
C
C=======================================================================
C         READING THE GOGNY-SET CODE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'GOGNY_SET'.OR.
     *    trim(KEYWOR).EQ.'GOGNY-SET') THEN
C
          READ(NFIREA,'(12X,A4)') GOGNAM
C
      END IF
C
C=======================================================================
C         READING THE SWITCH DEFINING THE INCLUSION OR NOT OF THE LINEAR
C         TERMS IN TWO-BODY ROTATIONAL OR TRANSLATIONAL CORRECTION
C=======================================================================
C         IN  PRINCIPLE,  THE  TWO-BODY  ROTATIONAL  CORRECTION  INDUCES
C         TERMS IN THE MEAN FIELD THAT ARE LINEAR IN ANGULAR MOMENTA AND
C         THUS SUCH CORRECTIONS CAN BE FULLY INCLUDED  ONLY  FOR  BROKEN
C         SIMPLEX AND TIME-REVERSAL SYMMETRIES.
C
C         SIMILARLY,   THE  TWO-BODY  TRANSLATIONAL  CORRECTION  INDUCES
C         TERMS IN THE MEAN FIELD THAT ARE LINEAR IN LINEAR MOMENTA  AND
C         THUS SUCH CORRECTIONS CAN BE FULLY INCLUDED  ONLY  FOR  BROKEN
C         PARITY, SIMPLEX, AND TIME-REVERSAL SYMMETRIES.
C
C         THEREFORE, FOR "ITWOLI"=+1, THE CODE REFUSES TO CALCULATE  THE
C         TWO-BODY CORRECTIONS UNLESS APPROPRIATE SYMMETRIES ARE BROKEN.
C
C         HOWEVER, FOR VARIOUS COMBINATIONS OF ENFORCED PARITY, SIMPLEX,
C         OR TIME-REVERSAL  SYMMETRIES,  THE  APPROPRIATE  LINEAR  TERMS
C         SELF-CONSISTENTLY VANISH.
C
C         THEREFORE,  THE  SWITCH  BELOW  ("ITWOLI"=-1)  ALLOWS  ONE  TO
C         ANYHOW PROCEED  WITH  CALCULATIONS  OF  TWO-BODY  CORRECTIONS.
C         THEN, THE LINEAR TERMS WILL BE PRESENT OR  NOT,  DEPENDING  ON
C         THE REQUESTED SYMMETRIES.
C
C         MOREOVER, THE SWITCH BELOW ("ITWOLI"=0) ALLOWS ONE  TO  REMOVE
C         ALL SUCH LINEAR TERMS MANUALLY, WHICH IN THE PAST WAS ALSO  AN
C         OPTION USED IN OTHER CODES. THE USER SHOULD  USE  THIS  OPTION
C         WITH  CAUTION,  BECAUSE  IT  MAY   LEAD   TO   THE   LACK   OF
C         SELF-CONSISTENCY AND TO NON-CONVERGING CALCULATIONS.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TWOBODYLIN') THEN
C
          READ(NFIREA,*) ITWOLI
C
      END IF
C
C=======================================================================
C         READING THE SWITCH DEFINING THE ROTATIONAL CORRECTION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ROTAT_CORR'.OR.
     *    trim(KEYWOR).EQ.'ROTAT-CORR') THEN
C
          READ(NFIREA,*) KETA_R
C
      END IF
C
C=======================================================================
C         READING THE SWITCHES REQUESTING THE CALCULATION OF PROJECTED
C         AVERAGE VALUES OF J^2 AND T^2
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROJ_J2_T2'.OR.
     *    trim(KEYWOR).EQ.'PROJ-J2-T2') THEN
C
          READ(NFIREA,*) KETAJ2,KETAT2
C
      END IF
C
C=======================================================================
C         READING THE USER DEFINED HBMINP=HBAR^2/2M PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'HBAR2OVR2M') THEN
C
          READ(NFIREA,*) HBMINP
C
      END IF
C
C=======================================================================
C         READING THE USER DEFINED SPIN-ORBIT PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPIN_ORBIT'.OR.
     *    trim(KEYWOR).EQ.'SPIN-ORBIT') THEN
C
          READ(NFIREA,*) W0_INP,W0PINP
C
      END IF
C
C=======================================================================
C         READING THE USER DEFINED SPIN-ORBIT PARAMETERS' ERRORS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPINORBERR') THEN
C
          READ(NFIREA,*) W0_ERR,W0PERR
C
      END IF
C
C=======================================================================
C         READING THE USER DEFINED SPIN-ORBIT-ERRORS' FACTORS
C         ATENTION: THIS KEYWORD RECALCULATES SPIN-ORBIT PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPINORBFAC') THEN
C
          READ(NFIREA,*) W0_FAC,W0PFAC
C
          W0_INP=W0_INP+W0_FAC*W0_ERR
          W0PINP=W0PINP+W0PFAC*W0PERR
C
      END IF
C
C=======================================================================
C         READING THE LANDAU PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'LANDAU') THEN
C
          READ(NFIREA,*) LANODD,
     *                   X0_LAN,X1_LAN,G0_LAN,G0PLAN,G1_LAN,G1PLAN
C
      END IF
C
C=======================================================================
C         READING THE LANDAU SWITCH FOR USING THE ORIGINAL OR SCALED
C         COUPLING CONSTANTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'LAN4SCALED') THEN
C
          READ(NFIREA,*) LANSCA
C
      END IF
C
C=======================================================================
C         READING THE SATURATION VALUES REQUIRED WHEN USING
C         THE LANDAU PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'LANDAU_SAT'.OR.
     *    trim(KEYWOR).EQ.'LANDAU-SAT') THEN
C
          READ(NFIREA,*) HBMSAT,RHOSAT,EFFSAT
C
      END IF
C
C=======================================================================
C         READING THE TIME-EVEN, TIME-ODD, AND TENSOR T-S
C         SKYRME-FUNCTIONAL SCALING FACTORS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EVE_SCA_TS'.OR.
     *    trim(KEYWOR).EQ.'EVE-SCA-TS') THEN
C
          READ(NFIREA,*) (STSALL(NUCOUP),NUCOUP=1,NDCOUP/2)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'ODD_SCA_TS'.OR.
     *    trim(KEYWOR).EQ.'ODD-SCA-TS') THEN
C
          READ(NFIREA,*) (STSALL(NUCOUP),NUCOUP=NDCOUP/2+1,NDCOUP)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'TEN_SCA_TS'.OR.
     *    trim(KEYWOR).EQ.'TEN-SCA-TS') THEN
C
          READ(NFIREA,*) (STSALL(NUCOUP),NUCOUP=NDCOUP+1,NDCOUP+6)
C
      END IF
C
C=======================================================================
C         READING THE TIME-EVEN, TIME-ODD, AND TENSOR P-M
C         SKYRME-FUNCTIONAL SCALING FACTORS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EVE_SCA_PM'.OR.
     *    trim(KEYWOR).EQ.'EVE-SCA-PM') THEN
C
          READ(NFIREA,*) (SPMALL(NUCOUP),NUCOUP=1,NDCOUP/2)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'ODD_SCA_PM'.OR.
     *    trim(KEYWOR).EQ.'ODD-SCA-PM') THEN
C
          READ(NFIREA,*) (SPMALL(NUCOUP),NUCOUP=NDCOUP/2+1,NDCOUP)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'TEN_SCA_PM'.OR.
     *    trim(KEYWOR).EQ.'TEN-SCA-PM') THEN
C
          READ(NFIREA,*) (SPMALL(NUCOUP),NUCOUP=NDCOUP+1,NDCOUP+6)
C
      END IF
C
C=======================================================================
C         READING THE TIME-EVEN, TIME-ODD, AND TENSOR T-S
C         SKYRME-FUNCTIONAL ADDITIVE CONSTANTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EVE_ADD_TS'.OR.
     *    trim(KEYWOR).EQ.'EVE-ADD-TS') THEN
C
          READ(NFIREA,*) (ATSALL(NUCOUP),NUCOUP=1,NDCOUP/2)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'ODD_ADD_TS'.OR.
     *    trim(KEYWOR).EQ.'ODD-ADD-TS') THEN
C
          READ(NFIREA,*) (ATSALL(NUCOUP),NUCOUP=NDCOUP/2+1,NDCOUP)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'TEN_ADD_TS'.OR.
     *    trim(KEYWOR).EQ.'TEN-ADD-TS') THEN
C
          READ(NFIREA,*) (ATSALL(NUCOUP),NUCOUP=NDCOUP+1,NDCOUP+6)
C
      END IF
C
C=======================================================================
C         READING THE TIME-EVEN, TIME-ODD, AND TENSOR P-M
C         SKYRME-FUNCTIONAL ADDITIVE CONSTANTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EVE_ADD_PM'.OR.
     *    trim(KEYWOR).EQ.'EVE-ADD-PM') THEN
C
          READ(NFIREA,*) (APMALL(NUCOUP),NUCOUP=1,NDCOUP/2)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'ODD_ADD_PM'.OR.
     *    trim(KEYWOR).EQ.'ODD-ADD-PM') THEN
C
          READ(NFIREA,*) (APMALL(NUCOUP),NUCOUP=NDCOUP/2+1,NDCOUP)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'TEN_ADD_PM'.OR.
     *    trim(KEYWOR).EQ.'TEN-ADD-PM') THEN
C
          READ(NFIREA,*) (APMALL(NUCOUP),NUCOUP=NDCOUP+1,NDCOUP+6)
C
      END IF
C
C=======================================================================
C         READING THE PAIRING-STRENGTHS SCALING FACTORS
C         ATTENTION: IF IAVRGG (AVERAGE - G) IS EQUAL TO 1, THE PAIRING
C         =========  CONSTANTS ARE   C A L C U L A T E D   ACCORDING TO
C                    BOLSTERLI ET AL., PHYS. REV. C5 P.1050;
C         THE SCALING FACTORS ARE APPLIED IN ANY CASE;  SET 1 TO AVOID.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'G_SCALING'.OR.
     *    trim(KEYWOR).EQ.'G-SCALING') THEN
C
          READ(NFIREA,*) FACTGN,FACTGP
C
      END IF
C
      IF (trim(KEYWOR).EQ.'G_AUTOCALC'.OR.
     *    trim(KEYWOR).EQ.'G-AUTOCALC') THEN
C
          READ(NFIREA,*) IAVRGG
C
      END IF
C
C=======================================================================
C         READING THE ISOVECTOR FERMI ENERGIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ISO_FERMI'.OR.
     *    trim(KEYWOR).EQ.'ISO-FERMI'.OR.
     *    trim(KEYWOR).EQ.'FERMI_XYZ'.OR.
     *    trim(KEYWOR).EQ.'FERMI-XYZ') THEN
C
          READ(NFIREA,*) (FERISO(KARTEZ),KARTEZ=1,NDKART)
C
      END IF
C
C=======================================================================
C         READING THE ISOSCALAR FERMI ENERGY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FERMI_SCA'.OR.
     *    trim(KEYWOR).EQ.'FERMI-SCA') THEN
C
          READ(NFIREA,*) FERISO(0)
C
      END IF
C
C=======================================================================
C         READING THE TILTED POLAR ISOVECTOR FERMI ENERGIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FERMI_RTP'.OR.
     *    trim(KEYWOR).EQ.'FERMI-RTP') THEN
C
          READ(NFIREA,*) FE_RAD,FE_THE,FE_PHI,FE_OFF
C
          FERTHE=FE_THE/DEGRAD
          FERPHI=FE_PHI/DEGRAD
C
          FERISO(1)=FE_RAD*SIN(FERTHE)*COS(FERPHI)
          FERISO(2)=FE_RAD*SIN(FERTHE)*SIN(FERPHI)
          FERISO(3)=FE_RAD*COS(FERTHE)+FE_OFF
C
      END IF
C
C=======================================================================
C         READING THE INITIAL HFB FERMI ENERGIES AND HFB PAIRING GAPS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'INI_FERMI'.OR.
     *    trim(KEYWOR).EQ.'INI-FERMI') THEN
C
          READ(NFIREA,*) (FERINI(ICHARG),ICHARG=0,NDISOS)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'INI_DELTA'.OR.
     *    trim(KEYWOR).EQ.'INI-DELTA') THEN
C
          READ(NFIREA,*) (DELINI(ICHARG),ICHARG=0,NDISOS)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'INI_LIPKIN') THEN
C
          READ(NFIREA,*) (FE2INI(ICHARG),ICHARG=0,NDISOS)
C
      END IF
C
C=======================================================================
C         READING THE FIXED HFB FERMI ENERGIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FIXFERMI_N'.OR.
     *    trim(KEYWOR).EQ.'FIXFERMI-N') THEN
C
          READ(NFIREA,*) FERFIN,IFEFIN
C
      END IF
C
      IF (trim(KEYWOR).EQ.'FIXFERMI_P'.OR.
     *    trim(KEYWOR).EQ.'FIXFERMI-P') THEN
C
          READ(NFIREA,*) FERFIP,IFEFIP
C
      END IF
C
C=======================================================================
C         READING THE FIXED LIPKIN-NOGAMI LAMBDA2 PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FIXLAMB2_N'.OR.
     *    trim(KEYWOR).EQ.'FIXLAMB2-N') THEN
C
          READ(NFIREA,*) FE2FIN,IF2FIN
C
      END IF
C
      IF (trim(KEYWOR).EQ.'FIXLAMB2_P'.OR.
     *    trim(KEYWOR).EQ.'FIXLAMB2-P') THEN
C
          READ(NFIREA,*) FE2FIP,IF2FIP
C
      END IF
C
C=======================================================================
C         READING THE STIFFNESS OF THE ALM ADJUSTEMENT FOR FERMI ENERGY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ALMFERMI_N'.OR.
     *    trim(KEYWOR).EQ.'ALMFERMI-N') THEN
C
          READ(NFIREA,*) FERALN,IFERAN
C
      END IF
C
      IF (trim(KEYWOR).EQ.'ALMFERMI_P'.OR.
     *    trim(KEYWOR).EQ.'ALMFERMI-P') THEN
C
          READ(NFIREA,*) FERALP,IFERAP
C
      END IF
C
C=======================================================================
C         ENFORCING EVEN NUMBERS OF QUASIPARTICLES FOR PFAFFIAN METHOD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EVENQPNUMB') THEN
C
          READ(NFIREA,*) NUQEVE
C
      END IF
C
C=======================================================================
C         READING THE FIXED HFB PAIRING GAPS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FIXDELTA_N'.OR.
     *    trim(KEYWOR).EQ.'FIXDELTA-N') THEN
C
          READ(NFIREA,*) DELFIN,IDEFIN
C
      END IF
C
      IF (trim(KEYWOR).EQ.'FIXDELTA_P'.OR.
     *    trim(KEYWOR).EQ.'FIXDELTA-P') THEN
C
          READ(NFIREA,*) DELFIP,IDEFIP
C
      END IF
C
C=======================================================================
C         ENFORCING VACUUM CONFIGURATIONS FOR HF CALCULATIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACUUMCONF') THEN
C
          READ(NFIREA,*) IVACUM
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS OF QUASIPARTICLE BLOCKING IN  THE  CASE
C         OF THE PARITY/SIGNATURE SYMMETRY CONSERVED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BLOCKSIG_N'.OR.
     *    trim(KEYWOR).EQ.'BLOCKSIG-N') THEN
C
          READ(NFIREA,*) INSIGN,IPSIGN,ISSIGN,IDSIGN
C
      END IF
C
      IF (trim(KEYWOR).EQ.'BLOCKSIG_P'.OR.
     *    trim(KEYWOR).EQ.'BLOCKSIG-P') THEN
C
          READ(NFIREA,*) INSIGP,IPSIGP,ISSIGP,IDSIGP
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS OF QUASIPARTICLE BLOCKING IN  THE  CASE
C         OF THE SIMPLEX SYMMETRY CONSERVED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BLOCKSIM_N'.OR.
     *    trim(KEYWOR).EQ.'BLOCKSIM-N') THEN
C
          READ(NFIREA,*) INSIMN,IRSIMN,IDSIMN
C
      END IF
C
      IF (trim(KEYWOR).EQ.'BLOCKSIM_P'.OR.
     *    trim(KEYWOR).EQ.'BLOCKSIM-P') THEN
C
          READ(NFIREA,*) INSIMP,IRSIMP,IDSIMP
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS OF QUASIPARTICLE BLOCKING IN  THE  CASE
C         OF THE PARITY SYMMETRY CONSERVED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BLOCKSIQ_N'.OR.
     *    trim(KEYWOR).EQ.'BLOCKSIQ-N') THEN
C
          INPQBN=1
C
          IF (INPQMN.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS MBLOCSIQ_N AND BLOCKSIQ_N''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY (1)''
     *                                                  ,2X,20(1H/),/)')
              STOP ' MBLOCSIQ_N AND BLOCKSIQ_N SIMULTANEOUS IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) INSIQN(1),IPSIQN(1),IDSIQN(1)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'BLOCKSIQ_P'.OR.
     *    trim(KEYWOR).EQ.'BLOCKSIQ-P') THEN
C
          INPQBP=1
C
          IF (INPQMP.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS MBLOCSIQ_P AND BLOCKSIQ_P''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY (1)''
     *                                                  ,2X,20(1H/),/)')
              STOP ' MBLOCSIQ_P AND BLOCKSIQ_P SIMULTANEOUS IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) INSIQP(1),IPSIQP(1),IDSIQP(1)
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS OF MULTI-QUASIPARTICLE BLOCKING IN  THE
C         CASE OF THE PARITY SYMMETRY CONSERVED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MBLOCSIQ_N'.OR.
     *    trim(KEYWOR).EQ.'MBLOCSIQ-N') THEN
C
          INPQMN=1
C
          IF (INPQBN.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS MBLOCSIQ_N AND BLOCKSIQ_N''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY (2)''
     *                                                  ,2X,20(1H/),/)')
              STOP ' MBLOCSIQ_N AND BLOCKSIQ_N SIMULTANEOUS IN NAMELI 2'
C
          END IF
C
          READ(NFIREA,*) NBBLOC
C
          IF (NBBLOC.GT.NDBLOC)
     *        STOP ' INCREASE NDBLOC FOR PARITY NEUTRONS IN NAMELI'
C
          READ(NFIREA,*) (INSIQN(NUBLOC),IPSIQN(NUBLOC),IDSIQN(NUBLOC),
     *                                                NUBLOC=1,NBBLOC)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'MBLOCSIQ_P'.OR.
     *    trim(KEYWOR).EQ.'MBLOCSIQ-P') THEN
C
          INPQMP=1
C
          IF (INPQBP.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS MBLOCSIQ_P AND BLOCKSIQ_P''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' MBLOCSIQ_P AND BLOCKSIQ_P SIMULTANEOUS IN NAMELI 2'
C
          END IF
C
          READ(NFIREA,*) NBBLOC
C
          IF (NBBLOC.GT.NDBLOC)
     *        STOP ' INCREASE NDBLOC FOR PARITY PROTONS IN NAMELI'
C
          READ(NFIREA,*) (INSIQP(NUBLOC),IPSIQP(NUBLOC),IDSIQP(NUBLOC),
     *                                                NUBLOC=1,NBBLOC)
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS OF QUASIPARTICLE BLOCKING IN  THE  CASE
C         OF NO SYMMETRY CONSERVED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BLOCKSIZ_N'.OR.
     *    trim(KEYWOR).EQ.'BLOCKSIZ-N') THEN
C
          INPZBN=1
C
          IF (INPZMN.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS MBLOCSIZ_N AND BLOCKSIZ_N''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' MBLOCSIZ_N AND BLOCKSIZ_N SIMULTANEOUS IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) INSIZN(1),IDSIZN(1)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'BLOCKSIZ_P'.OR.
     *    trim(KEYWOR).EQ.'BLOCKSIZ-P') THEN
C
          INPZBP=1
C
          IF (INPZMP.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS MBLOCSIZ_P AND BLOCKSIZ_P''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' MBLOCSIZ_P AND BLOCKSIZ_P SIMULTANEOUS IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) INSIZP(1),IDSIZP(1)
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS OF MULTI-QUASIPARTICLE BLOCKING IN  THE
C         CASE OF NO SYMMETRY CONSERVED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MBLOCSIZ_N'.OR.
     *    trim(KEYWOR).EQ.'MBLOCSIZ-N') THEN
C
          INPZMN=1
C
          IF (INPZBN.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS MBLOCSIZ_N AND BLOCKSIZ_N''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' MBLOCSIZ_N AND BLOCKSIZ_N SIMULTANEOUS IN NAMELI 2'
C
          END IF
C
          READ(NFIREA,*) NBBLOC
C
          IF (NBBLOC.GT.NDBLOC)
     *        STOP ' INCREASE NDBLOC FOR NOSYM NEUTRONS IN NAMELI'
C
          READ(NFIREA,*) (INSIZN(NUBLOC),IDSIZN(NUBLOC),NUBLOC=1,NBBLOC)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'MBLOCSIZ_P'.OR.
     *    trim(KEYWOR).EQ.'MBLOCSIZ-P') THEN
C
          INPZMP=1
C
          IF (INPZBP.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS MBLOCSIZ_P AND BLOCKSIZ_P''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' MBLOCSIZ_P AND BLOCKSIZ_P SIMULTANEOUS IN NAMELI 2'
C
          END IF
C
          READ(NFIREA,*) NBBLOC
C
          IF (NBBLOC.GT.NDBLOC)
     *        STOP ' INCREASE NDBLOC FOR NOSYM PROTONS IN NAMELI'
C
          READ(NFIREA,*) (INSIZP(NUBLOC),IDSIZP(NUBLOC),NUBLOC=1,NBBLOC)
C
      END IF
C
C=======================================================================
C         READING THE SWITCHES THAT DECIDE  UPON  THE  QUASIPARTICLE
C         BLOCKING BASED ON THE FIXED SINGLE-PARTICLE WAVE FUNCTIONS
C=======================================================================
C         FOR IFIBLN = 1 THE   FIXED  NEUTRON SINGLE-PARTICLE WAVE
C                        FUNCTION WILL BE USED
C         FOR IFIBLN = 0 THE VARIABLE NEUTRON SINGLE-PARTICLE WAVE
C                        FUNCTION WILL BE USED
C         FOR IFIBLP = 1 THE   FIXED   PROTON SINGLE-PARTICLE WAVE
C                        FUNCTION WILL BE USED
C         FOR IFIBLP = 0 THE VARIABLE  PROTON SINGLE-PARTICLE WAVE
C                        FUNCTION WILL BE USED
C=======================================================================
C         FOR INIBLN = 1 THE NEUTRON SINGLE-PARTICLE WAVE FUNCTION WILL
C                        BE     INITIALIZED AT THE FIRST ITERATION
C         FOR INIBLN = 0 THE NEUTRON SINGLE-PARTICLE WAVE FUNCTION WILL
C                        NOT BE INITIALIZED AT THE FIRST ITERATION
C         FOR INIBLP = 1 THE  PROTON SINGLE-PARTICLE WAVE FUNCTION WILL
C                        BE     INITIALIZED AT THE FIRST ITERATION
C         FOR INIBLP = 0 THE  PROTON SINGLE-PARTICLE WAVE FUNCTION WILL
C                        NOT BE INITIALIZED AT THE FIRST ITERATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BLOCKFIX_N'.OR.
     *    trim(KEYWOR).EQ.'BLOCKFIX-N') THEN
C
          READ(NFIREA,*) IFIBLN,INIBLN
C
      END IF
C
      IF (trim(KEYWOR).EQ.'BLOCKFIX_P'.OR.
     *    trim(KEYWOR).EQ.'BLOCKFIX-P') THEN
C
          READ(NFIREA,*) IFIBLP,INIBLP
C
      END IF
C
C=======================================================================
C         READING THE COUPLING CONSTANTS OF THE PAIRING FORCE IN THE
C         V0-V1-POWER REPRESENTATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PAIRNFORCE') THEN
C
          READ(NFIREA,*) PRHD_N,PRHDDN,POWDRN
C
          CALL RHODEP(1,PRHD_N,PRHDDN,PRHDSN,POWDRN)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'PAIRPFORCE') THEN
C
          READ(NFIREA,*) PRHD_P,PRHDDP,POWDRP
C
          CALL RHODEP(1,PRHD_P,PRHDDP,PRHDSP,POWDRP)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'PAIR_FORCE'.OR.
     *    trim(KEYWOR).EQ.'PAIR-FORCE') THEN
C
          READ(NFIREA,*) PRHD_T,PRHDDT,POWDRT
C
          PRHD_N=PRHD_T
          PRHDDN=PRHDDT
          POWDRN=POWDRT
C
          CALL RHODEP(1,PRHD_N,PRHDDN,PRHDSN,POWDRN)
C
          PRHD_P=PRHD_T
          PRHDDP=PRHDDT
          POWDRP=POWDRT
C
          CALL RHODEP(1,PRHD_P,PRHDDP,PRHDSP,POWDRP)
C
      END IF
C
C=======================================================================
C         READING THE COUPLING CONSTANTS OF THE PAIRING FORCE IN THE
C         V0-RHO-POWER REPRESENTATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PAIRNINTER') THEN
C
          READ(NFIREA,*) PRHD_N,PRHDSN,POWDRN
C
          CALL RHODEP(2,PRHD_N,PRHDDN,PRHDSN,POWDRN)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'PAIRPINTER') THEN
C
          READ(NFIREA,*) PRHD_P,PRHDSP,POWDRP
C
          CALL RHODEP(2,PRHD_P,PRHDDP,PRHDSP,POWDRP)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'PAIR_INTER'.OR.
     *    trim(KEYWOR).EQ.'PAIR-INTER') THEN
C
          READ(NFIREA,*) PRHD_T,PRHDST,POWDRT
C
          PRHD_N=PRHD_T
          PRHDSN=PRHDST
          POWDRN=POWDRT
C
          CALL RHODEP(2,PRHD_N,PRHDDN,PRHDSN,POWDRN)
C
          PRHD_P=PRHD_T
          PRHDSP=PRHDST
          POWDRP=POWDRT
C
          CALL RHODEP(2,PRHD_P,PRHDDP,PRHDSP,POWDRP)
C
      END IF
C
C=======================================================================
C         READING THE HFB PAIRING CUTOFF ENERGY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CUTOFF') THEN
C
          READ(NFIREA,*) ECUTOF
C
      END IF
C
C=======================================================================
C         READING THE HFB PAIRING CUTOFF NUMBERS OF STATES IN THE
C         NO-SYMMTRY CASE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NUMBCUTOFF'.OR.
     *    trim(KEYWOR).EQ.'NUMBCUTSIZ') THEN
C
          READ(NFIREA,*) NCUSIZ(0),NCUSIZ(1)
C
      END IF
C
C=======================================================================
C         READING THE HFB PAIRING CUTOFF NUMBERS OF STATES IN THE
C         PARITY CASE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NUMBCUTSIQ') THEN
C
          READ(NFIREA,*) NCUSIQ(0,0),NCUSIQ(0,1),
     *                   NCUSIQ(1,0),NCUSIQ(1,1)
C
      END IF
C
C=======================================================================
C         READING NUMERICAL PARAMETERS THAT ARE USED IN QUABCS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PARAQUABCS') THEN
C
          READ(NFIREA,*) XARACC,XORLIM,XERLIM,XCCLIM,NAXQUA,IPQBCS
C
          IF (XARACC.GT.0.0D0.AND.IPQBCS.EQ.1) PARACC=XARACC
          IF (XORLIM.GT.0.0D0.AND.IPQBCS.EQ.1) CORLIM=XORLIM
          IF (XERLIM.GT.0.0D0.AND.IPQBCS.EQ.1) DERLIM=XERLIM
          IF (XCCLIM.GT.0.0D0.AND.IPQBCS.EQ.1) OCCLIM=XCCLIM
          IF (NAXQUA.GT.0    .AND.IPQBCS.EQ.1) MAXQUA=NAXQUA
C
      END IF
C
C=======================================================================
C         READING THE SWITCH DECIDING ON WHETHER ONLY THE QUASIPARTICLES
C         WITH ENERGIES BELOW 'ECUTOF' WILL BE TAKEN INTO ACCOUNT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CUT_SPECTR'.OR.
     *    trim(KEYWOR).EQ.'CUT-SPECTR') THEN
C
          READ(NFIREA,*) LIMQUA
C
      END IF
C
C=======================================================================
C         READING THE SWITCH DECIDING ON WHETHER THE EQUIVALENT
C         QUASIPARTICLE ENERGIES WILL BE CUT RELATIVELY TO THE FERMI
C         ENERGIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FERMICUT') THEN
C
          READ(NFIREA,*) LAMCUT
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS WHICH CONTROL THE CALCULATION OF THE
C         PAIRING MATRIX ELEMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PAIR_MATRI'.OR.
     *    trim(KEYWOR).EQ.'PAIR-MATRI') THEN
C
          READ(NFIREA,*) IDESTA,IDEMID,IDESTO,IDEDIS
C
      END IF
C
C=======================================================================
C=======================================================================
C
C         SYMMETRIES ARE DEFINED IN TERMS OF:
C
C         0. THE SPHERICAL SYMMETRY
C
C         (ISPHER=1 => SPHERICAL SYMMETRY CONSERVED)
C
C         1. THE Y_SIMPLEX
C
C         (ISIMPY=1 => Y_SIMPLEX     CONSERVED)
C         (ISIMPY=0 => Y_SIMPLEX NON CONSERVED)
C
C         2. THE Y_SIGNATURE
C
C         (ISIGNY=1 => Y_SIGNATURE     CONSERVED)
C         (ISIGNY=0 => Y_SIGNATURE NON CONSERVED)
C
C         3. THE PARITY
C
C         (IPARTY=1 => PARITY          CONSERVED)
C         (IPARTY=0 => PARITY          CONSERVED)
C         (IPARTY=-1=> PARITY DETERMINED ACCORDING TO ISIMPY AND ISIGNY)
C
C         4. THE X_SIMPLEX*TIME_REVERSAL
C
C         (ISIMTX=1 => X_SIMPLEX*TIME_REVERSAL     CONSERVED)
C         (ISIMTX=0 => X_SIMPLEX*TIME_REVERSAL NON CONSERVED)
C
C         5. THE Y_SIMPLEX*TIME_REVERSAL
C
C         (JSIMTY=1 => Y_SIMPLEX*TIME_REVERSAL     CONSERVED)
C         (JSIMTY=0 => Y_SIMPLEX*TIME_REVERSAL NON CONSERVED)
C         (JSIMTY=-1=> Y_SIMPLEX*TIME_REVERSAL DETERMINED FROM IROTAT)
C
C         6. THE Z_SIMPLEX*TIME_REVERSAL
C
C         (ISIMTZ=1 => Z_SIMPLEX*TIME_REVERSAL     CONSERVED)
C         (ISIMTZ=0 => Z_SIMPLEX*TIME_REVERSAL NON CONSERVED)
C
C=======================================================================
C         NOT ALL THE COMBINATIONS OF SYMMETRY  SWITCHES  ARE
C         ALLOWED.
C=======================================================================
C         ATTENTION: PARAMETER IPARTY IS PREDEFINED TO -1 AND
C                    READ FROM THE DATA.
C
C                    IF IPARTY IS NOT EQUAL TO  -1  THEN  THE
C                    VALUE OF ISIQTY IS SET EQUAL  TO  IPARTY.
C
C                    IF IPARTY IS EQUAL TO -1 THEN THE  VALUE
C                    OF ISIQTY IS DETERMINED ACCORDING TO THE
C                    FOLLOWING TABLE:
C
C                    ISIMPY=1 AND ISIGNY=1  ==>  ISIQTY=1
C                    ISIMPY=0  OR ISIGNY=0  ==>  ISIQTY=0
C
C                    VALUE OF IPARTY=-1 IS ALLOWED  ONLY  FOR
C                    THE SAKE OF COMPATIBILITY  WITH  EARLIER
C                    VERSIONS (BEFORE 1.96C).
C
C                    "ISIQTY" DECIDES INSIDE THE  PROGRAM  ON
C                    WHETHER OR NOT  THE PARITY IS CONSERVED.
C
C=======================================================================
C         THE PRODUCT OF ANY OF THE TWO SYMMETRY OPERATORS  FROM  THE
C         SET: (Y-SIMPLEX, Y-SIGNATURE, PARITY) IS EQUAL TO THE THIRD
C         ONE. THEREFORE, IF TWO OF THEM ARE CONSERVED, THE THIRD ONE
C         HAS TO BE CONSERVED TOO.
C=======================================================================
C         THE COMPLETE TABLE OF ALL THE VALUES OF THE ABOVE  SYMMETRY
C         SWITCHES IS AS FOLLOWS:
C
C         ISIMPY = 1,  ISIGNY = 1,  ISIQTY = 1  ===>  ALLOWED
C         ISIMPY = 1,  ISIGNY = 1,  ISIQTY = 0  ===>  IMPOSSIBLE
C         ISIMPY = 1,  ISIGNY = 0,  ISIQTY = 1  ===>  IMPOSSIBLE
C         ISIMPY = 1,  ISIGNY = 0,  ISIQTY = 0  ===>  ALLOWED
C         ISIMPY = 0,  ISIGNY = 1,  ISIQTY = 1  ===>  IMPOSSIBLE
C         ISIMPY = 0,  ISIGNY = 1,  ISIQTY = 0  ===>  ALLOWED*
C         ISIMPY = 0,  ISIGNY = 0,  ISIQTY = 1  ===>  ALLOWED
C         ISIMPY = 0,  ISIGNY = 0,  ISIQTY = 0  ===>  ALLOWED
C=======================================================================
C         HOWEVER, IN THE PRESENT VERSIONS, FOUR OF THESE COMBINATIONS
C         OF THE ALLOWED SYMMETRY SWITCHES ARE IMPLEMENTED DYNAMICALLY,
C         I.E., THE SYMMETRIES ARE USED FOR BLOCK-DIAGONALIZATIOTS AND
C         DEFINITIONS OF QUANTUM NUMBERS. THE FIFTH ONE IS IMPLEMENTED
C         STATICALLY, I.E., ONLY THE DENSITIES ARE SYMMETRIEZED, WHILE
C         THE REST OF THE CODE WORKS IN THE MODE CORRESPONDING  TO  NO
C         CONSERVED SYMMETRIES.
C=======================================================================
C         THE COMBINATIONS IMPLEMENTED DYNAMICALLY CORRESPOND  TO  THE
C         FOLLOWING BRANCHING TREE:
C
C                          ISIGNY=1  ====>  (AND ISIQTY=1 IS IMPLIED)
C                         /
C                 ISIMPY=1
C               /         \
C              /           ISIGNY=0  ====>  (AND ISIQTY=0 IS IMPLIED)
C         START
C              \           ISIQTY=1  ====>  (AND ISIGNY=0 IS IMPLIED)
C               \         /
C                 ISIMPY=0
C                         \
C                          ISIQTY=0  ====>  (AND ISIGNY=0 IS IMPLIED)
C
C=======================================================================
C         ATTENTION: PARAMETER ISIMTY IS PREDEFINED TO -1 AND
C                    READ FROM THE DATA.
C
C                    IF ISIMTY IS NOT EQUAL TO  -1  THEN  THE
C                    VALUE OF JSIMTY IS SET EQUAL  TO  ISIMTY.
C
C                    IF ISIMTY IS EQUAL TO -1 THEN THE  VALUE
C                    OF JSIMTY IS SET EQUAL TO 1-IROTAT:
C
C                    VALUE OF ISIMTY=-1 IS ALLOWED  ONLY  FOR
C                    THE SAKE OF COMPATIBILITY  WITH  EARLIER
C                    VERSIONS (BEFORE 2.05J).
C
C                    "JSIMTY" DECIDES INSIDE THE  PROGRAM  ON
C                    WHETHER OR NOT THE Y-SIMPLEX*TIME_REVER.
C                    IS CONSERVED.
C
C=======================================================================
C         THE PRODUCT OF ANY OF THE TWO SYMMETRY OPERATORS  FROM  THE
C         SET (Y-SIMPLEX, Y-SIMPLEX^T, TIME-REVERSAL) IS EQUAL TO THE
C         THIRD ONE. THEREFORE, IF TWO OF  THEM  ARE  CONSERVED,  THE
C         THIRD ONE HAS TO BE CONSERVED TOO.
C=======================================================================
C         THE COMPLETE TABLE OF ALL THE VALUES OF THE ABOVE  SYMMETRY
C         SWITCHES IS AS FOLLOWS:
C
C         ISIMPY = 1,  IROTAT = 0,  JSIMTY = 1  ===>  ALLOWED
C         ISIMPY = 1,  IROTAT = 1,  JSIMTY = 1  ===>  IMPOSSIBLE
C         ISIMPY = 1,  IROTAT = 0,  JSIMTY = 0  ===>  IMPOSSIBLE
C         ISIMPY = 1,  IROTAT = 1,  JSIMTY = 0  ===>  ALLOWED
C         ISIMPY = 0,  IROTAT = 0,  JSIMTY = 1  ===>  IMPOSSIBLE
C         ISIMPY = 0,  IROTAT = 1,  JSIMTY = 1  ===>  ALLOWED
C         ISIMPY = 0,  IROTAT = 0,  JSIMTY = 0  ===>  ALLOWED
C         ISIMPY = 0,  IROTAT = 1,  JSIMTY = 0  ===>  ALLOWED
C
C         THE PATAMETER JSIMTY HAS TO BE CONSISTENT  WITH  THE  OTHER
C         TWO PARAMETERS ISIMPY AND IROTAT ACCORDING TO THE  STANDARD
C         D2H GROUP MULTIPLICATION TABLE.
C
C         ATTENTION: NOTE THAT THE TIME-REVERSAL IS CONSERVED OR  NOT
C                    FOR IROTAT = 0 OR IROTAT = 1, RESPECTIVELY.
C
C=======================================================================
C         THE PRODUCT OF ANY OF THE TWO SYMMETRY OPERATORS  FROM  THE
C         SET (Y-SIGNATURE, X-SIMPLEX^T, Z-SIMPLEX^T) IS EQUAL TO THE
C         THIRD ONE. THEREFORE, IF ANY TWO OF THEM ARE CONSERVED, THE
C         THIRD ONE HAS TO BE CONSERVED TOO.
C=======================================================================
C         THE COMPLETE TABLE OF ALL THE VALUES OF THE ABOVE  SYMMETRY
C         SWITCHES IS AS FOLLOWS:
C
C         ISIGNY = 1,  ISIMTX = 1,  ISIMTZ = 1  ===>  ALLOWED
C         ISIGNY = 1,  ISIMTX = 1,  ISIMTZ = 0  ===>  IMPOSSIBLE
C         ISIGNY = 1,  ISIMTX = 0,  ISIMTZ = 1  ===>  IMPOSSIBLE
C         ISIGNY = 1,  ISIMTX = 0,  ISIMTZ = 0  ===>  ALLOWED
C         ISIGNY = 0,  ISIMTX = 1,  ISIMTZ = 1  ===>  IMPOSSIBLE
C         ISIGNY = 0,  ISIMTX = 1,  ISIMTZ = 0  ===>  ALLOWED
C         ISIGNY = 0,  ISIMTX = 0,  ISIMTZ = 1  ===>  ALLOWED
C         ISIGNY = 0,  ISIMTX = 0,  ISIMTZ = 0  ===>  ALLOWED
C=======================================================================
C
C=======================================================================
C         READING THE PARAMETER SELECTING THE SHERICAL SYMMETRY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPHERICAL') THEN
C
          READ(NFIREA,*) ISPHER
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING THE SIMPLEX MODE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SIMPLEXY') THEN
C
          READ(NFIREA,*) ISIMPY
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING THE SIGNATURE MODE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SIGNATUREY') THEN
C
          READ(NFIREA,*) ISIGNY
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING THE PARITY MODE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PARITY') THEN
C
          READ(NFIREA,*) IPARTY
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING  NO-ROTATION  MODE
C=======================================================================
C         KEYWORD "TIMEREVERS" AND SWITCH "ITIREV" ARE  HERE
C         USED AS A CONVENIENT ALTERNATIVE TO READING SWITCH
C         "IROTAT"; SWITCH "ITIREV" IS USED NOWHERE ELSE.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ROTATION') THEN
C
          READ(NFIREA,*) IROTAT
C
      END IF
C
      IF (trim(KEYWOR).EQ.'TIMEREVERS') THEN
C
          READ(NFIREA,*) ITIREV
C
          IF (ITIREV.EQ.1) THEN
              IROTAT=0
          ELSE
              IROTAT=1
          END IF
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING CONSERVED TIME-REVERSAL IN THE
C         PAIRING CHANNEL
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TIMEREPAIR') THEN
C
          READ(NFIREA,*) ITIREP
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS SELECTING THE SIMPLEXES*T
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TSIMPLEX_Y'.OR.
     *    trim(KEYWOR).EQ.'TSIMPLEX-Y') THEN
C
          READ(NFIREA,*) ISIMTY
C
      END IF
C
      IF (trim(KEYWOR).EQ.'TSIMPLEXES') THEN
C
          READ(NFIREA,*) ISIMTX,ISIMTZ
C
      END IF
C
      IF (trim(KEYWOR).EQ.'TSIMPLEX3D') THEN
C
          READ(NFIREA,*) ISIMTX,ISIMTY,ISIMTZ
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING PAIRING MODE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PAIRING') THEN
C
          READ(NFIREA,*) IPAIRI
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING THE HFB MODE
C=======================================================================
C         IPAHFB=0 DENOTES EITHER NO PAIRING (IPAIRI=0)
C                              OR THE BCS MODE (IPABCS>0)
C         IPAHFB=1 DENOTES        THE HFB MODE (IPABCS=0) WITH DENSITIES
C                                 SUMMED UP IN THE QUASIPARTICLE BASIS
C         IPAHFB=2 DENOTES        THE HFB MODE (IPABCS=0) WITH DENSITIES
C                                 SUMMED UP IN THE CANONICAL BASIS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'HFB') THEN
C
          READ(NFIREA,*) IPAHFB
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS DOWNGRADING THE HFB MODE TO THE HF MODE
C         SEPARATELY FOR NEUTRONS [IPA2HF(0)>0] OR PROTONS [IPA2HF(1)>0]
C         FOR IPA2HF()=1, THE HF MODE IS  SWITCHED  ON  FROM  THE  START
C         FOR IPA2HF()=2, THE HF MODE IS SWITCHED ON  DURING  ITERATIONS
C                         ONCE THE PAIRING GAP BECOMES SMALLER THAN  THE
C                         LIMITING VALUE GIVEN IN DEL2HF().
C         ATTENTION: THESE OPTIONS ARE FRAGILE.  TOGETHER  WITH  VARIOUS
C                    OTHER OPTIONS OF THE CODE, THEY MAY OR MAY NOT WORK
C                    PROPERLY. CROSS YOUR FINGERS AND  PROCEED  AT  YOUR
C                    OWN RISK AND PERIL, OR STAY SAFE  AND  DO  NOT  USE
C                    THESE OPTIONS AT ALL.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'HFB2HF') THEN
C
          READ(NFIREA,*) IPA2HF(0),IPA2HF(1)
C
      END IF
C
C=======================================================================
C         READING THE LIMITING VALUES OF THE PAIRING  GAPS  BELOW  WHICH
C         THE HFB MODE IS DOWNGRADED TO THE HF MODE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'GAP2HF') THEN
C
          READ(NFIREA,*) DEL2HF(0),DEL2HF(1)
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING THE PN-MIXING MODE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROTNEUMIX') THEN
C
          READ(NFIREA,*) IPNMIX
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER SELECTING THE TWO-BASIS METHOD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TWOBASIS') THEN
C
          READ(NFIREA,*) ITWOBA
C
      END IF
C
C=======================================================================
C         PARAMETER IPABCS DECIDES ON WHETHER OR NOT, AND WHAT KIND OF
C         BCS PAIRING CALCULATIONS ARE PERFORMED:
C         IPABCS=-1 ->  COMPATIBILTY MODE
C         IPABCS=0  ->  NO BCS PAIRING
C         IPABCS=1  ->     BCS PAIRING WITH THE SENIORITY PARING FORCE
C         IPABCS=2  ->     BCS PAIRING WITH FIXED PAIRING GAPS
C         IPABCS=3  ->     BCS PAIRING WITH STATE-DEPENDENT PAIRING GAPS
C=======================================================================
C         ATTENTION: PARAMETER IPABCS IS PREDEFINED TO -1 AND
C                    READ FROM THE DATA.
C
C                    IF IPABCS IS NOT EQUAL TO  -1  THEN  THE
C                    VALUE OF JPABCS IS SET EQUAL  TO  IPABCS.
C
C                    IF IPABCS IS EQUAL TO -1 THEN THE  VALUE
C                    OF JPABCS IS SET IN THE FOLLOWING WAY TO
C                    FULFILL THE COMPATIBILITY CONDITIONS:
C                    JPABCS=0      IS SET FOR IPAHFB>0
C                    JPABCS=IPAIRI IS SET FOR IPAHFB=0
C
C                    VALUE OF IPABCS=-1 IS ALLOWED  ONLY  FOR
C                    THE SAKE OF COMPATIBILITY  WITH  EARLIER
C                    VERSIONS (BEFORE 2.13F).
C
C                    "JPABCS" DECIDES INSIDE THE  PROGRAM  ON
C                    WHETHER OR NOT THE BCS PAIRING IS USED.
C
C=======================================================================
C         READING THE PARAMETER SELECTING THE BCS MODE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BCS') THEN
C
          READ(NFIREA,*) IPABCS
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER REQUESTING THE HFB MEAN-FIELD PROPERTIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'HFBMEANFLD') THEN
C
          READ(NFIREA,*) IMFHFB
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER REQUESTING THE LIPKIN-NOGAMI CORRECTIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'LIPKIN') THEN
C
          READ(NFIREA,*) LIPKIN,LIPKIP
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER REQUESTING EXCLUSION OF BLOCKED ORBITALS
C         FROM THE LIPKIN-NOGAMI CORRECTIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NOBLOLIPKI') THEN
C
          READ(NFIREA,*) LIPNON,LIPNOP
C
      END IF
C
C=======================================================================
C         READING THE ORDERS OF THE LIPKIN VAPNP METHOD AND THE MAXIMUM
C         SHIFT OF THE GAUGE ANGLE (COMMON FOR NEUTRONS AND PROTONS)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'LIPORDER') THEN
C
          READ(NFIREA,*) ILIPON,ILIPOP
C
      END IF
C
      IF (trim(KEYWOR).EQ.'GAUGESHIFT') THEN
C
          READ(NFIREA,*) GAUSHI
C
      END IF
C
      IF (trim(KEYWOR).EQ.'GAUGEFRACT') THEN
C
          READ(NFIREA,*) MAXGAU
C
          IF (MAXGAU.GE.1) GAUSHI=8.D0*ATAN(1.0D0)/MAXGAU
C
          IF (MAXGAU.EQ.0) GAUSHI=8.D0*ATAN(1.0D0)/51
C
      END IF
C
C=======================================================================
C=======================================================================
C
C         CONFIGURATIONS ARE DEFINED IN TERMS OF EITHER THE SIMPLEX
C         (ISIGNY=0) OR THE SIGNATURE-PARITY (ISIGNY=1) QUANTUM
C         NUMBERS.
C
C         SIMPLEX IS EQUAL TO THE PRODUCT: SIMPLEX=SIGNATURE*PARITY
C
C                                       *********************
C         THE BLOCK IREVER=0 CONTAINS   * (RY=+i,PARITY=+1) * AND
C                                       * (RY=-i,PARITY=-1) *
C                                       *********************
C         THE BLOCK IREVER=1 CONTAINS   * (RY=-i,PARITY=+1) * AND
C                                       * (RY=+i,PARITY=-1) *
C                                       *********************
C
C         FOR THE CASE OF THE SIMPLEX:
C         IN THE INPUT DATA THE BLOCKS ARE RED IN THE ORDER
C                    (SIMPLEX) = (+) , (-)
C         THEREFORE: THE BLOCK IREVER=0 IS DEFINED BY (+)
C                    THE BLOCK IREVER=1 IS DEFINED BY (-)
C
C         FOR THE CASE OF THE SIGNATURE-PARITY:
C         IN THE INPUT DATA THE BLOCKS ARE RED IN THE ORDER
C                    (PARITY,SIGNATURE) = (+,+) (+,-) (-,+) (-,-)
C         THEREFORE: THE BLOCK IREVER=0 IS DEFINED BY (+,+) AND (-,-)
C                    THE BLOCK IREVER=1 IS DEFINED BY (+,-) AND (-,+)
C
C=======================================================================
C         READING THE NEUTRON PARTICLE-HOLE EXCITATION (NO SYMMETRY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHNONE_NEU'.OR.
     *    trim(KEYWOR).EQ.'PHNONE-NEU') THEN
C
          READ(NFIREA,*) NUPAHO,KPNONE(NUPAHO,0),
     *                          KHNONE(NUPAHO,0)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR NONE/NEUTRONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE  PROTON PARTICLE-HOLE EXCITATION (NO SYMMETRY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHNONE_PRO'.OR.
     *    trim(KEYWOR).EQ.'PHNONE-PRO') THEN
C
          READ(NFIREA,*) NUPAHO,KPNONE(NUPAHO,1),
     *                          KHNONE(NUPAHO,1)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR NONE/PROTONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON PARTICLE-HOLE EXCITATION (NO SYMMETRY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHNONE_NUC'.OR.
     *    trim(KEYWOR).EQ.'PHNONE-NUC') THEN
C
          READ(NFIREA,*) NUPAHO,LPNONE(NUPAHO),
     *                          LHNONE(NUPAHO)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR NONE/NUCLEONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR NEUTRONS (SIMPLEX)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACSIM_NEU'.OR.
     *    trim(KEYWOR).EQ.'VACSIM-NEU') THEN
C
          READ(NFIREA,*) (KVASIM(ISIMPL,0),ISIMPL=0,NDSIMP)
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR PROTONS (SIMPLEX)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACSIM_PRO'.OR.
     *    trim(KEYWOR).EQ.'VACSIM-PRO') THEN
C
          READ(NFIREA,*) (KVASIM(ISIMPL,1),ISIMPL=0,NDSIMP)
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR NUCLEONS (SIMPLEX)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACSIM_NUC'.OR.
     *    trim(KEYWOR).EQ.'VACSIM-NUC') THEN
C
          READ(NFIREA,*) (KVAMIM(ISIMPL),ISIMPL=0,NDSIMP)
C
      END IF
C
C=======================================================================
C         READING THE NEUTRON PARTICLE-HOLE EXCITATION (SIMPLEX)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHSIMP_NEU'.OR.
     *    trim(KEYWOR).EQ.'PHSIMP-NEU') THEN
C
          READ(NFIREA,*) NUPAHO,KPSIMP(NUPAHO,0),KPSIMM(NUPAHO,0),
     *                          KHSIMP(NUPAHO,0),KHSIMM(NUPAHO,0)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR SIMPLEX/NEUTRONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE PROTON PARTICLE-HOLE EXCITATION (SIMPLEX)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHSIMP_PRO'.OR.
     *    trim(KEYWOR).EQ.'PHSIMP-PRO') THEN
C
          READ(NFIREA,*) NUPAHO,KPSIMP(NUPAHO,1),KPSIMM(NUPAHO,1),
     *                          KHSIMP(NUPAHO,1),KHSIMM(NUPAHO,1)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR SIMPLEX/PROTONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON PARTICLE-HOLE EXCITATION (SIMPLEX)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHSIMP_NUC'.OR.
     *    trim(KEYWOR).EQ.'PHSIMP-NUC') THEN
C
          READ(NFIREA,*) NUPAHO,LPSIMP(NUPAHO),LPSIMM(NUPAHO),
     *                          LHSIMP(NUPAHO),LHSIMM(NUPAHO)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR SIMPLEX/NUCLEONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR NEUTRONS (PARITY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACPAR_NEU'.OR.
     *    trim(KEYWOR).EQ.'VACPAR-NEU'.OR.
     *    trim(KEYWOR).EQ.'VACSIQ_NEU'.OR.
     *    trim(KEYWOR).EQ.'VACSIQ-NEU') THEN
C
          READ(NFIREA,*) (KVASIQ(IPARIT,0),IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR PROTONS (PARITY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACPAR_PRO'.OR.
     *    trim(KEYWOR).EQ.'VACPAR-PRO'.OR.
     *    trim(KEYWOR).EQ.'VACSIQ_PRO'.OR.
     *    trim(KEYWOR).EQ.'VACSIQ-PRO') THEN
C
          READ(NFIREA,*) (KVASIQ(IPARIT,1),IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATION FOR NEUTRONS (NO-SYMMETRY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACNON_NEU'.OR.
     *    trim(KEYWOR).EQ.'VACNON-NEU'.OR.
     *    trim(KEYWOR).EQ.'VACSIZ_NEU'.OR.
     *    trim(KEYWOR).EQ.'VACSIZ-NEU') THEN
C
          READ(NFIREA,*) KVASIZ(0)
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATION FOR PROTONS (NO-SYMMETRY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACNON_PRO'.OR.
     *    trim(KEYWOR).EQ.'VACNON-PRO'.OR.
     *    trim(KEYWOR).EQ.'VACSIZ_PRO'.OR.
     *    trim(KEYWOR).EQ.'VACSIZ-PRO') THEN
C
          READ(NFIREA,*) KVASIZ(1)
C
      END IF
C
C=======================================================================
C         READING THE CORRECTIONS TO PARTICLE NUMBERS USED AS THE VACUUM
C         OCCUPATION FOR NEUTRONS (NO-SYMMETRY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACSIZCNEU') THEN
C
          READ(NFIREA,*) MVASIZ(0)
C
      END IF
C
C=======================================================================
C         READING THE CORRECTIONS TO PARTICLE NUMBERS USED AS THE VACUUM
C         OCCUPATION FOR  PROTONS (NO-SYMMETRY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACSIZCPRO') THEN
C
          READ(NFIREA,*) MVASIZ(1)
C
      END IF
C
C=======================================================================
C         READING THE ALIGNMENT VACUUM OCCUPATIONS FOR NEUTRONS  IN  THE
C         PARITY BLOCKS
C=======================================================================
C         NLSIQN     => CARTESIAN DIRECTION OF THE ALIGNMENT  CONSIDERED
C         NLSIQN = 0 => ALIGNMENT VACUUM OCCUPATIONS IGNORED
C         NLSIQN > 0 => ALIGNMENT VACUUM OCCUPATIONS CALCULATED AND USED
C         NLSIQN < 0 => ALIGNMENT VACUUM OCCUPATIONS CALCULATED ONLY
C=======================================================================
C         MXALIN     => POSITIVE AND ODD VALUE OF THE MAXIMUM  ALIGNMENT
C=======================================================================
C         LALSIQ & KALSIQ => READ AND USED,  RESPECTIVELY,  ARRAYS  THAT
C                            CONTAIN NUMBERS OF STATES OCCUPIED IN EVERY
C                            ALIGNMENT BLOCK. THE  CODE  ATTRIBUTES  THE
C                            CALCULATED ALIGNMENTS TO THE NEAREST  HALF-
C                            INTEGER VALUE.
C         KALSIQ > 0 => OCCUPIES THE LOWEST STATES IN AN ALIGNMENT BLOCK
C         KALSIQ < 0 => OCCUPIES THE LOWEST STATES IN AN ALIGNMENT BLOCK
C                       PLUS CREATES THE LOWEST PARTICLE-HOLE EXCITATION
C                       IN THIS BLOCK.
C=======================================================================
C         FOR NLSIQN>0  THE PARTICLES ARE FILLED  IN  ALIGNMENT  BLOCKS.
C                       AS A SECURITY MEASURE, SUMS OF PARTICLE  NUMBERS
C                       READ IN THE ALINGMENT BLOCKS MUST  BE  EQUAL  TO
C                       THE VACUUM DATA READ UNDER KEYWORD "VACPAR_NEU".
C                       HOWEVER, THE DIABATIC-BLOCKING  DATA, READ UNDER
C                       KEYWORDS "DIABATIC" OR "DIAPAR_NEU",  CAN  STILL
C                       BE USED, WHICH IS A VERY  FRAGILE  FEATURE  THAT
C                       HAS TO BE USED WITH AN EXTREME CAUTION,  BECAUSE
C                       DURING ITERATIONS THE NUMBERING   OF  STATES  IN
C                       PARITY  BLOCKS  DYNAMICALLY  DEPENDS  ON  STATES
C                       OCCUPIED IN THE ALIGNMENT BLOCKS.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACPARANEU') THEN
C
          READ(NFIREA,*) NLSIQN,MXALIN,
     *                  (LALSIQ(I_ALIB,0,0),I_ALIB=-MXALIN,MXALIN,2),
     *                  (LALSIQ(I_ALIB,1,0),I_ALIB=-MXALIN,MXALIN,2)
C
          IF (MXALIN.GT.NDALIB) STOP ' INCREASE NDALIB IN NAMELI (1)'
C
          KALSIQ(:,:,0)=LALSIQ(:,:,0)
C
      END IF
C
C=======================================================================
C         READING THE ALIGNMENT VACUUM OCCUPATIONS FOR  PROTONS  IN  THE
C         PARITY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACPARAPRO') THEN
C
          READ(NFIREA,*) NLSIQP,MXALIP,
     *                  (LALSIQ(I_ALIB,0,1),I_ALIB=-MXALIP,MXALIP,2),
     *                  (LALSIQ(I_ALIB,1,1),I_ALIB=-MXALIP,MXALIP,2)
C
          IF (MXALIP.GT.NDALIB) STOP ' INCREASE NDALIB IN NAMELI (2)'
C
          KALSIQ(:,:,1)=LALSIQ(:,:,1)
C
      END IF
C
C=======================================================================
C         READING THE ALIGNMENT VACUUM OCCUPATIONS FOR NEUTRONS  IN  THE
C         NO-SYMMETRY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACNONANEU'.OR.
     *    trim(KEYWOR).EQ.'VACSIZANEU') THEN
C
          READ(NFIREA,*) NLSIZN,MXALIN,
     *                  (LALSIZ(I_ALIB,0),I_ALIB=-MXALIN,MXALIN,2)
C
          IF (MXALIN.GT.NDALIB) STOP ' INCREASE NDALIB IN NAMELI (3)'
C
          KALSIZ(:,0)=LALSIZ(:,0)
C
      END IF
C
C=======================================================================
C         READING THE ALIGNMENT VACUUM OCCUPATIONS FOR  PROTONS  IN  THE
C         NO-SYMMETRY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACNONAPRO'.OR.
     *    trim(KEYWOR).EQ.'VACSIZAPRO') THEN
C
          READ(NFIREA,*) NLSIZP,MXALIP,
     *                  (LALSIZ(I_ALIB,1),I_ALIB=-MXALIP,MXALIP,2)
C
          IF (MXALIP.GT.NDALIB) STOP ' INCREASE NDALIB IN NAMELI (4)'
C
          KALSIZ(:,1)=LALSIZ(:,1)
C
      END IF
C
C=======================================================================
C         READING THE SWITCHES REQUESTING OCCUPATIONS OF LAST ORBITALS
C         ONLY IN EACH OMEGA BLOCK
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACLASTORB') THEN
C
          READ(NFIREA,*) LASTAN,LASTAP
C
      END IF
C
C=======================================================================
C         READING THE SWITCH REQUESTING AXIALIZATION OF THE P-H AND  P-P
C         MEAN FIELDS IN SPACE (FOR |IAXIAP|=1) AND DENSITY  MATRIX  AND
C         PAIRING TENSOR (FOR IAXIAP=-1)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'AXIALIZE'.OR.trim(KEYWOR).EQ.'AXIALISE') THEN
C
          READ(NFIREA,*) IAXIAP
C
      END IF
C
C=======================================================================
C         READING THE SWITCH REQUESTING ANTISYMMETRIZATION OF THE
C         PAIRING TENSOR
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ANTISYMPAI') THEN
C
          READ(NFIREA,*) KAPASY
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR NUCLEONS (PARITY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACPAR_NUC'.OR.
     *    trim(KEYWOR).EQ.'VACPAR-NUC') THEN
C
          READ(NFIREA,*) (KVAMIQ(IPARIT),IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE NEUTRON PARTICLE-HOLE EXCITATION (PARITY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHPARI_NEU'.OR.
     *    trim(KEYWOR).EQ.'PHPARI-NEU') THEN
C
          READ(NFIREA,*) NUPAHO,KPSIQP(NUPAHO,0),KPSIQM(NUPAHO,0),
     *                          KHSIQP(NUPAHO,0),KHSIQM(NUPAHO,0)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR PARITY/NEUTRONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE PROTON PARTICLE-HOLE EXCITATION (PARITY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHPARI_PRO'.OR.
     *    trim(KEYWOR).EQ.'PHPARI-PRO') THEN
C
          READ(NFIREA,*) NUPAHO,KPSIQP(NUPAHO,1),KPSIQM(NUPAHO,1),
     *                          KHSIQP(NUPAHO,1),KHSIQM(NUPAHO,1)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR PARITY/PROTONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON PARTICLE-HOLE EXCITATION (PARITY)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHPARI_NUC'.OR.
     *    trim(KEYWOR).EQ.'PHPARI-NUC') THEN
C
          READ(NFIREA,*) NUPAHO,LPSIQP(NUPAHO),LPSIQM(NUPAHO),
     *                          LHSIQP(NUPAHO),LHSIQM(NUPAHO)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR PARITY/NUCLEONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR NEUTRONS (SIGNATURE)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACSIG_NEU'.OR.
     *    trim(KEYWOR).EQ.'VACSIG-NEU') THEN
C
          READ(NFIREA,*) ((KVASIG(IPARIT,ISIGNA,0),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR PROTONS (SIGNATURE)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACSIG_PRO'.OR.
     *    trim(KEYWOR).EQ.'VACSIG-PRO') THEN
C
          READ(NFIREA,*) ((KVASIG(IPARIT,ISIGNA,1),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE VACUUM OCCUPATIONS FOR NUCLEONS (SIGNATURE)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'VACSIG_NUC'.OR.
     *    trim(KEYWOR).EQ.'VACSIG-NUC') THEN
C
          READ(NFIREA,*) ((KVAMIG(IPARIT,ISIGNA),ISIGNA=0,NDSIGN),
     *                                           IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE NEUTRON PARTICLE-HOLE EXCITATION (SIGNATURE)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHSIGN_NEU'.OR.
     *    trim(KEYWOR).EQ.'PHSIGN-NEU') THEN
C
          READ(NFIREA,*) NUPAHO,KPPPSP(NUPAHO,0),KPPPSM(NUPAHO,0),
     *                          KPPMSP(NUPAHO,0),KPPMSM(NUPAHO,0),
     *                          KHPPSP(NUPAHO,0),KHPPSM(NUPAHO,0),
     *                          KHPMSP(NUPAHO,0),KHPMSM(NUPAHO,0)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR SIGNATURE/NEUTRONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE PROTON PARTICLE-HOLE EXCITATION (SIGNATURE)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHSIGN_PRO'.OR.
     *    trim(KEYWOR).EQ.'PHSIGN-PRO') THEN
C
          READ(NFIREA,*) NUPAHO,KPPPSP(NUPAHO,1),KPPPSM(NUPAHO,1),
     *                          KPPMSP(NUPAHO,1),KPPMSM(NUPAHO,1),
     *                          KHPPSP(NUPAHO,1),KHPPSM(NUPAHO,1),
     *                          KHPMSP(NUPAHO,1),KHPMSM(NUPAHO,1)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR SIGNATURE/PROTONS IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON PARTICLE-HOLE EXCITATION (SIGNATURE)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PHSIGN_NUC'.OR.
     *    trim(KEYWOR).EQ.'PHSIGN-NUC') THEN
C
          READ(NFIREA,*) NUPAHO,LPPPSP(NUPAHO),LPPPSM(NUPAHO),
     *                          LPPMSP(NUPAHO),LPPMSM(NUPAHO),
     *                          LHPPSP(NUPAHO),LHPPSM(NUPAHO),
     *                          LHPMSP(NUPAHO),LHPMSM(NUPAHO)
C
          IF (NUPAHO.LE.0.OR.NUPAHO.GT.NDPAHO)
     *        STOP 'INDEX OUT OF RANGE FOR SIGNATURE/NUCLEONS IN NAMELI'
C
      END IF
C
C=======================================================================
C=======================================================================
C
C         FOR A SINGLE PAIR OF STATES, THE DIABATIC BLOCKING OF
C         CONFIGURATIONS IS ORGANISED AS FOLLOWS:
C
C         1A. FOR THE PARITY/SIGNATURE CASE, THE BLOCK IN WHICH THE
C             BLOCKING IS TO BE PERFORMED IS DEFINDED BY THE:
C                                                 CHARGE, ICHFLI=(0,1),
C                                                 PARITY, IPAFLI=(0,1),
C                                          AND SIGNATURE, ISIFLI=(0,1)
C
C         1B. FOR THE     SIMPLEX      CASE, THE BLOCK IN WHICH THE
C             BLOCKING IS TO BE PERFORMED IS DEFINDED BY THE:
C                                                 CHARGE, ICHFLI=(0,1),
C                                            AND SIMPLEX, ISIFLI=(0,1)
C             ATTENTION: AS A SECURITY MEASURE, IN THE  SIMPLEX  CASE
C                        THE USER IS RESPONSIBLE FOR SETTING IPAFLI=0,
C                        ALTHOUGH THIS VARIABLE WILL NOT BE USED.
C
C         1C. FOR THE      PARITY      CASE, THE BLOCK IN WHICH THE
C             BLOCKING IS TO BE PERFORMED IS DEFINDED BY THE:
C                                                 CHARGE, ICHFLI=(0,1),
C                                            AND  PARITY, IPAFLI=(0,1)
C             ATTENTION: AS A SECURITY MEASURE, IN  THE  PARITY  CASE
C                        THE USER IS RESPONSIBLE FOR SETTING ISIFLI=0,
C                        ALTHOUGH THIS VARIABLE WILL NOT BE USED.
C
C         1D. FOR THE    NO-SYMMETRY   CASE, THE BLOCK IN WHICH THE
C             BLOCKING IS TO BE PERFORMED IS DEFINDED BY THE:
C                                                 CHARGE, ICHFLI=(0,1)
C             ATTENTION: AS A SECURITY MEASURE, IN  THE  NO-SYMM  CASE
C                        THE USER IS RESPONSIBLE FOR SETTING  ISIFLI=0
C                        AND IPAFLI=0, ALTHOUGH THESE  VARIABLES  WILL
C                        NOT BE USED.
C
C         2.  THE CODE CONSIDERS TWO STATES:  A PARTICLE STATE, ISPFLI,
C                                         AND A     HOLE STATE, ISHFLI.
C             THESE INDICES REFER TO THE ENERGY ORDERING IN THE CHOSEN
C             BLOCK, AND HENCE DEPEND ON WHETHER THE  PARITY/SIGNATURE
C             OR THE SIMPLEX CASE IS CONSIDERED (ISIGNY VARIABLE).
C
C         3.  THE CODE CONSIDERS THE OBSERVABLE DEFINED BY THE ABSOLUTE
C                                                      VALUE OF IFLIPI:
C             FOR  ABS(IFLIPI)= 1, ANGULAR MOMENTUM Y-ALIGNMENT IS TAKEN
C             FOR  ABS(IFLIPI)= 2, INTRINSIC  SPIN  Y-ALIGNMENT IS TAKEN
C
C             FOR  ABS(IFLIPI)= 3, ANGULAR MOMENTUM X-ALIGNMENT IS TAKEN
C             FOR  ABS(IFLIPI)= 4, INTRINSIC  SPIN  X-ALIGNMENT IS TAKEN
C
C             FOR  ABS(IFLIPI)= 5, ANGULAR MOMENTUM Z-ALIGNMENT IS TAKEN
C             FOR  ABS(IFLIPI)= 6, INTRINSIC  SPIN  Z-ALIGNMENT IS TAKEN
C
C             FOR  ABS(IFLIPI)= 7, ANGULAR MOMENTUM O-ALIGNMENT IS TAKEN
C             FOR  ABS(IFLIPI)= 8, INTRINSIC  SPIN  O-ALIGNMENT IS TAKEN
C
C                                  WHERE THE "O-ALIGNMENTS"  DENOTE  THE
C                                  PROJECTIONS  ON  THE  VECTOR  OF  THE
C                                  ANGULAR FREQUENCY OMEGA
C
C             FOR  ABS(IFLIPI)= 9, QUADRUPOLE MOMENT Q_20 MIU=0 IS TAKEN
C             FOR  ABS(IFLIPI)=10, QUADRUPOLE MOMENT Q_22 MIU=2 IS TAKEN
C
C             FOR  ABS(IFLIPI)=11, ISOSPIN Z-ALIGNMENT IS TAKEN
C
C             FOR      IFLIPI = 0, THERE IS NO DIABATIC BLOCKING.
C
C         4.  AMONG THE TWO STATES, ISPFLI AND ISHFLI, THE ONE WHICH IS
C             KEPT OCCUPIED MUST HAVE THE LARGER, FOR IFLIPI > 0,
C                                     OR SMALLER, FOR IFLIPI < 0,
C             VALUE OF THE CHOSEN OBSERVABLE
C
C         5.  VALUES OF IFLIPI FROM 3 TO 8 ARE ALLOWED ONLY FOR ISIMPY=0
C
C=======================================================================
C         READING THE DIABATIC CONFIGURATION DATA FOR A SINGLE PAIR
C         OF STATES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIABATIC') THEN
C
          READ(NFIREA,*) ICHFLI,IPAFLI,ISIFLI,
     *                   ISPFLI,ISHFLI,IFLIPI
C
          IREFLI=ISIFLI*(1-IPAFLI)+(1-ISIFLI)*IPAFLI
C
      END IF
C
C=======================================================================
C         READING THE SWITCH THAT REQUESTS CALCULATIONS OF THE ADIABATIC
C         MASS PARAMETERS AND MOMENTS OF INERTIA
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ADIABATIC') THEN
C
          READ(NFIREA,*) IADBAT
C
      END IF
C
C=======================================================================
C         READING ATDHF(B) SWITCHES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ADBRUNMOD') THEN
C
          READ(NFIREA,*) IABCOL, IABICH, IABNTE, DABPRS, XCHIMX
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS RELATED TO FINITE AMPLITUDE METHOD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FAM') THEN
C
          READ(NFIREA,*) IFAMON, ETAFAM
C
      END IF
C
C=======================================================================
C         READING THE FILE NAME OF INDUCED DENSITY IN FIRST DIMENSION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ADBINDFST') THEN
C
          READ(NFIREA,*) SFIADB
C
      END IF
C
C=======================================================================
C         READING THE FILE NAME OF INDUCED DENSITY IN SECOND DIMENSION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ADBINDSEC') THEN
C
          READ(NFIREA,*) SFJADB
C
      END IF
C
C=======================================================================
C         READING THE POSITION AT WHICH TOMOGRAPHY IS TAKEN
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TOMOGRAPHY') THEN
C
          READ(NFIREA,*) ITOMOZ, PTOMOX, PTOMOY, PTOMOZ
C
      END IF
C
C=======================================================================
C         READING THE TYPE OF DENSITY FOR WHICH TOMOGRAPHY IS CALCULATED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TYPECPD') THEN
C
          READ(NFIREA,*) IOBSCH, IDESCH, INDENS
C
      END IF
C
C=======================================================================
C         READING THE VECTORS DEFINING THE SLICE OF CONDITIONAL DENSITY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TOMOSLICE') THEN
C
          READ(NFIREA,*) ITOMSC, P0VECX,P0VECY,P0VECZ,
     *                           P1VECX,P1VECY,P1VECZ,
     *                           P2VECX,P2VECY,P2VECZ
C
      END IF
C
C=======================================================================
C         READING THE NUMBER DEFINES THE PROJECTION OF TOMOGRAPHY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TOMOPROJ') THEN
C
          READ(NFIREA,*) ITOMII, ITOMMM, ITOMKK, NTOMNB, NTOMNA
C
      END IF
C
C=======================================================================
C         READING SWITCH FOR VISUALIZATION OF THE CONDITIONAL DENSITY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TOMOPLOT') THEN
C
          READ(NFIREA,*) NCMESH, PINTSC, PWIDTH, PHEIGH
C
      END IF
C
C=======================================================================
C         READING THE SWITCH THAT REQUESTS CALCULATIONS FOR ONE OR TWO
c         CENTER HO BASIS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CENT_BASIS'.OR.
     *trim(KEYWOR).EQ.'CENT-BASIS') THEN
C
          READ(NFIREA,*) ITWCEN,CENREA(1,1),CENREA(2,1),CENREA(3,1),
     *                          CENREA(1,2),CENREA(2,2),CENREA(3,2)
C
          DO LTWCEN=1,ITWCEN
C
             IF (LTWCEN.GT.NDTWCE) STOP 'WRONG ITWCEN IN NAMELI'
C
             DO KARTEZ=1,NDKART
                CENCOR(KARTEZ,LTWCEN)=CENREA(KARTEZ,LTWCEN)
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C         READING THE CUT-OFF FOR BUILDING THE NATURAL BASIS IN THE TWO-
C         CENTER CALCULATIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NATBASCTFF') THEN
C
          READ(NFIREA,*) IEIGCU, EIGCUT
C
          IF (IEIGCU.NE.0.AND.IEIGCU.NE.1)
     *    STOP 'WRONG SWITCH FOR NATURAL BASIS CUT-OFF'
C
      END IF
C
C=======================================================================
C         POPULATION OF FRAGMENTS FOR TWO-CENTER BASIS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FRAGCONSTR') THEN
C
 1050     READ(NFIREA,*,END=2050) MTWCEN,MCHARG,
     *                                   FRGSTF(MCHARG,ABS(MTWCEN)),
     *                                   FRGASK(MCHARG,ABS(MTWCEN)),
     *                                   IFLFRG(MCHARG,ABS(MTWCEN))
C
          IF (ABS(MTWCEN).LT.1.OR.ABS(MTWCEN).GT.NDTWCE)
     *
     *        STOP ' FRGSTF CENTER INDICES OUT OF RANGE IN NAMELI'
C
          IF (MCHARG.LT.0.OR.MCHARG.GT.NDISOS)
     *
     *        STOP ' FRGSTF ISOSPIN INDICES OUT OF RANGE IN NAMELI'
C
          IF (NDTWCE.NE.2)
     *
     *        STOP ' KEYWORD FRAGCONSTR ALLOWED ONLY FOR NDTWCE=2'
C
          IF (MTWCEN.LT.0) GO TO 1050
C
      END IF
C
C=======================================================================
C         DEFORMATION OF FRAGMENTS FOR TWO-CENTER BASIS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FRAGMULDEF') THEN
C
 1051     READ(NFIREA,*,END=2051) MTWCEN,LAMBDA,MIU,
     *                                 STQTWC(LAMBDA,MIU,ABS(MTWCEN)),
     *                                 QTWCAS(LAMBDA,MIU,ABS(MTWCEN)),
     *                                 IFLQTW(LAMBDA,MIU,ABS(MTWCEN))
          IF (ABS(MTWCEN).LT.1.OR.ABS(MTWCEN).GT.NDTWCE)
     *
     *        STOP ' STQTWC CENTER INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.GT.NDMULT.OR.LAMBDA.LE.0.OR.IABS(MIU).GT.LAMBDA)
     *        STOP ' STQTWC INDICES OUT OF RANGE IN NAMELI'
C
          IF (NDTWCE.NE.2)
     *
     *        STOP ' KEYWORD FRAGMULDEF ALLOWED ONLY FOR NDTWCE=2'
C
          IF (MTWCEN.LT.0) GO TO 1051
C
      END IF
C
C=======================================================================
C         READING THE LINEAR-CONSTRAINT CONTINUATION PARAMETER FOR
C         THE PROPERTIES OF THE FRAGMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTFRAGMN') THEN
C
          READ(NFIREA,*) IFRCNT
C
      END IF
C
C=======================================================================
C         ROTATION OF FRAGMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FRAGROTATI') THEN
C
          READ(NFIREA,*) IROAUX(1),IROAUX(2),
     *                   ALTWRE(1),BETWRE(1),GATWRE(1),
     *                   ALTWRE(2),BETWRE(2),GATWRE(2)
C
          DO LTWCEN=1,NDTWCE
             IROFRG(LTWCEN)=IROAUX(LTWCEN)
             ALFFRA(LTWCEN)=ALTWRE(LTWCEN)/DEGRAD
             BETFRA(LTWCEN)=BETWRE(LTWCEN)/DEGRAD
             GAMFRA(LTWCEN)=GATWRE(LTWCEN)/DEGRAD
          END DO
C
      END IF
C
C=======================================================================
C
C         FOR ALL BLOCKS OF STATES, THE DIABATIC BLOCKING OF
C         CONFIGURATIONS IS ORGANISED IN THE SAME WAY AS FOR
C         THE SINGLE PAIR OF STATES (SEE DESCRIPTION ABOVE).
C
C         THE ROLE OF THE SINGLE-PAIR VARIABLES IS  PLAYED BY
C         THE MATRICES ACCORDING TO  THE  FOLLOWING  TABLE OF
C         CORRSPONDENCES:
C
C         SINGLE-PAIR  SIGNATURE   SIMPLEX      PARITY   NO-SYMMETRY
C         -----------  ----------  --------    --------  -----------
C           ISPFLI       KPFLIG     KPFLIM      KPFLIQ     KPFLIZ
C           ISHFLI       KHFLIG     KHFLIM      KHFLIQ     KHFLIZ
C           IFLIPI       KOFLIG     KOFLIM      KOFLIQ     KOFLIZ
C
C         ATTENTION:        THE SINGLE-PAIR DIABATIC BLOCKING
C                       AND THE ALL-BLOCKS  DIABATIC BLOCKING
C                       C A N N O T  BE  USED  SIMULTANEOUSLY
C
C=======================================================================
C         READING THE NEUTRON DIABATIC CONFIGURATION DATA FOR ALL
C         NO-SYMMETRY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIANON_NEU'.OR.
     *    trim(KEYWOR).EQ.'DIANON-NEU') THEN
C
          READ(NFIREA,*) KPFLIZ(0),
     *                   KHFLIZ(0),
     *                   KOFLIZ(0)
C
      END IF
C
C=======================================================================
C         READING THE  PROTON DIABATIC CONFIGURATION DATA FOR ALL
C         NO-SYMMETRY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIANON_PRO'.OR.
     *    trim(KEYWOR).EQ.'DIANON-PRO') THEN
C
          READ(NFIREA,*) KPFLIZ(1),
     *                   KHFLIZ(1),
     *                   KOFLIZ(1)
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON DIABATIC CONFIGURATION DATA FOR ALL
C         NO-SYMMETRY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIANON_NUC'.OR.
     *    trim(KEYWOR).EQ.'DIANON-NUC') THEN
C
          READ(NFIREA,*) KPMLIZ,
     *                   KHMLIZ,
     *                   KOMLIZ
C
      END IF
C
C=======================================================================
C         READING THE NEUTRON DIABATIC CONFIGURATION DATA FOR ALL
C         SIMPLEX BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIASIM_NEU'.OR.
     *    trim(KEYWOR).EQ.'DIASIM-NEU') THEN
C
          READ(NFIREA,*) (KPFLIM(ISIMPL,0),ISIMPL=0,NDSIMP),
     *                   (KHFLIM(ISIMPL,0),ISIMPL=0,NDSIMP),
     *                   (KOFLIM(ISIMPL,0),ISIMPL=0,NDSIMP)
C
      END IF
C
C=======================================================================
C         READING THE  PROTON DIABATIC CONFIGURATION DATA FOR ALL
C         SIMPLEX BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIASIM_PRO'.OR.
     *    trim(KEYWOR).EQ.'DIASIM-PRO') THEN
C
          READ(NFIREA,*) (KPFLIM(ISIMPL,1),ISIMPL=0,NDSIMP),
     *                   (KHFLIM(ISIMPL,1),ISIMPL=0,NDSIMP),
     *                   (KOFLIM(ISIMPL,1),ISIMPL=0,NDSIMP)
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON DIABATIC CONFIGURATION DATA FOR ALL
C         SIMPLEX BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIASIM_NUC'.OR.
     *    trim(KEYWOR).EQ.'DIASIM-NUC') THEN
C
          READ(NFIREA,*) (KPMLIM(ISIMPL),ISIMPL=0,NDSIMP),
     *                   (KHMLIM(ISIMPL),ISIMPL=0,NDSIMP),
     *                   (KOMLIM(ISIMPL),ISIMPL=0,NDSIMP)
C
      END IF
C
C=======================================================================
C         READING THE NEUTRON DIABATIC CONFIGURATION DATA FOR ALL
C         PARITY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIAPAR_NEU'.OR.
     *    trim(KEYWOR).EQ.'DIAPAR-NEU') THEN
C
          READ(NFIREA,*) (KPFLIQ(IPARIT,0),IPARIT=0,NDPARI),
     *                   (KHFLIQ(IPARIT,0),IPARIT=0,NDPARI),
     *                   (KOFLIQ(IPARIT,0),IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE  PROTON DIABATIC CONFIGURATION DATA FOR ALL
C         PARITY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIAPAR_PRO'.OR.
     *    trim(KEYWOR).EQ.'DIAPAR-PRO') THEN
C
          READ(NFIREA,*) (KPFLIQ(IPARIT,1),IPARIT=0,NDPARI),
     *                   (KHFLIQ(IPARIT,1),IPARIT=0,NDPARI),
     *                   (KOFLIQ(IPARIT,1),IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON DIABATIC CONFIGURATION DATA FOR ALL
C         PARITY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIAPAR_NUC'.OR.
     *    trim(KEYWOR).EQ.'DIAPAR-NUC') THEN
C
          READ(NFIREA,*) (KPMLIQ(IPARIT),IPARIT=0,NDPARI),
     *                   (KHMLIQ(IPARIT),IPARIT=0,NDPARI),
     *                   (KOMLIQ(IPARIT),IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE NEUTRON DIABATIC CONFIGURATION DATA FOR ALL
C         SIGNATURE BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIASIG_NEU'.OR.
     *    trim(KEYWOR).EQ.'DIASIG-NEU') THEN
C
          READ(NFIREA,*) ((KPFLIG(IPARIT,ISIGNA,0),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI),
     *                   ((KHFLIG(IPARIT,ISIGNA,0),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI),
     *                   ((KOFLIG(IPARIT,ISIGNA,0),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE  PROTON DIABATIC CONFIGURATION DATA FOR ALL
C         SIGNATURE BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIASIG_PRO'.OR.
     *    trim(KEYWOR).EQ.'DIASIG-PRO') THEN
C
          READ(NFIREA,*) ((KPFLIG(IPARIT,ISIGNA,1),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI),
     *                   ((KHFLIG(IPARIT,ISIGNA,1),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI),
     *                   ((KOFLIG(IPARIT,ISIGNA,1),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON DIABATIC CONFIGURATION DATA FOR ALL
C         SIGNATURE BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIASIG_NUC'.OR.
     *    trim(KEYWOR).EQ.'DIASIG-NUC') THEN
C
          READ(NFIREA,*) ((KPMLIG(IPARIT,ISIGNA),ISIGNA=0,NDSIGN),
     *                                           IPARIT=0,NDPARI),
     *                   ((KHMLIG(IPARIT,ISIGNA),ISIGNA=0,NDSIGN),
     *                                           IPARIT=0,NDPARI),
     *                   ((KOMLIG(IPARIT,ISIGNA),ISIGNA=0,NDSIGN),
     *                                           IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS OF MULTI-PARTICLE/HOLE  BLOCKING  BASED
C         ON THE NILSSON LABELS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NIBLOCK_N'.OR.
     *    trim(KEYWOR).EQ.'NIBLOCK-N') THEN
C
          READ(NFIREA,*) NIBLOC(0)
C
          IF (NIBLOC(0).GT.NDBLOC)
     *        STOP ' INCREASE NDBLOC FOR NEUTRONS IN NAMELI (2)'
C
          DO NUBLOC=1,NIBLOC(0)
C
             READ(NFIREA,'(A80)') LINE
C
             NIBLOL(NUBLOC,0)=LINE(13:27)
             READ(LINE(28:80),*) NIBLOM(NUBLOC,0),NIBLOE(NUBLOC,0)
C
          END DO
C
      END IF
C
      IF (trim(KEYWOR).EQ.'NIBLOCK_P'.OR.
     *    trim(KEYWOR).EQ.'NIBLOCK-P') THEN
C
          READ(NFIREA,*) NIBLOC(1)
C
          IF (NIBLOC(1).GT.NDBLOC)
     *        STOP ' INCREASE NDBLOC FOR PROTONS IN NAMELI (2)'
C
          DO NUBLOC=1,NIBLOC(1)
C
             READ(NFIREA,'(A80)') LINE
C
             NIBLOL(NUBLOC,1)=LINE(13:27)
             READ(LINE(28:80),*) NIBLOM(NUBLOC,1),NIBLOE(NUBLOC,1)
C
          END DO
C
      END IF
C
C=======================================================================
C         READING THE NEUTRON FILLING CONFIGURATION DATA FOR ALL
C         NO-SYMMETRY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FILNON_NEU'.OR.
     *    trim(KEYWOR).EQ.'FILNON-NEU') THEN
C
          READ(NFIREA,*) KPFILZ(0),
     *                   KHFILZ(0),
     *                   KOFILZ(0)
C
      END IF
C
C=======================================================================
C         READING THE  PROTON FILLING CONFIGURATION DATA FOR ALL
C         NO-SYMMETRY BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FILNON_PRO'.OR.
     *    trim(KEYWOR).EQ.'FILNON-PRO') THEN
C
          READ(NFIREA,*) KPFILZ(1),
     *                   KHFILZ(1),
     *                   KOFILZ(1)
C
      END IF
C
C=======================================================================
C         READING THE NEUTRON FILLING CONFIGURATION DATA FOR ALL
C         SIGNATURE BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FILSIG_NEU'.OR.
     *    trim(KEYWOR).EQ.'FILSIG-NEU') THEN
C
          READ(NFIREA,*) ((KPFILG(IPARIT,ISIGNA,0),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI),
     *                   ((KHFILG(IPARIT,ISIGNA,0),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI),
     *                   ((KOFILG(IPARIT,ISIGNA,0),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE PROTON FILLING CONFIGURATION DATA FOR ALL
C         SIGNATURE BLOCKS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FILSIG_PRO'.OR.
     *    trim(KEYWOR).EQ.'FILSIG-PRO') THEN
C
          READ(NFIREA,*) ((KPFILG(IPARIT,ISIGNA,1),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI),
     *                   ((KHFILG(IPARIT,ISIGNA,1),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI),
     *                   ((KOFILG(IPARIT,ISIGNA,1),ISIGNA=0,NDSIGN),
     *                                             IPARIT=0,NDPARI)
C
      END IF
C
C=======================================================================
C         READING THE MAXIMUM NUMBERS OF MULTIPOLES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAX_MULTIP'.OR.
     *    trim(KEYWOR).EQ.'MAX-MULTIP') THEN
C
          READ(NFIREA,*) NMUCON,NMUCOU,NMUPRI
C
      END IF
C
C=======================================================================
C         READING THE REQUEST TO CALCULATE AND PRINT THE COULOMB MIXING
C         MATRIX ELEMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'COUMATMIX') THEN
C
          READ(NFIREA,*) ICOUMD,ICOUMX
C
      END IF
C
C=======================================================================
C         READING THE MAXIMUM NUMBERS OF SURFACE OR SCHIFF MULTIPOLES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAX_SURFAC'.OR.
     *    trim(KEYWOR).EQ.'MAX_SCHIFF'.OR.
     *    trim(KEYWOR).EQ.'MAX-SURFAC'.OR.
     *    trim(KEYWOR).EQ.'MAX-SCHIFF') THEN
C
          READ(NFIREA,*) NSICON,NSIPRI
C
      END IF
C
C=======================================================================
C         READING THE SWITCH REQUESTING THE REPLACEMENT OF THE SURFACE
C         MOMENTS BY THE SCHIFF MOMENTS
C=======================================================================
C         FOR ISCHIF=0 SURFACE MULTIPOLE MOMENTS ARE CALCULATED
C         FOR ISCHIF=1 SCHIFF  MULTIPOLE MOMENTS ARE CALCULATED
C         FOR ISCHIF=2 SURFACE MULTIPOLE MOMENTS ARE CALCULATED AND
C                      SHIFF   MULTIPOLE MOMENTS OF PROJECTED STATES
C                              ARE PRINTED IN ADDITION.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SCHIFF_MOM'.OR.
     *    trim(KEYWOR).EQ.'SCHIFF-MOM') THEN
C
          READ(NFIREA,*) ISCHIF
C
      END IF
C
C=======================================================================
C         READING THE MAXIMUM NUMBERS OF THE MAGNETIC MULTIPOLES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAX_MAGNET'.OR.
     *    trim(KEYWOR).EQ.'MAX-MAGNET') THEN
C
          READ(NFIREA,*) NMACON,NMAPRI
C
      END IF
C
C=======================================================================
C         READING THE  SWITCHES  REQUESTING  THE  CALCULATION  OF  THE
C         TWO-BODY-CURRENT CONTRIBUTIONS TO THE MAGNETIC DIPOLE MOMENT
C
C         MAG2BC(I)=0 NO CALCULATION    OF THE ITH FORMFACTOR
C         MAG2BC(I)=1 THE EXCHANGE TERM OF THE ITH FORMFACTOR
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAGNET_2BC'.OR.
     *    trim(KEYWOR).EQ.'MAGNET-2BC') THEN
C
          READ(NFIREA,*) (MAG2BC(IFO2BC),IFO2BC=1,NDF2BC)
C
      END IF
C
C=======================================================================
C         READING THE EFFECTVE G FACTORS FOR THE INTRINSIC  AND  SACHS
C         TWO-BODY-CURRENT CONTRIBUTIONS TO THE MAGNETIC DIPOLE MOMENT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TBC_G_FACT'.OR.
     *    trim(KEYWOR).EQ.'TBC-G-FACT') THEN
C
          READ(NFIREA,*) IGY2BC,GYR_IN,GYR_SA
C
          IF (IGY2BC.EQ.1) THEN
C
              GIN2BC=GYR_IN
              GSA2BC=GYR_SA
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE SWITCHES REQUESTING THE CALCULATION OF THE ANAPOLE
C         MOMENTS
C
C         MAGANL(I)=0 NO CALCULATION OF THE I-TH TERM
C         MAGANL(I)=1    CALCULATION OF THE I-TH TERM
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ANAPOLE') THEN
C
          READ(NFIREA,*) (MAGANL(IFOANL),IFOANL=1,NDFANL)
C
      END IF
C
C=======================================================================
C         READING THE EFFECTVE  G FACTORS  FOR  THE  TWO  TERMS  OF  THE
C         ANAPOLE MOMENT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ANA_G_FACT'.OR.
     *    trim(KEYWOR).EQ.'ANA-G-FACT') THEN
C
          READ(NFIREA,*) IGYANL,GYR_J2,GYR_SQ
C
          IF (IGYANL.EQ.1) THEN
C
              GJ2ANL=GYR_J2
              GSQANL=GYR_SQ
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE MAXIMUM NUMBERS OF THE SPIN ASYMMETRY MULTIPOLES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAX_ASYMME'.OR.
     *    trim(KEYWOR).EQ.'MAX-ASYMME') THEN
C
          READ(NFIREA,*) NASCON,NASPRI
C
      END IF
C
C=======================================================================
C         READING THE MAXIMUM ORDER OF THE RADIAL MOMENTS OF THE
C         MAGNETIC MULTIPOLES. NMAORD=0 (DEFAULT) MEANS THAT ONLY
C         THE ZERO MOMENT (STANDARD MAGNETIC MULTIPOLE) WILL BE
C         CALCULATED.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAX_MAGORD'.OR.
     *    trim(KEYWOR).EQ.'MAX-MAGORD') THEN
C
          READ(NFIREA,*) NMAORD
C
      END IF
C
C=======================================================================
C         READING THE MAXIMUM ORDER OF THE RADIAL MOMENTS OF THE
C         RADIUS. NRAORD=0 (DEFAULT) MEANS THAT NO HIGHER MOMENTS
C         WILL BE CALCULATED. HOWEVER, THE SECOND MOMENT (STANDARD
C         RADIUS SQUARED) WILL BE CALCULATED.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAX_RADORD'.OR.
     *    trim(KEYWOR).EQ.'MAX-RADORD') THEN
C
          READ(NFIREA,*) NRAORD
C
      END IF
C
C=======================================================================
C         READING THE MAXIMUM ORDER OF THE RADIAL MOMENTS OF THE
C         SPIN-ASYMMETRY MULTIPOLES. NASORD=-1 (DEFAULT) MEANS
C         THAT NO MOMENTS WILL BE CALCULATED.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MAX_ASMORD'.OR.
     *    trim(KEYWOR).EQ.'MAX-ASMORD') THEN
C
          READ(NFIREA,*) NASORD
C
      END IF
C
C=======================================================================
C         READING THE EFFECTIVE GYROSCOPIC FACTORS, G-FACTORS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EFF_G_FACT'.OR.
     *    trim(KEYWOR).EQ.'EFF-G-FACT') THEN
C
          READ(NFIREA,*) IGYROS,GYR_RP,GYR_PN,GYR_PP
C
          IF (IGYROS.EQ.1) THEN
C
              GYRORP=GYR_RP
              GYRSPN=GYR_PN
              GYRSPP=GYR_PP
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE NUMBERS OF ELECTRIC, MAGNETIC, AND  SURFACE  OR
C         SCHIFF MULTIPOLES, FOR WHICH THE KERNELS AND REDUCED MATRIX
C         ELEMENTS WILL BE CALCULATED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TRANSITION') THEN
C
          READ(NFIREA,*) NMURED,NMARED,NSIRED
C
      END IF
C
C=======================================================================
C         READING THE NUMBER OF SPIN-ASYMMETRY MULTIPOLES, FOR WHICH THE
C         KERNELS AND REDUCED MATRIX ELEMENTS WILL BE CALCULATED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TRANSPIASM') THEN
C
          READ(NFIREA,*) NASRED
C
      END IF
C
C=======================================================================
C         READING THE CUT-OFF PARAMETERS FOR PRINTING ELECTRIC,
C         MAGNETIC, AND SURFACE OR SCHIFF KERNELS  AND  REDUCED
C         MATRIX ELEMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TRANCUTPRI') THEN
C
          READ(NFIREA,*) QMUCUT,QMACUT,QSICUT
C
      END IF
C
C=======================================================================
C         READING THE CUT-OFF PARAMETER FOR PRINTING THE SPIN-ASYMMETRY
C         KERNELS AND REDUCED MATRIX ELEMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TRANASMPRI') THEN
C
          READ(NFIREA,*) QASCUT
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS PERTAINING TO THE BOHR DEFORMATIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BOHR_BETAS'.OR.
     *    trim(KEYWOR).EQ.'BOHR-BETAS') THEN
C
          READ(NFIREA,*) NEXBET,IPRIBE,IPRIBL
C
      END IF
C
C=======================================================================
C         READING THE COULOMB GREEN-FUNCTION CONTROL PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'COULOMB') THEN
C
          READ(NFIREA,*) NUMCOU,NUMETA,FURMAX
C
      END IF
C
C=======================================================================
C         READING THE COULOMB CONTROL PARAMETERS
C=======================================================================
C         FOR ICOUDI=0 THE  DIRECT  COULOMB TERMS ARE NEGLECTED
C         FOR ICOUDI=1 THE  DIRECT  COULOMB TERMS ARE CALCULATED BY  THE
C                      GREEN FUNCTION METHOD (DEFAULT)
C         FOR ICOUDI=2 THE  DIRECT  COULOMB TERMS ARE CALCULATED BY  THE
C                      METHOD OF EXPANDING INTO GAUSSIANS
C         FOR ICOUEX=0 THE EXCHANGE COULOMB TERMS ARE NEGLECTED
C         FOR ICOUEX=1 THE EXCHANGE COULOMB TERMS ARE CALCULATED BY  THE
C                      SLATER APPROXIMATION (DEFAULT)
C         FOR ICOUEX=2 HE EXCHANGE COULOMB TERMS ARE CALCULATED BY  THE
C                      METHOD OF EXPANDING INTO GAUSSIANS>EXACT EXCHANGE
C=======================================================================
C             ICOUDI ICOUEX         DIRECT COULOMB      EXCHANGE COULOMB
C             ------ ------         --------------      ----------------
C                0      0             NEGLECTED            NEGLECTED
C                1      O           GREEN-FUNCTION         NEGLECTED
C                2      0             GAUSSIANS            NEGLECTED
C                0      1             NEGLECTED             SLATER
C                1      1           GREEN-FUNCTION          SLATER
C                2      1             GAUSSIANS             SLATER
C                0      2             NEGLECTED            GAUSSIANS
C                1      2           GREEN-FUNCTION         GAUSSIANS
C                2      2             GAUSSIANS            GAUSSIANS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'COULOMBPAR') THEN
C
          READ(NFIREA,*) ICOTYP,ICOUDI,ICOUEX
C
      END IF
C
C=======================================================================
C         READING THE MEAN-FIELD CHARGE VALUE (AS IN THE PRL PAPER)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'COULOCHARG') THEN
C
          READ(NFIREA,*) E_EFFE
C
      END IF
C
C=======================================================================
C         READING THE YUKAWA PION MASS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'YUKAWA') THEN
C
          READ(NFIREA,*) PIDUMM,I_YUKA
C
          IF (I_YUKA.GE.1.AND.PIDUMM.GT.0.0) PIMASS=PIDUMM
C
      END IF
C
C=======================================================================
C         READING THE YUKAWA CONTROL PARAMETERS FOR THE HAMILTONIAN TERM
C=======================================================================
C         FOR I_YUKA>0,      THE AVERAGE VALUES OF  THE  FINITE-RANGE
C                            YUKAWA INTERACTION ARE CALCULATED
C         FOR I_YUKA=2 OR 3, THE CORRESPONDING  YUKAWA  DIRECT   MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C         FOR I_YUKA=2 OR 4, THE CORRESPONDING YUKAWA  EXCHANGE  MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'YUKAWATERM') THEN
C
          READ(NFIREA,*) PIDUMM,PNDUMM,
     *                   YUKAGT,YUKAG0,YUKAG1,YUKAG2,IYUTYP,I_YUKA
C
          IF (I_YUKA.GE.1.AND.PIDUMM.GT.0.0) PIMASS=PIDUMM
          IF (I_YUKA.GE.1.AND.PNDUMM.GT.0.0) PNMASS=PNDUMM
C
      END IF
C
C=======================================================================
C         READING THE GENERIC PION MASS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PIONMASS') THEN
C
          READ(NFIREA,*) PIDUMM,I_PIMA
C
          IF (I_PIMA.EQ.1.AND.PIDUMM.GT.0.0) PIMASS=PIDUMM
C
      END IF
C
C=======================================================================
C         ATTENTION: THREE DIFFERENT KEYWORDS ABOVE  ALLOW  FOR  READING
C                    THE PION MASS IN "PIMASS". IF MORE THAN ONE OF THEM
C                    WAS PRESENT AND ACTIVE IN THE DATA FILE, THE  FINAL
C                    READ VALUE OF "PIMASS" WOULD DEPEND ON THEIR  ORDER
c                    IN THE DATA FILE AND THE LAST OCCURRENCE  WOULD  BE
C                    USED IN THE CURRENT RUN. THIS WOULD BE INCOMPATIBLE
C                    WITH THE GENERAL RULES OF USING THE HFODD KEYWORDS.
C                    THIS POTENTIAL TRAP IS FOR NOW LEFT UNTREATED.
C=======================================================================
C
C=======================================================================
C         READING THE SWITCH THAT REQUESTS CALCULATIONS WITH THE NEW
C         IMPLEMENTATION OF THE GOGNY INTERACTION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NEW_GOGNY'.OR.
     *    trim(KEYWOR).EQ.'NEW-GOGNY') THEN
C
          READ(NFIREA,*) NEWGOG
C
      END IF
C
C=======================================================================
C         READING THE GOGNY CONTROL PARAMETER
C=======================================================================
C         FOR I_GOGA>0,      THE AVERAGE VALUES OF  THE  FINITE-RANGE
C                            GOGNY INTERACTION ARE CALCULATED
C         FOR I_GOGA=2 OR 3, THE  CORRESPONDING  GOGNY  DIRECT   MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C         FOR I_GOGA=2 OR 4, THE CORRESPONDING  GOGNY  EXCHANGE  MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C=======================================================================
C         FOR IGOGPA>0,      THE  PAIRING  ENERGY OF THE FINITE-RANGE
C                            GOGNY INTERACTION ARE CALCULATED
C         FOR IGOGPA=2       THE  CORRESPONDING  GOGNY  PAIRING FIELD
C                            IS ALSO COMPUTED AND INCLUDED IN THE HFB
C                            MATRIX
C         FOR IGOGPA=3       THE GOGNY  PAIRING  ENERGY  AND  PAIRING
C                            FIELD ARE  COMPUTED  BY  AN  ALTERNATIVE
C                            METHOD PROGRAMMED IN "GAUENE".
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'GOGNY') THEN
C
          READ(NFIREA,*) I_GOGA
C
      END IF
C
      IF (trim(KEYWOR).EQ.'GOGNY_PAIR'.OR.
     *    trim(KEYWOR).EQ.'GOGNY-PAIR') THEN
C
          READ(NFIREA,*) IGOGPA
C
      END IF
C
C=======================================================================
C         READING THE REGULARIZED SKYRME CONTROL PARAMETER
C=======================================================================
C         FOR I_REGA>0,      THE AVERAGE VALUES OF  THE  FINITE-RANGE
C                            REGULARIZED INTERACTION ARE CALCULATED
C         FOR I_REGA=2 OR 3, THE CORRESPONDING REGULARIZED  DIRECT  MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C         FOR I_REGA=2 OR 4, THE CORRESPONDING REGULARIZED EXCHANGE MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C=======================================================================
C         FOR IREGPA>0,      THE  PAIRING  ENERGY OF THE FINITE-RANGE
C                            REGULARIZED INTERACTION IS CALCULATED
C         FOR IREGPA=2       THE CORRESPONDING REGULARIZED PAIRING FIELD
C                            IS ALSO COMPUTED AND INCLUDED IN THE HFB
C                            MATRIX
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REGULFORCE'.OR.
     *    trim(KEYWOR).EQ.'REGUSKYRME') THEN
C
          READ(NFIREA,*) I_REGA
C
      END IF
C
      IF (trim(KEYWOR).EQ.'REGUL_PAIR'.OR.
     *    trim(KEYWOR).EQ.'REGUL-PAIR') THEN
C
          READ(NFIREA,*) IREGPA
C
      END IF
C
C=======================================================================
C         READING THE SEPARABLE FORCE CONTROL PARAMETER
C=======================================================================
C         FOR I_SEPA>0,      THE AVERAGE VALUES OF  THE  FINITE-RANGE
C                            SEPARABLE INTERACTION ARE CALCULATED
C         FOR I_SEPA=2 OR 3, THE CORRESPONDING  SEPARABLE DIRECT  MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C         FOR I_SEPA=2 OR 4, THE CORRESPONDING SEPARABLE EXCHANGE MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C=======================================================================
C         FOR ISEPPA>0,      THE  PAIRING  ENERGY OF THE FINITE-RANGE
C                            SEPARABLE INTERACTION IS CALCULATED
C         FOR ISEPPA=2       THE CORRESPONDING SEPARABLE PAIRING FIELD
C                            IS ALSO COMPUTED AND INCLUDED IN THE HFB
C                            MATRIX
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SEPARGAUSS') THEN
C
          READ(NFIREA,*) I_SEPA
C
      END IF
C
      IF (trim(KEYWOR).EQ.'SEPAR_PAIR'.OR.
     *    trim(KEYWOR).EQ.'SEPAR-PAIR') THEN
C
          READ(NFIREA,*) ISEPPA
C
      END IF
C
C=======================================================================
C         READING THE SWITCH THAT REQUESTS CALCULATIONS WITH THE NEW
C         IMPLEMENTATION OF THE COULOMB INTERACTION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NEW_COUL'.OR.
     *    trim(KEYWOR).EQ.'NEW-COUL') THEN
C
          READ(NFIREA,*) NEWCOU
C
      END IF
C
C=======================================================================
C         READING THE COULOMB FORCE CONTROL PARAMETER FOR NEWCOU=1
C=======================================================================
C         FOR I_COUA>0,      THE AVERAGE VALUES OF  THE  FINITE-RANGE
C                            COULOMB INTERACTION ARE CALCULATED
C         FOR I_COUA=2 OR 3, THE CORRESPONDING  COULOMB DIRECT  MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C         FOR I_COUA=2 OR 4, THE CORRESPONDING COULOMB EXCHANGE MEAN
C                            FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                            MEAN FIELD
C         ATTENTION: CURENTLY, I_COUA=1-4 ARE ALL EQUIVALENT TO I_COUA=2
C                    BUT FOR A CONSISTENCY OF THE PRINTOUTS, ONLY VALUES
C                    OF I_COUA=0 AND 2 SHOULD BE USED IN THE INPUT FILE.
C=======================================================================
C         FOR ICOUPA>0,      THE  PAIRING  ENERGY OF THE FINITE-RANGE
C                            COULOMB INTERACTION IS CALCULATED
C         FOR ICOUPA=2       THE CORRESPONDING COULOMB PAIRING FIELD
C                            IS ALSO COMPUTED AND INCLUDED IN THE HFB
C                            MATRIX
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'COUL_FORCE') THEN
C
          READ(NFIREA,*) I_COUA,ICOUPA
C
      END IF
C
C=======================================================================
C         READING THE FINITE-RANGE SPIN-ORBIT AND TENSOR  FORCE  CONTROL
C         PARAMETERS FOR THE PARTICLE-HOLE CHANNEL (THE MEAN FIELD).
C=======================================================================
C         FOR I_FSTA(1)>0,      THE AVERAGE VALUES OF  THE  FINITE-RANGE
C                               SPIN-ORBIT INTERACTION ARE CALCULATED
C         FOR I_FSTA(1)=2 OR 3, THE CORRESPONDING SPIN-ORBIT DIRECT MEAN
C                               FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                               MEAN FIELD
C         FOR I_FSTA(1)=2 OR 4, THE CORRESPONDING SPIN-ORBIT EXCHANGE
C                               MEAN FIELD IS INCLUDED IN THE SELF-
C                               CONSISTENT MEAN FIELD
C=======================================================================
C         FOR I_FSTA(2)>0,      THE AVERAGE VALUES OF  THE  FINITE-RANGE
C                               ODD TENSOR INTERACTION ARE CALCULATED
C         FOR I_FSTA(2)=2 OR 3, THE CORRESPONDING ODD TENSOR DIRECT MEAN
C                               FIELD IS INCLUDED IN THE SELF-CONSISTENT
C                               MEAN FIELD
C         FOR I_FSTA(2)=2 OR 4, THE CORRESPONDING ODD TENSOR EXCHANGE
C                               MEAN FIELD IS INCLUDED IN THE SELF-
C                               CONSISTENT MEAN FIELD
C=======================================================================
C         FOR I_FSTA(3)>0,      THE AVERAGE VALUES OF  THE  FINITE-RANGE
C                               EVEN TENSOR INTERACTION ARE CALCULATED
C         FOR I_FSTA(3)=2 OR 3, THE CORRESPONDING EVEN TENSOR DIRECT
C                               MEAN FIELD IS INCLUDED IN THE SELF-
C                               CONSISTENT MEAN FIELD
C         FOR I_FSTA(3)=2 OR 4, THE CORRESPONDING EVEN TENSOR EXCHANGE
C                               MEAN FIELD IS INCLUDED IN THE SELF-
C                               CONSISTENT MEAN FIELD
C=======================================================================

      IF (trim(KEYWOR).EQ.'FISOTEMEAN') THEN
C
          READ(NFIREA,*) (I_FSTA(I),I=1,NDFSTA)
C
      END IF
C
C=======================================================================
C         READING THE FINITE-RANGE SPIN-ORBIT AND TENSOR  FORCE  CONTROL
C         PARAMETERS FOR THE PARTICLE-PARTICLE CHANNEL (THE PAIR FIELD).
C=======================================================================
C         FOR IFSTPA(1)>0,      THE  PAIRING  ENERGY OF THE FINITE-RANGE
C                               SPIN-ORBIT INTERACTION IS CALCULATED
C         FOR IFSTPA(1)=2       THE CORRESPONDING SPIN-ORBIT PAIRING
C                               FIELD IS ALSO COMPUTED AND INCLUDED IN
C                               THE HFB MATRIX
C=======================================================================
C         FOR IFSTPA(2)>0,      THE  PAIRING  ENERGY OF THE FINITE-RANGE
C                               ODD TENSOR INTERACTION IS CALCULATED
C         FOR IFSTPA(2)=2       THE CORRESPONDING ODD TENSOR PAIRING
C                               FIELD IS ALSO COMPUTED AND INCLUDED IN
C                               THE HFB MATRIX
C=======================================================================
C         FOR IFSTPA(3)>0,      THE  PAIRING  ENERGY OF THE FINITE-RANGE
C                               EVEN TENSOR INTERACTION IS CALCULATED
C         FOR IFSTPA(3)=2       THE CORRESPONDING EVEN TENSOR PAIRING
C                               FIELD IS ALSO COMPUTED AND INCLUDED IN
C                               THE HFB MATRIX
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FISOTEPAIR') THEN
C
          READ(NFIREA,*) (IFSTPA(I),I=1,NDFSTA)
C
      END IF
C
C=======================================================================
C         READING THE SWITCH THAT SELECTS THE DIAGONAL APPROXIMATION TO
C         GAUSSIAN FORMFACTORS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'DIAGOGAUSS') THEN
C
          READ(NFIREA,*) DIQDUD,DIQDUE,DIQDUP,IDIQGA
C
          IF (IDIQGA.EQ.1) THEN
C
              DIQCOD=DIQDUD
              DIQCOE=DIQDUE
              DIQCOP=DIQDUP
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE REGULARIZED SKYRME COUPLING CONSTANTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REGUORDER') THEN
C
          WRITE(NFIPRI,'(/,
     *            1X,20(1H/),'' FROM VERSION (3.03N) ON, THE USE ''
     *                                              ,2X,20(1H/),/,
     *            1X,20(1H/),'' OF KEYWORD REGUORDER HAS BEEN    ''
     *                                              ,2X,20(1H/),/,
     *            1X,20(1H/),'' DISCONNECTED. PLEASE USE KEYWORDS''
     *                                              ,2X,20(1H/),/,
     *            1X,20(1H/),'' REGUCOUPLI OR REGUL_TXYZ INSTEAD.''
     *                                              ,2X,20(1H/),/)')
C
          STOP ' KEYWORD REGUORDER HAS BEEN DISCONNECTED IN NAMELI'
C
      END IF
C
C=======================================================================
C         THE PSEUDOPOTENTIAL IS DEFINED IN TERMS OF THE  FOLLOWING  TWO
C         OPERATORS:      T1=(K'*^2+K^2)/2       AND        T2=K'* DOT K
C
C         I N T E R N A L L Y, THE ORDER OF TERMS IS AS FOLLOWS:
C
C         ORDER=0 (LO)   INDEX=01, OPERATOR=1
C         ORDER=2 (NLO)  INDEX=21, OPERATOR=T1
C         ORDER=2 (NLO)  INDEX=22, OPERATOR=T2
C         ORDER=4 (N2LO) INDEX=41, OPERATOR=T1^2
C         ORDER=4 (N2LO) INDEX=42, OPERATOR=T1*T2
C         ORDER=4 (N2LO) INDEX=43, OPERATOR=T2^2
C         ORDER=6 (N3LO) INDEX=61, OPERATOR=T1^3
C         ORDER=6 (N3LO) INDEX=62, OPERATOR=T1^2*T2
C         ORDER=6 (N3LO) INDEX=63, OPERATOR=T1*T2^2
C         ORDER=6 (N3LO) INDEX=64, OPERATOR=T2^3
C
C         THE INDEXES ARE USED FOR DEFINING NAMES OF INTERNAL ARRAYS  OF
C         THE  CODE,  SEE  ROUTINES  "DEFGOG"  AND  "GAUENE".  THEY  ARE
C         COMPOSED OF TWO DIGITS, FIRST ONE DENOTING THE ORDER  AND  THE
C         THE SECOND ONE DENOTING THE CONSECUTIVE NUMBER  OF  THE  TERM.
C
C         NOTE THAT OPERATORS T1 AND T2 ARE SCALARS, THAT IS, THEY  BOTH
C         ARE SUMS OF THE CORRESPONDING X, Y, AND Z COMPONENTS. HOWEVER,
C         THE SAME INDEXES ARE ALSO USED FOR ARRAYS  PERTAINING  TO  THE
C         INDIVIDUAL X, Y, AND Z DIRECTIONS.
C
C         E X T E R N A L L Y, THE  ORDER  OF  TERMS,  NUMBERED  BY  THE
C         VARIABLE "INREGA" IN THE INPUT DATA BELOW, IS AS FOLLOWS:
C
C         ORDER=0 (LO)   INREGA= 1, INDEX=01, OPERATOR=1
C         ORDER=2 (NLO)  INREGA= 2, INDEX=21, OPERATOR=T1
C         ORDER=2 (NLO)  INREGA= 3, INDEX=22, OPERATOR=T2
C         ORDER=4 (N2LO) INREGA= 4, INDEX=41, OPERATOR=T1^2+T2^2
C         ORDER=4 (N2LO) INREGA= 5, INDEX=42, OPERATOR=2*T1*T2
C         ORDER=4 (N2LO) INREGA= 6, INDEX=43, OPERATOR=T1^2-T2^2
C         ORDER=6 (N3LO) INREGA= 7, INDEX=61, OPERATOR=T1^3+3*T1*T2^2
C         ORDER=6 (N3LO) INREGA= 8, INDEX=62, OPERATOR=T2^3+3*T1^2*T2
C         ORDER=6 (N3LO) INREGA= 9, INDEX=63, OPERATOR=T1^3-T1*T2^2
C         ORDER=6 (N3LO) INREGA=10, INDEX=64, OPERATOR=T2^3-T1^2*T2
C
C         THE DIFFERENCE BETWEEN INTERNAL  AND  EXTERNAL  CONVENTION  IS
C         INTRODUCED SO AS TO, IN  EACH  ORDER,  THE  DIFFERENCE OF  THE
C         FIRST AND SECOND TERM CORRESPONDS TO A LOCAL POTENTIAL:
C
C         ORDER=2, INDEX=21-22, OPERATOR=T1-T2=(K'*-K)^2/2
C         ORDER=4, INDEX=41-42, OPERATOR=T1^2+T2^2-2*T1*T2
C                                       =(T1-T2)^2=(K'*-K)^4/4
C         ORDER=6, INDEX=61-62, OPERATOR=T1^3+3*T1*T2^2-T2^3-3*T1^2*T2
C                                       =(T1-T2)^3=(K'*-K)^6/8
C=======================================================================
C         THE CODE USES THREE TYPES OF PARAMETERS OF THE REGULARIZED
C         FORCE:
C         1. REGTCC - PARAMETERS IN THE TXYZ REPRESENTATION
C         2. REGVCC - PARAMETERS IN THE COUPLING-CONSTANT REPRESENTATION
C         3. REGBCC - PARAMETERS IN THE COUPLING-CONSTANT REPRESENTATION
C                     SCALED WITH THE POWERS OF WIDTHS AND CHANGED SIGNS
C
C         INTERNALLY: A) FOR N3LORD<0  (T2<>-T1 FORCES)  THE  CODE  USES
C                        PARAMETERS "REGVCC"  O N L Y
C         INTERNALLY: B) FOR N3LORD>0  (T2 =-T1 FORCES)  THE  CODE  USES
C                        PARAMETERS "REGBCC"  O N L Y
C
C         KEYWORD 'REGUCOUPLI' ALLOWS  FOR  READING  "REGVCC".  THEN,
C                              "REGTCC" ARE CALCULATED  AND  "REGBCC"
C                              ARE  CALCULATED  ONLY  FOR   N3LORD>0.
C         KEYWORD 'REGUL_TXYZ' ALLOWS  FOR  READING  "REGTCC".  THEN,
C                              "REGVCC" ARE CALCULATED  AND  "REGBCC"
C                              ARE  CALCULATED  ONLY  FOR   N3LORD>0.
C         KEYWORD 'REGUPARAMS' HAS BEEN DISCONNECTED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REGUPARAMS') THEN
C
          WRITE(NFIPRI,'(/,
     *            1X,20(1H/),'' FROM VERSION (3.03N) ON, THE USE ''
     *                                              ,2X,20(1H/),/,
     *            1X,20(1H/),'' OF KEYWORD REGUPARAMS HAS BEEN   ''
     *                                              ,2X,20(1H/),/,
     *            1X,20(1H/),'' DISCONNECTED. PLEASE USE KEYWORDS''
     *                                              ,2X,20(1H/),/,
     *            1X,20(1H/),'' REGUCOUPLI OR REGUL_TXYZ INSTEAD.''
     *                                              ,2X,20(1H/),/)')
C
          STOP ' KEYWORD REGUPARAMS HAS BEEN DISCONNECTED IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE REGULARIZED-FORCE COUPLING CONSTANTS
C         IN THE W,B,H,M REPRESENTATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REGUCOUPLI') THEN
C
          IREJCO=1
C
          IF (IREJTX.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS REGUCOUPLI AND REGUL_TXYZ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY     ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' REGUCOUPLI/REGUL_TXYZ SIMULTANEOUSLY IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) IREREJ(1),NREREJ(1),REGWID
C
          IF (IREREJ(1).GE.1) THEN
C
              IF (IREREJ(1).GT.NDREGA) STOP'INCREASE NDREGA IN NAMELI 2'
C
              REJVCC=0.0D0
C
              READ(NFIREA,*) ((REJVCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                              ,INREGA=1,IREREJ(1))
          END IF
C
      END IF
C
C=======================================================================
C         READING THE REGULARIZED-FORCE COUPLING-CONSTANTS ERRORS
C         IN THE W,B,H,M REPRESENTATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REGCOUPERR') THEN
C
          READ(NFIREA,*) IREREJ(2),NREREJ(2)
C
          IF (IREREJ(2).GE.1) THEN
C
              IF (IREREJ(2).GT.NDREGA) STOP'INCREASE NDREGA IN NAMELI 4'
C
              REJERR=0.0D0
C
              READ(NFIREA,*) ((REJERR(INREGA,INFORC),INFORC=1,NDFORC)
     *                                              ,INREGA=1,IREREJ(2))
          END IF
C
      END IF
C
C=======================================================================
C         READING THE REGULARIZED-FORCE COUPLING-CONSTANT-ERROR FACTORS
C         IN THE W,B,H,M REPRESENTATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REGCOUPFAC') THEN
C
          READ(NFIREA,*) IREREJ(3),NREREJ(3)
C
          IF (IREREJ(3).GE.1) THEN
C
              IF (IREREJ(3).GT.NDREGA) STOP'INCREASE NDREGA IN NAMELI 5'
C
              REJFAC=0.0D0
C
              READ(NFIREA,*) ((REJFAC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                              ,INREGA=1,IREREJ(3))
          END IF
C
      END IF
C
C=======================================================================
C         READING THE REGULARIZED-FORCE COUPLING CONSTANTS
C         IN THE T-X-Y-Z REPRESETATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REGUL_TXYZ') THEN
C
          IREJTX=1
C
          IF (IREJCO.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS REGUCOUPLI AND REGUL_TXYZ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY     ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' REGUCOUPLI/REGUL_TXYZ SIMULTANEOUSLY IN NAMELI 2'
C
          END IF
C
          READ(NFIREA,*) IREREJ(4),NREREJ(4),REGWID
C
          IF (IREREJ(4).GE.1) THEN
C
              IF (IREREJ(4).GT.NDREGA) STOP'INCREASE NDREGA IN NAMELI 3'
C
              REJTCC=0.0D0
C
              READ(NFIREA,*) ((REJTCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                              ,INREGA=1,IREREJ(4))
          END IF
C
      END IF
C
C=======================================================================
C         THE SEPARABLE PSEUDOPOTENTIAL IS DEFINED IN TERMS OF THE
C         DIFFERENTIAL OPERATORS THAT ARE STRICTLY THE SAME AS THOSE
C         DEFINING THE REGULARIZED PSEUDOPOTENTIAL. THE HIGHER-ORDER
C         ARE, HOWEVER, NOT YET IMPLEMENTED.
C=======================================================================
C         THE CODE USES TWO TYPES OF PARAMETERS OF THE SEPARABLE FORCE:
C         1. SEPTCC - PARAMETERS IN THE T-X-Y-Z REPRESENTATION
C         2. SEPVCC - PARAMETERS IN THE W,B,H,M REPRESENTATION
C
C         THESE PARAMETERS ARE INPUT AS:
C         1. SEPTIC
C         2. SEPVIC
C         PARAMETERS "SEPTIC" ARE USED TO DETERMINE PARAMETERS  "SEPVIC"
C         AND DO NOT LEAVE SUBROUTINE "NAMELI".
C
C         KEYWORD 'SEPAR_TXYZ' ALLOWS  FOR  READING  "SEPTIC" AND  THEN,
C                              PARAMETERS "SEPVIC" ARE CALCULATED.
C         KEYWORD 'SEP_TXYZ'   ALLOWS  FOR  READING  "SEPTIC"  AND  DOES
C                              NOT  READ  THE  WIDTH  OF  THE  GAUSSIAN,
C                              LEAVING THIS TASK TO KEYWORD 'SEPAR_FORM'
C                              THEN, PARAMETERS "SEPVIC" ARE CALCULATED.
C         KEYWORD 'SEPACOUPLI' ALLOWS  FOR  READING  "SEPVIC".
C         KEYWORD 'SEPCOUPLI'  ALLOWS  FOR  READING  "SEPVIC"  AND  DOES
C                              NOT  READ  THE  WIDTH  OF  THE  GAUSSIAN,
C                              LEAVING THIS TASK TO KEYWORD 'SEPAR_FORM'
C
C         PARAMETERS "SEPVCC" AND "SEPTCC" ARE DETERMINED IN THE  "INPUT
C         RELATED PREDEFINITIONS".
C
C=======================================================================
C         READING THE SEPARABLE-FORCE COUPLING CONSTANTS
C         IN THE T-X-Y-Z REPRESENTATION AND THE GAUSSIAN WIDTH
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SEPAR_TXYZ') THEN
C
          ISEPAT=1
C
          IF (ISEPCO.EQ.1.OR.ISEPTX.EQ.1.OR.ISEPAC.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS SEPACOUPLI  /  SEPAR_TXYZ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),''       /  SEPCOUPLI   /  SEP_TXYZ  ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY     ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' SEPARABLE KEYWORDS SIMULTANEOUSLY IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) IVISEP,N3LAUX,SEPAUX
C
          IF (IVISEP.GE.1) THEN
C
              N3SERD=N3LAUX
              NUSEGA=1
              SEPWID(1)=SEPAUX
              SEPGAU(1)=1.0D0
C
              IF (IVISEP.GT.NDSEPA) STOP ' INCREASE NDSEPA IN NAMELI 3'
C
              SEPTIC=0.0D0
C
              READ(NFIREA,*) ((SEPTIC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                                              ,INSEPA=1,IVISEP)
              DO INSEPA=1,IVISEP
C
                 SEPVIC(INSEPA,1)=SEPTIC(INSEPA,1)
                 SEPVIC(INSEPA,2)=SEPTIC(INSEPA,1)*SEPTIC(INSEPA,2)
                 SEPVIC(INSEPA,3)=SEPTIC(INSEPA,1)*SEPTIC(INSEPA,3)
                 SEPVIC(INSEPA,4)=SEPTIC(INSEPA,1)*SEPTIC(INSEPA,4)
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE SEPARABLE-FORCE COUPLING CONSTANTS
C         IN THE T-X-Y-Z REPRESENTATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SEP_TXYZ') THEN
C
          ISEPTX=1
C
          IF (ISEPCO.EQ.1.OR.ISEPAT.EQ.1.OR.ISEPAC.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS SEPACOUPLI  /  SEPAR_TXYZ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),''       /  SEPCOUPLI   /  SEP_TXYZ  ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY     ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' SEPARABLE KEYWORDS SIMULTANEOUSLY IN NAMELI 2'
C
          END IF
C
          READ(NFIREA,*) IVISEP,N3LAUX
C
          IF (IVISEP.GE.1) THEN
C
              N3SERD=N3LAUX
C
              IF (IVISEP.GT.NDSEPA) STOP ' INCREASE NDSEPA IN NAMELI 3'
C
              SEPTIC=0.0D0
C
              READ(NFIREA,*) ((SEPTIC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                                              ,INSEPA=1,IVISEP)
              DO INSEPA=1,IVISEP
C
                 SEPVIC(INSEPA,1)=SEPTIC(INSEPA,1)
                 SEPVIC(INSEPA,2)=SEPTIC(INSEPA,1)*SEPTIC(INSEPA,2)
                 SEPVIC(INSEPA,3)=SEPTIC(INSEPA,1)*SEPTIC(INSEPA,3)
                 SEPVIC(INSEPA,4)=SEPTIC(INSEPA,1)*SEPTIC(INSEPA,4)
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE SEPARABLE-FORCE COUPLING CONSTANTS
C         IN THE W,B,H,M REPRESENTATION AND THE GAUSSIAN WIDTH
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SEPACOUPLI') THEN
C
          READ(NFIREA,*) IVISEP,N3LAUX,SEPAUX
C
          ISEPAC=1
C
          IF (ISEPCO.EQ.1.OR.ISEPTX.EQ.1.OR.ISEPAT.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS SEPACOUPLI  /  SEPAR_TXYZ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),''       /  SEPCOUPLI   /  SEP_TXYZ  ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY     ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' SEPARABLE KEYWORDS SIMULTANEOUSLY IN NAMELI 3'
C
          END IF
C
          IF (IVISEP.GE.1) THEN
C
              N3SERD=N3LAUX
              NUSEGA=1
              SEPWID(1)=SEPAUX
              SEPGAU(1)=1.0D0
C
              IF (IVISEP.GT.NDSEPA) STOP ' INCREASE NDSEPA IN NAMELI 2'
C
              SEPVIC=0.0D0
C
              READ(NFIREA,*) ((SEPVIC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                                              ,INSEPA=1,IVISEP)
          END IF
C
      END IF
C
C=======================================================================
C         READING THE SEPARABLE-FORCE COUPLING CONSTANTS
C         IN THE W,B,H,M REPRESENTATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SEPCOUPLI') THEN
C
          ISEPCO=1
C
          IF (ISEPAC.EQ.1.OR.ISEPTX.EQ.1.OR.ISEPAT.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS SEPACOUPLI  /  SEPAR_TXYZ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),''       /  SEPCOUPLI   /  SEP_TXYZ  ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY     ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' SEPARABLE KEYWORDS SIMULTANEOUSLY IN NAMELI 4'
C
          END IF
C
          READ(NFIREA,*) IVISEP,N3LAUX
C
          IF (IVISEP.GE.1) THEN
C
              N3SERD=N3LAUX
C
              IF (IVISEP.GT.NDSEPA) STOP ' INCREASE NDSEPA IN NAMELI 2'
C
              SEPVIC=0.0D0
C
              READ(NFIREA,*) ((SEPVIC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                                              ,INSEPA=1,IVISEP)
          END IF
C
      END IF
C
C=======================================================================
C         READING THE SEPARABLE-FORCE COUPLING-CONSTANTS ERRORS
C         IN THE W,B,H,M REPRESENTATION.
C         THE NUMER OF ERRORS READ "IERSEP" MUST BE EQUAL TO "IVISEP".
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SEPCOUPERR') THEN
C
          READ(NFIREA,*) IERSEP
C
          IF (IERSEP.GE.1) THEN
C
              IF (IERSEP.GT.NDSEPA) STOP ' INCREASE NDSEPA IN NAMELI 4'
C
              SEPERR=0.0D0
C
              READ(NFIREA,*) ((SEPERR(INSEPA,INFORC),INFORC=1,NDFORC)
     *                                              ,INSEPA=1,IERSEP)
          END IF
C
      END IF
C
C=======================================================================
C         READING THE SEPARABLE-FORCE COUPLING-CONSTANT FACTORS
C         IN THE W,B,H,M REPRESENTATION.
C         THE NUMER OF FACTORS READ "IFASEP" MUST BE EQUAL TO "IVISEP".
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SEPCOUPFAC') THEN
C
          READ(NFIREA,*) IFASEP
C
          IF (IFASEP.GE.1) THEN
C
              IF (IFASEP.GT.NDSEPA) STOP ' INCREASE NDSEPA IN NAMELI 5'
C
              SEPFAC=0.0D0
C
              READ(NFIREA,*) ((SEPFAC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                                              ,INSEPA=1,IFASEP)
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE FINITE-RANGE SPIN-ORBIT AND TENSOR COUPLING
C         CONSTANTS IN THE W,H REPRESENTATION.
C         ATTENTION: IN EACH TERM, ONLY ONE GAUSSIAN FROMFACTOR HAS BEEN
C                    IMPLEMENTED (IGOFST=1)
C         ATTENTION: IN EACH TERM, ONLY THE LOWEST FIRST ORDER  HAS BEEN
C                    IMPLEMENTED (NREFST=1)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FISOTECOUP') THEN
C
          READ(NFIREA,*) IGOFST,NREFST,FSTWID(1)
C
          IF (IGOFST.GE.1) THEN
C
              IF (IGOFST.GT.1)
     *                  STOP' IGOFST.GT.1 NOT YET IMPLEMENTED IN NAMELI'
              IF (NREFST.GT.1)
     *                  STOP' NREFST.GT.1 NOT YET IMPLEMENTED IN NAMELI'
C
              FSOSTR(:,:)=0.0D0
              FTOSTR(:,:)=0.0D0
              FTESTR(:,:)=0.0D0
C
              DO INGOGA=1,IGOFST
C
                 READ(NFIREA,*)(FSOSTR(INGOGA,INFORC),INFORC=1,NDFORC,2)
                 READ(NFIREA,*)(FTOSTR(INGOGA,INFORC),INFORC=1,NDFORC,2)
                 READ(NFIREA,*)(FTESTR(INGOGA,INFORC),INFORC=1,NDFORC,2)
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE EXPANSION OF FORMFACTORS OF THE SEPARABLE FORCE
C         INTO SERIES OF GAUSSIANS.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SEPAR_FORM') THEN
C
          READ(NFIREA,*) NUSEGA
C
          IF (NUSEGA.GE.1) THEN
C
              IF (NUSEGA.GT.NDSEGA) STOP 'INCREASE NDSEGA IN NAMELI'
C
              READ(NFIREA,*) (SEPWID(IUSEGA),IUSEGA=1,NUSEGA)
              READ(NFIREA,*) (SEPGAU(IUSEGA),IUSEGA=1,NUSEGA)
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE TENSOR HYPERCONTRACTION SWITCH
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'HYPERCONTR') THEN
C
          READ(NFIREA,*) IDOTHC
C
      END IF
C
C=======================================================================
C         READING THE MEAN-FIELD SLOW-DOWN PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SLOW_DOWN'.OR.
     *    trim(KEYWOR).EQ.'SLOW-DOWN') THEN
C
          READ(NFIREA,*) SLOWEV,SLOWOD
C
      END IF
C
C=======================================================================
C         READING THE PAIRING SLOW-DOWN PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SLOW_PAIR'.OR.
     *    trim(KEYWOR).EQ.'SLOW-PAIR') THEN
C
          READ(NFIREA,*) SLOWPA
C
      END IF
C
C=======================================================================
C         READING THE LIPKIN-NOGAMI SLOW-DOWN PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SLOWLIPKIN') THEN
C
          READ(NFIREA,*) SLOWLI
C
      END IF
C
C=======================================================================
C         READING THE ALL-FIELDS SLOW-DOWN PARAMETER
C=======================================================================
C         FOR I_SLOW=0, DIFFERENT FIELDS ARE SLOWED DOWN USING DIFFERENT
C                       SLOW-DOWN PARAMETERS, AS IMPLEMENTED IN VERSIONS
C                       UP TO (2.78).
C         FOR I_SLOW=1, THE TOTAL MEAN FIELD IS SLOWED  DOWN  USING  ONE
C                       COMMON SLOW-DOWN  PARAMETER  "SLOWAL",  AND  THE
C                       OTHER SLOW-DOWN PARAMETERS, APART FROM  "SLOWLD"
C                       AND "SLOWLM", ARE IGNORED.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SLOWALLFIL') THEN
C
          READ(NFIREA,*) SLOWAL,I_SLOW
C
      END IF
C
C=======================================================================
C         READING THE LIPKIN-METHOD SLOW-DOWN PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SLOWLIPMTD') THEN
C
          READ(NFIREA,*) SLOWLD,SLOWTP,SLOWRP,SLOWLM
C
      END IF
C
C=======================================================================
C         READING THE PRECISION OF DETERMINING HERMITE POLYNOMIALS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EPS_HERMIT'.OR.
     *    trim(KEYWOR).EQ.'EPS-HERMIT') THEN
C
          READ(NFIREA,*) EPSHER
C
      END IF
C
C=======================================================================
C         READING THE INTEGRATION PARAMETERS FOR "TESGOG"
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'INT_TESGOG'.OR.
     *    trim(KEYWOR).EQ.'INT-TESGOG') THEN
C
          READ(NFIREA,*) RANGX,NPOINT
C
C=======================================================================
C
      END IF
C
C=======================================================================
C         READING THE OPTIMUM-GAUSS-INTEGRATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'OPTI_GAUSS'.OR.
     *    trim(KEYWOR).EQ.'OPTI-GAUSS') THEN
C
          READ(NFIREA,*) IOPTGS
C
      END IF
C
C=======================================================================
C         READING NUMBERS OF POINTS USED FOR THE GAUSS-HERMITE INTEGRALS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'GAUSHERMIT') THEN
C
          READ(NFIREA,*) NXHERM,NYHERM,NZHERM
C
      END IF
C
C=======================================================================
C         READING PARAMETERS DEFINING THE SIZE OF THE OSCILLATOR BASIS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BASIS_SIZE'.OR.
     *    trim(KEYWOR).EQ.'BASIS-SIZE') THEN
C
          READ(NFIREA,*) NOSCIL,NLIMIT,ENECUT
C
          IF (NLIMIT.EQ.0) NLIMIT=((NOSCIL+1)*(NOSCIL+2)*(NOSCIL+3))/6
C
      END IF
C
C=======================================================================
C         READING PARAMETERS DEFINING THE SIZE OF THE OSCILLATOR BASIS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TWCBASSIZE') THEN
C
          READ(NFIREA,*) NLIMTW,ENECTW
C
      END IF
C
C=======================================================================
C         READING THE FACTOR WHICH IS USED FOR SCALING THE VALUE OF
C         HBAR*OMEGA_0 =  41 MEV / A**(1/3)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'HOMEGAZERO') THEN
C
          READ(NFIREA,*) FCHOM0
C
      END IF
C
C=======================================================================
C         READING PARAMETERS OF THE CLASSICAL NUCLEAR SURFACE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SURFAC_PAR'.OR.
     *    trim(KEYWOR).EQ.'SURFAC-PAR') THEN
C
          READ(NFIREA,*) INBASI,IZBASI,R0PARM
C
      END IF
C
C=======================================================================
C         READING THE SWITCH THAT CAN LINK THE PARTICLE-NUMBER BASIS
C         PARAMETERS TO PARTICLE NUMBERS:
C         FOR ILIBAS=0, PARAMETERS INBASI AND IZBASI ARE USED
C         FOR ILIBAS=1, PARAMETERS IN_FIX AND IZBASI ARE USED
C         FOR ILIBAS=2, PARAMETERS INBASI AND IZ_FIX ARE USED
C         FOR ILIBAS=3, PARAMETERS IN_FIX AND IZ_FIX ARE USED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ADPARBASIS') THEN
C
          READ(NFIREA,*) ILIBAS
C
      END IF
C
C=======================================================================
C         READING DEFORMATIONS OF THE  CLASSICAL  NUCLEAR SURFACE.
C         DEFORMATIONS FOR SEVERAL VALUES OF LAMBDA AND MIU CAN BE
C         PROVIDED ON  CONSECUTIVE LINES  BY  READING-IN  NEGATIVE
C         FLIPPED-SIGN VALUES OF LAMBDA FOR ALL BUT THE LAST LINE.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SURFAC_DEF'.OR.
     *    trim(KEYWOR).EQ.'SURFAC-DEF') THEN
C
 1001     READ(NFIREA,*,END=2001) LAMBDA,MIU,ALPHRE(ABS(LAMBDA),MIU)
C
          IF (ABS(LAMBDA).GT.NDLAMB.OR.LAMBDA.EQ.0.OR.MIU.LT.0.OR.
     *                                         MIU.GT.ABS(LAMBDA))
     *
     *        STOP ' ALPHRE INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.LT.0) GO TO 1001
C
      END IF
C
C=======================================================================
C         FOR INPOME=0, VALUES OF BASINX, BASINY, AND BASINZ ARE IGNORED
C         FOR INPOME=1, VALUES OF BASINX,BASINY,BASINZ REPLACE THE
C                       HARMONIC-OSCILLATOR FREQUENCIES.
C         FOR INPOME=2, VALUES OF BASINX, BASINY, AND BASINZ REPLACE THE
C                       HARMONIC-OSCILLATOR LENGHTS.
C         FOR INPOME=3, VALUES OF BASINX, BASINY, AND BASINZ REPLACE THE
C                       HARMONIC-OSCILLATOR CONSTANTS.
C         FOR INPOME=4, VALUES OF BASINX, BASINY, AND BASINZ ARE IGNORED
C                       AND   THE   HARMONIC-OSCILLATOR   LENGHTS    ARE
C                       CALCULATED ACCORDING TO THE  MARKUS'  CODE,  SEE
C                       HIS EMAIL OF 22/03/2019 10:29
C         FOR INPOME=5, VALUES OF BASINX, BASINY, AND BASINZ ARE IGNORED
C                       AND  THE  HARMONIC-OSCILLATOR  FREQUENCIES   ARE
C                       CALCULATED BY PROCHNIAK'S SUBROUTINE  "proprxyz"
C                       FROM THE VALUES OF  THE  QUADRUPOLE  CONSTRAINTS
C                       QASKED(2,0)  AND  QASKED(2,2),  IRRESPECTIVE  OF
C                       WHETHER THESE CONSTRAINTS HAVE BEEN ACTIVATED BY
C                       FLAGS IFLAGQ(2,0) AND IFLAGQ(2,2).
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FREQBASIS') THEN
C
          READ(NFIREA,*) BAXREA(1),BAYREA(1),BAZREA(1),INPOME
C
              BASINX(1)=BAXREA(1)
              BASINY(1)=BAYREA(1)
              BASINZ(1)=BAZREA(1)
C
      END IF
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FREQTWCBAS') THEN
C
          READ(NFIREA,*) BAXREA(NDTWCE),BAYREA(NDTWCE),BAZREA(NDTWCE)
C
          IF (NDTWCE.NE.2)
     *        STOP ' KEYWORD FREQTWCBAS ALLOWED ONLY FOR NDTWCE=2'
C
              BASINX(NDTWCE)=BAXREA(NDTWCE)
              BASINY(NDTWCE)=BAYREA(NDTWCE)
              BASINZ(NDTWCE)=BAZREA(NDTWCE)
C
      END IF
C
C=======================================================================
C         READING THE NOT-TILTED ISOSCALAR ROTATIONAL FREQUENCY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'OMEGAY') THEN
C
          READ(NFIREA,*) OMEGAY
C
      END IF
C
C=======================================================================
C         READING THE NOT-TILTED ISOVECTOR ROTATIONAL FREQUENCY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'OMISOY') THEN
C
          READ(NFIREA,*) OMISOY
C
      END IF
C
C=======================================================================
C         READING THE TILTED CARTESIAN ISOSCALAR ROTATIONAL FREQUENCIES
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 1.98  AND  3.00E,  THE  RESULT  OF
C                    READING KEYWORDS OMEGA_XYZ AND  OMEGA_RTP  DEPENDED
C                    ON THE ORDER IN WHICH THEY  APPEARED  IN  THE  DATA
C                    FILE. ALTHOUGH THIS WAS NOT REALLY A BUG, IT WAS IN
C                    CONTRADICTION WITH THE RULE OF THE  KEYWORDS  BEING
C                    INDEPENDENT OF ONE ANOTHER. THEREFORE ON 16/10/2020
C                    IN VERSION 3.00F, THE OPTION OF  HAVING  THESE  TWO
C                    KEYWORDS SIMLTANEOUSLY IN THE DATA FILE FOR A GIVEN
C                    RUN WAS BLOCKED.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'OMEGA_XYZ'.OR.
     *    trim(KEYWOR).EQ.'OMEGA-XYZ') THEN
C
          IREXYZ=1
C
          IF (IRERTP.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS OMEGA_XYZ AND OMEGA_RTP ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' OMEGA_XYZ AND OMEGA_RTP SIMULTANEOUSLY IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) OMEHAX,OMEHAY,OMEHAZ,ITILAX
C
          IF (ITILAX.EQ.1) THEN
C
              OMEGAX=OMEHAX
              OMEGAY=OMEHAY
              OMEGAZ=OMEHAZ
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE TILTED POLAR ISOSCALAR ROTATIONAL FREQUENCIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'OMEGA_RTP'.OR.
     *    trim(KEYWOR).EQ.'OMEGA-RTP') THEN
C
          IRERTP=1
C
          IF (IREXYZ.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS OMEGA_XYZ AND OMEGA_RTP ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' OMEGA_XYZ AND OMEGA_RTP SIMULTANEOUSLY IN NAMELI 2'
C
          END IF
C
          READ(NFIREA,*) OMERAD,OMETHE,OMEPHI,ITILAX
C
          IF (ITILAX.EQ.1) THEN
C
              OMETHE=OMETHE/DEGRAD
              OMEPHI=OMEPHI/DEGRAD
C
              OMEGAX=OMERAD*SIN(OMETHE)*COS(OMEPHI)
              OMEGAY=OMERAD*SIN(OMETHE)*SIN(OMEPHI)
              OMEGAZ=OMERAD*COS(OMETHE)
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE TILTED ISOVECTOR ROTATIONAL FREQUENCIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'OMISO_XYZ'.OR.
     *    trim(KEYWOR).EQ.'OMISO-XYZ') THEN
C
          READ(NFIREA,*) OMISOX,OMISOY,OMISOZ,ITISAX
C
      END IF
C
C=======================================================================
C         READING REQUEST FOR ADJUSTABLE DIRECTION OF ANGULAR FREQUENCY
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'OMEGA_TURN'.OR.
     *    trim(KEYWOR).EQ.'OMEGA-TURN') THEN
C
          READ(NFIREA,*) IMOVAX
C
      END IF
C
C=======================================================================
C         READING THE SWITCH WHICH CONTROLS THE REMOVAL OF CONSTRAINT ON
C         THE ORBITAL ANGULAR MOMENTUM
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NORBCONSTR') THEN
C
          READ(NFIREA,*) NO_ORB
C
      END IF
C
C=======================================================================
C         READING THE EULER ANGLES (DEGREES) OF THE INITIAL ROTATION OF
C         THE WAVE FUNCTION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'INI_ROTAT'.OR.
     *    trim(KEYWOR).EQ.'INI-ROTAT'.OR.
     *    trim(KEYWOR).EQ.'EULERANGLS') THEN
C
          READ(NFIREA,*) ALPAUX,BETAUX,GAMAUX,INIROT
C
          IF (INIROT.EQ.1) THEN
C
              ALPINI=ALPAUX/DEGRAD
              BETINI=BETAUX/DEGRAD
              GAMINI=GAMAUX/DEGRAD
C
          END IF
C
      END IF
C
C=======================================================================
C         READING INDEXES OF THE INITIAL D2H TRANSFORMATION OF
C         THE WAVE FUNCTION
C=======================================================================
C         THE FOLLOWING TRANSFORMATIONS WILL BE PERFORMED:
C
C                   INIKAR=0 INIKAR=1 INIKAR=2 INIKAR=3
C         INIINV=0     I        Rx       Ry       Rz
C         INIINV=1     P        Sx       Sy       Sz
C         INIINV=2     T        RxT      RyT      RzT
C         INIINV=3     PT       SxT      SyT      SzT
C
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'INI_INVERS'.OR.
     *    trim(KEYWOR).EQ.'INI-INVERS') THEN
C
          READ(NFIREA,*) INIINV,INIKAR
C
      END IF
C
C=======================================================================
C         READING INDEXES OF THE D2H TRANSFORMATION OF  THE  RIGHT  WAVE
C         FUNCTION TO BE USED WHEN  CALCULATING  KERNELS  FOR  IKERNE=1.
C         TRANSFORMATIONS LISTED ABOVE WILL BE PERFORMED.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'KERNINVERS') THEN
C
          READ(NFIREA,*) IKEINV,IKEKAR
C
      END IF
C
C=======================================================================
C         READING THE PARTICLE-NUMBER-PROJECTION PARAMETERS FOR  SINGLE-
C         REFERENCE CALCULATIONS (T. LESINSKI)
C         NPPNPN = Num. of Points for Particle Num. Projection, Neutrons
C         NPPNPP = Num. of Points for Particle Num. Projection, Protons
C         PN Projection disabled for NPPNPN<=0 or NPPNPP<=0
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PARTNUMPRJ') THEN
C
         READ(NFIREA,*) IPNPRJ,NPPNPN,NPPNPP
C
      END IF
C
C=======================================================================
C         ATTENTION!   INPUT PARAMETERS "IPRROT", "IPRISO", AND "IPRIS3"
C                      BELOW ARE KEPT ONLY FOR COMPATIBILITY REASONS:
C                      IPRROT --> CORRESPONDS TO USING  THE  RECOMMENDED
C                                 KEYWORD "PROJECTGCM"
C                      IPRISO --> CORRESPONDS TO USING  THE   OBSOLETE
C                                 KEYWORD "PROJECTISO"
C                      IPRIS3 --> CORRESPONDS TO USING  THE  RECOMMENDED
C                                 KEYWORD "PROJ3D_ISO"
C                      IPRNUM --> CORRESPONDS TO USING  THE  RECOMMENDED
C                                 KEYWORD "PROJPARNUM"
C                      IPRVEC --> CORRESPONDS TO USING  THE  RECOMMENDED
C                                 KEYWORD "PROJVECNUM"
C                      IPRPTY --> CORRESPONDS TO USING  THE  RECOMMENDED
C                                 KEYWORD "PROJPARITY"
C=======================================================================
C        ATTENTION!  BETWEEN VERSIONS 2.66H AND 2.98, THE WAY TO  DEFINE
C                    THE SWITCH "IPRGCM" COULD HAVE BEEN CAUSING PROBLEM
C                    IF CASE THE USER WAS HAVING IN THE INPUT DATA:
C                    KEYWORD "PROJECTISO" WITH IPRISO=0 OR
C                    KEYWORD "PROJ3D_ISO" WITH IPRIS3=0
C                            AND SIMULTANEOUSLY:
C                    KEYWORD "PROJECTGCM" WITH IPRROT>0.
C                    THEN, PARAMETERS READ UNDER THE FIRST TWO  KEYWORDS
C                    WERE SET AND USED BY THE CODE. THIS  MIGHT  BE  IN
C                    CONTRADICTION  WITH  THE  INTENTION  OF  THE  USER,
C                    BECAUSE FOR THE LEAD SWITCHES EQUAL  TO  ZERO,  THE
C                    FOLLOWING PARAMETERS SHOULD  HAVE  BEEN  NEGLECTED.
C                    THIS BUG WAS CORRECTED  ON  03/08/2020  IN  VERSION
C                    2.98A.
C=======================================================================
C                      IPRGCM --> IN THE MAIN PROGRAM, PARAMETER  IPRGCM
C                                 IS SET TO ANY OF THE  FIVE  PARAMETERS
C                                 ABOVE. AMONG THOSE THAT ARE  NON-ZERO,
C                                 THE LAST  ONE  (IN  THE  ABOVE  ORDER)
C                                 SERVES TO DEFINE IPRGCM.
C                                 THEREFORE, A SAFE PRACTICE IS TO  KEEP
C                                 IN THE INPUT DATA ALL NON-ZERO  VALUES
C                                 OF THESE SWITCHES  INDENTICAL  TO  ONE
C                                 ANOTHER.
C=======================================================================
C         FOR IPRGCM = 0   NONE OF THE SINGLE-REFERENCE KERNELS USED
C         FOR IPRGCM = 1      DIAGONAL SINGLE-REFERENCE KERNELS USED
C         FOR IPRGCM = 2  NON-DIAGONAL SINGLE-REFERENCE KERNELS USED
C         FOR IPRGCM = 4      DIAGONAL  MULTI-REFERENCE KERNELS USED
C         FOR IPRGCM = 5  NON-DIAGONAL  MULTI-REFERENCE KERNELS USED
C
C             DIAGONAL SINGLE-REFERENCE KERNELS ARE THOSE PERTAINING
C                      TO THE SAME LEFT AND RIGHT INTRINSIC STATES
C         NON-DIAGONAL SINGLE-REFERENCE KERNELS ARE THOSE PERTAINING
C                      TO TWO DIFFERENT LEFT AND RIGHT INTRINSIC STATES
C             DIAGONAL  MULTI-REFERENCE KERNELS ARE THOSE PERTAINING
C                      TO THE SAME LEFT AND RIGHT COMBINATIONS OF
C                      INTRINSIC STATES
C         NON-DIAGONAL  MULTI-REFERENCE KERNELS ARE THOSE PERTAINING
C                      TO TWO DIFFERENT LEFT AND RIGHT COMBINATIONS OF
C                      INTRINSIC STATES
C
C         NUAKNO (NUBKNO) ARE NUMBERS OF GAUSS POINTS THAT SERVE TO
C         PERFORM INTEGRATIONS OVER ALPHA AND  GAMMA  (BETA)  EULER
C         FOR THE ANGULAR MOMENTUM PROJECTION (AMP).
C         FOR NUAKNO = 1  AND NUBKNO = 1  NO AMP IS PERFORMED
C         FOR NUAKNO = 1  AND NUBKNO > 1  THE 1D PROJECTION ON GOOD
C                                         ANGULAR    MOMENTUM    IS
C                                         PERFORMED BY ASSUMING  AN
C                                         AXIAL SHAPE  AND  A  GOOD
C                                         VALUE  OF  THE   MAGNETIC
C                                         COMPONENT, WHICH  IN  THE
C                                         INPUT DATA  IS  GIVEN  BY
C                                         THE PARAMETER "KPROJE".
C         FOR NUAKNO > 1                  THE 3D PROJECTION ON GOOD
C                                         ANGULAR    MOMENTUM    IS
C                                         PERFORMED
C
C         IPROMI (IPROMA) ARE DOUBLED MINIMUM (MAXIMUM)  VALUES  OF
C         RANGE OF ANGULAR MOMENTA FOR WHICH THE  AMP  CALCULATIONS
C         ARE PERFORMED.
C         FOR NUAKNO = 1  AND NUBKNO = 1 THESE VALUES  ARE  IGNORED
C
C         IFRWAV (ITOWAV) ARE THE THREE-DIGIT NUMBERS THAT ARE USED
C         TO NAME THE FILES THAT STORE RESULTS OF THE  DIAGONAL  OR
C         NON-DIAGONAL GCM CALCULATION.
C         --> FOR IFRWAV>0, THE GCM KERNELS ARE CALCULATED  BETWEEN
C             ALL WAVE FUNCTIONS FROM "IFRWAV" TO "ITOWAV" AND  THE
C             WAVE FUNCTION "ITOWAV".
C         --> FOR IFRWAV<0, THE GCM KERNELS ARE CALCULATED  O N L Y
C             BETWEEN THE WAVE  FUNCTION  "-IFRWAV"  AND  THE  WAVE
C             FUNCTION "ITOWAV".
C
C         FOR IPRGCM<2 AND IWRWAV=1, THE VALUE OF IFRWAV IS IGNORED
C                                    AND A DIAGONAL GCM CALCULATION
C                                    IS STORED WITH  THE  VALUE  OF
C                                    "IFRWAV" IDENTIFIED IDENTIFIED
C                                    WITH "ITOWAV".
C
C         FOR IPRGCM <2 AND IWRWAV=0
C                       AND ISAKER=0 THE VALUE OF ITOWAV IS IGNORED
C
C         FOR IWRWAV = 0 (1) THE  WAVE FUNCTIONS CALCULATED IN  THE
C                        CURRENT RUN ARE NOT  (ARE)  STORED IN  THE
C                        FILE WHOSE NAME STARTS FROM  "ITOWAV"  AND
C                        IS FOLLOWED BY "FILWAV".
C         --> FOR CALCULATIONS OF THE GCM KERNELS  (IPRGCM=2)  THAT
C             REQUIRE  K-MIXING  (NUAKNO>1)  AND  PRINTING  OF  THE
C             REDUCED MATRIX ELEMENTS (IRMPRI=1), THE WAVE-FUNCTION
C             FILES MUST BE CALCULATED IN PREVIOUS RUNS  (BLOCKS 2)
C             AND STORING THEM IN THE CURRENT RUN (IWRWAV=1) IS NOT
C             ALLOWED.
C
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROJECTGCM') THEN
C
          READ(NFIREA,*) IPRROT,IREPA1,IREPA2,IREPA3,IREPA4,IREPA5,
     *                                        IREPA6,IREPA7,IREPA8
C
          IF (IPRROT.GE.1) THEN
C
              IPROMI=IREPA1
              IPROMA=IREPA2
              NUAKNO=IREPA3
              NUBKNO=IREPA4
              KPROJE=IREPA5
              IFRWAV=IREPA6
              ITOWAV=IREPA7
              IWRWAV=IREPA8
C
          END IF
C
      END IF
C
C=======================================================================
C         ISOSMI (ISOSMA) ARE DOUBLED MINIMUM (MAXIMUM)  VALUES  OF  THE
C         ISOSPIN FOR WHICH THE ISOSPIN PROJECTION IS PERFORMED.
C
C         FOR THE KEYWORD PROJECTISO, ISOSMI AND ISOSMA ARE SET AS:
C                  ISOSMI=ABS(N-Z)   AND    ISOSMA=ISOSTZ+ISOSAD
C                  WHERE PARAMETER ISOSAD IS READ.
C
C         FOR THE KEYWORD PROJ3D_ISO, ISOSMI AND ISOSMA ARE SET AS:
C                  ISOSMI=KSOSMI     AND    ISOSMA=KSOSMA
C                  WHERE PARAMETERS KSOSMI AND KSOSMA ARE READ.
C
C=======================================================================
C         NATKNO (NBTKNO) ARE NUMBERS OF GAUSS POINTS THAT ARE USED
C         TO PERFORM INTEGRATIONS OVER ALPHA_T AND GAMMA_T (BETA_T)
C         EULER ANGLES IN ORDER TO REALIZE THE ISOPIN PROJECTION.
C         FOR NATKNO = 1  AND NBTKNO = 1  NO IP IS PERFORMED
C         FOR NATKNO = 1  AND NBTKNO > 1  THE 1D PROJECTION ON GOOD
C                                         ISOSPIN IS  PERFORMED  BY
C                                         ASSUMING A GOOD VALUE  OF
C                                         THE  THIRD  COMPONENT  OF
C                                         THE ISOPSPIN KSOSTZ=(N-Z)
C         FOR NUAKNO > 1  AND NBTKNO = 1  THE 1D PROJECTION ON GOOD
C                                         THIRD  COMPONENT  OF  THE
C                                         ISOSPIN IS PERFORMED (NOT
C                                         IMPLEMENTED YET)
C         FOR NUAKNO > 1  AND NBTKNO > 1  THE 3D PROJECTION ON GOOD
C                                         ISOSPIN IS PERFORMED (NOT
C                                         DEBUGGED YET)
C=======================================================================
C      ATTENTION: BETWEEN  VERSIONS  248WF  AND  282Q, VARIABLE "IFERME"
C                 WAS USED TO DEFINE CALCULATION  OF  BETA  TRANSITIONS.
C                 IN VERSION 282R ON 27/07/2017, THIS FUNCTIONALITY  WAS
C                 TRANSFERRED TO VARIABLE "IBETME".
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROJECTISO') THEN
C
          READ(NFIREA,*) IPRISO,IREPA1,IREPA2,AREPA3,IREPA4,IREPA5
C
          IF (IPRISO.GE.1) THEN
C
              ISOSAD=IREPA1
              NBTKNO=IREPA2
              EPSISO=AREPA3
              ICSKIP=IREPA4
              IFERME=IREPA5
C
C             CALCULATE THE FERMI SUPERALLOWED
C
              IF (IFERME.NE.0) THEN
C
                 IBETME = IFERME
                 IIFERR = 0
                 ITFERR = 2
                 ISFERR = 1
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROJ3D_ISO'.OR.
     *    trim(KEYWOR).EQ.'PROJ3D-ISO') THEN
C
          READ(NFIREA,*) IPRIS3,IREPA1,IREPA2,IREPA3,IREPA4,IREPA5,
     *                                        AREPA6,IREPA7
C
          IF (IPRIS3.GE.1) THEN
C
              KSOSMI=IREPA1
              KSOSMA=IREPA2
              NATKNO=IREPA3
              NBTKNO=IREPA4
              KSOSTZ=IREPA5
              EPSISO=AREPA6
              ICSKIP=IREPA7
C
          END IF
C
      END IF
C
C=======================================================================
C         READING  THE  PARTICLE-NUMBER-PROJECTION  PARAMETERS  FOR  THE
C         PROJECTED GCM CALCULATIONS (DIAGONAL OR NON-DIAGONAL  KERNELS)
C         NPNKNO = NUMBER OF POINTS FOR TOTAL PARTICLE  NUM.  PROJECTION
C         ONLY THE PROJECTION ON THE NUMBER OF PARTICLE IN_FIX+IZ_FIX IS
C         PERFORMED. THE TOTAL PARTICLE NUMBER PROJECTION  DISABLED  FOR
C         NPNKNO=1
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROJPARNUM') THEN
C
          READ(NFIREA,*) IPRNUM,IREPA1
C
          IF (IPRNUM.GE.1) THEN
C
              NPNKNO=IREPA1
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE  ISOVECTOR-NUMBER-PROJECTION  PARAMETERS  FOR  THE
C         PROJECTED GCM CALCULATIONS (DIAGONAL OR NON-DIAGONAL  KERNELS)
C         NTZKNO = NUMBER OF POINTS FOR TOTAL ISOVECTOR NUM.  PROJECTION
C         ONLY THE PROJECTION ON THE NUMBER OF PARTICLE IN_FIX-IZ_FIX IS
C         PERFORMED. THE TOTAL ISOVECTOR NUMBER PROJECTION DISABLED  FOR
C         NTZKNO=1
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROJVECNUM') THEN
C
          READ(NFIREA,*) IPRVEC,IREPA1
C
          IF (IPRVEC.GE.1) THEN
C
              NTZKNO=IREPA1
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE PARTITY-PROJECTION PARAMETERS NPAKNO AND IPAPRO
C         PARTITY PROJECTION DISABLED FOR NPAKNO=1
C         PARTITY PROJECTION  ENABLED FOR NPAKNO=2
C         PROJECTION ON THE POSITIVE PARITY FOR IPAPRO=+1
C         PROJECTION ON THE NEGATIVE PARITY FOR IPAPRO=-1
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROJPARITY') THEN
C
          READ(NFIREA,*) IPRPTY,IREPA1,IREPA2
C
          IF (IPRPTY.GE.1) THEN
C
              NPAKNO=IREPA1
              IPAPRO=IREPA2
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE SWITCH THAT REQUESTS USING THE  UNPROJECTED  TOTAL
C         DENSITY IN THE TOTAL PARTICLE-NUMBER PROJECTION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PROJE_DENS') THEN
C
          READ(NFIREA,*) IDENSU
C
      END IF
C
C=======================================================================
C     IF ICOMIX.EQ.0 - KERNELS NXXX-LYYY-RZZZ-//FILKER ARE CALCULATED
C                      WHERE LYYY-RZZZ- ARE EQUAL INLKER AND INRKER,
C                      RESPECTIVELY
C     IF ICOMIX.EQ.1 - CONFIGURATION MIXING IS CALCULATED. ALL KERNELS
C                      NXXX-LYYY-RZZZ-//FILKER WITH LYYY AND RZZZ
C                      RANGING BETWEEN IFRWAV AND ITOWAV SHOULD EXIST
C=======================================================================
C
      IF (KEYWOR.EQ.'CONFMIXING') THEN
C
          READ(NFIREA,*) ICOMIX,INLKER,INRKER,ICMPRI,EPSMIX
C
      END IF
C
C=======================================================================
C         KEYWORDS "CONLISTING" AND "CONFIGMIX"  ARE  BOTH  READING  THE
C         SAME ARRAY "IN_EXC", HOWEVER, THE FORMER READS ALL ELEMENTS UP
C         TO THE DECLARED DIMENSION "ND_EXC", WHEREAS THE LATTER  BEGINS
C         BY READING  THE NUMBER OF ITS ELEMENTS "NU_EXC" AND THEN READS
C         ONLY "NU_EXC" ELEMENTS OF "IN_EXC".
C
C         FOR NOW, OUTSIDE "NAMELI", VARIABLE "NU_EXC" IS NOT  USED  AND
C         ALL ELEMENTS OF ARRAY "IN_EXC" ARE ANYHOW CHECKED  UP  TO  THE
C         DECLARED DIMENSION "ND_EXC".
C
C         THE I-TH ELEMENT OF ARRAY  "IN_EXC"  CONTAINS  THE  NUMBER  OF
C         K-MIXED STATES THAT HAVE  TO  BE  TAKEN  FROM  THE  I-TH  NCCI
C         CONFIGURATION AND INCLUDED IN THE NCCI MIXING.
C=======================================================================
C
      IF (KEYWOR.EQ.'CONLISTING') THEN
C
          IN_EXC(:)=0
C
          READ(NFIREA,*) (IN_EXC(I),I=1,ND_EXC)
C
      END IF
C
      IF (KEYWOR.EQ.'CONFIGMIX') THEN
C
          IN_EXC(:)=0
C
          READ(NFIREA,*) NU_EXC,(IN_EXC(I),I=1,NU_EXC)
C
          IF (NU_EXC.GT.ND_EXC) STOP ' INCREASE ND_EXC'
C
      END IF
C
C=======================================================================
C         READING  ARRAY  "INCONF"  THAT  CONTAINS   SWITCHES   DENOTING
C         CONFIGURATIONS INCLUDED (1) OR NOT INCLUDED (0) IN THE LIST
C         OF MULTI-REFERENCE MIXED CONFIGURATIONS.
C=======================================================================
C
      IF (KEYWOR.EQ.'MIXCONFIG') THEN
C
          INCONF(:)=0
C
          READ(NFIREA,*) ILCONF,(INCONF(I),I=1,ILCONF)
C
          IF (ILCONF.GT.NDCONF) STOP ' INCREASE NDCONF IN NAMELI'
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE CONTAINING  INFORMATION  ABOUT  FERMI
C         MATRIX ELEMENTS.
C=======================================================================
C
      IF (KEYWOR.EQ.'FILFERMATE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILFER)
C
      END IF
C
C=======================================================================
C         READING PARAMETERS USED FOR THE CALCULATION OF BETA TRANSITION
C         MATRIX ELEMENTS.
C=======================================================================
C
      IF (KEYWOR.EQ.'BETAME_ISO') THEN
C
          READ(NFIREA,*) ISOADD,NBTKNT
C
      END IF
C
C=======================================================================
C         READING THE SWITCH "ISAKER" THAT DECIDES WHETHER KERNELS
C         IN FUNCTION OF EULER ANGLES ARE STORED ON DISK.
C=======================================================================
C         FOR ISAKER=1 THE CODE FIRST ATTEMPTS READING  THE  FILES
C         NXXX-LYYY-RZZZ-//FILKER, WHERE THE 3-DIGIT INTEGERS ARE:
C              XXX IS THE NUMBER OF THE "FILKER" FILE
C              YYY IS THE NUMBER OF THE  LEFT WAVE FUNCTION
C              ZZZ IS THE NUMBER OF THE RIGHT WAVE FUNCTION
C         IF A FILE LIKE THAT EXISTS, THEN THE KERNELS  STORED  IN
C         THIS FILE ARE READ AND WILL NOT BE CALCULATED. THE FILES
C         FOR ALL XXX ARE SCANNED. NEXT, THOSE KERNELS, WHICH HAVE
C         NOT BEEN FOUND ON DISK ARE CALCULATED AND STORED IN  THE
C         FILE WITH THE NEXT HIGHER AVAILABLE XXX.
C=======================================================================
C         FOR ISAKER=2  AND  IPAKER=1,  THE  CODE  FIRST  ATTEMPTS
C         READING THE FILES NXXXXXT-LYYY-RZZZ-//FILKER, WHERE  THE
C         4 INTEGERS ARE:
C              XXXXX: IS THE NUMBER OF THE "FILKER" FILE  THAT  IS
C                     EQUAL TO "KFIKER"
C                  T: IS THE NUMBER FROM 0 TO 9 OF THE CONSECUTIVE
C                     FILE WITHIN THE FILE NUMBER "KFIKER"
C                YYY: IS THE NUMBER  OF  THE  LEFT  WAVE  FUNCTION
C                ZZZ: IS THE NUMBER OF  THE  RIGHT  WAVE  FUNCTION
C         IF A FILE LIKE THAT EXISTS, THEN THE KERNELS  STORED  IN
C         THIS FILE ARE READ AND WILL NOT BE CALCULATED. THE FILES
C         FOR ALL "T" ARE SCANNED. NEXT, THOSE KERNELS, WHICH HAVE
C         NOT BEEN FOUND ON DISK ARE CALCULATED AND STORED IN  THE
C         FILE WITH THE NEXT HIGHER AVAILABLE "T".
C=======================================================================
C         FOR ISAKER=2  AND  IPAKER<>1, THE CODE READS  ALL  FILES
C         NXXXXXT-LYYY-RZZZ-//FILKER, WHERE THE XXXXX VARIES  FROM
C         1 TO "KFIKER" AND T VARIES FROM 0 TO 9 AND  ALL  KERNELS
C         COLECTED IN THIS WAY ARE USED FOR PROJECTION.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SAVEKERNEL') THEN
C
          READ(NFIREA,*) ISAKER
C
      END IF
C
C=======================================================================
C         READING THE SWITCH "ICHKER" THAT SUSPENDS THE COMPARISON
C         OF NAMES OF KERNEL FILES WITH THE RECOREDED NAMES.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CHECKERNEL') THEN
C
          READ(NFIREA,*) ICHKER
C
      END IF
C
C=======================================================================
C         READING THE NUMBERS OF ALPHA AND GAMMA KNOTS FOR PARALLEL
C         CALCULATIONS
C=======================================================================
C         FOR IPAKER=1 CALCULATIONS OF KERNELS ARE PERFORMED ONLY:
C             FOR ALPHA KNOTS FROM NUASTA TO NUASTO
C             FOR GAMMA KNOTS FROM NUGSTA TO NUGSTO
C         AND THE INTEGRATION OF KERNELS IS SUSPENDED
C
C         FOR IPAKER<>1 CALCULATIONS OF KERNELS ARE PERFORMED FOR ALL
C             ALPHA AND GAMMA AND THEN THE KERNELS ARE INTEGRATED
C
C         FOR IPAKER=-1 KERNELS ARE SUPPOSED TO BE ALREADY CALCULATED
C             AND THE KERNELS ARE INTEGRATED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PARAKERNEL') THEN
C
          READ(NFIREA,*) IPAKER,NUASTA,NUASTO,NUGSTA,NUGSTO
C
      END IF
C
C=======================================================================
C         READING THE NUMBERS OF ALP_T AND GAM_T ISOSPIN KNOTS FOR
C         PARALLEL CALCULATIONS
C=======================================================================
C         FOR IPAKER=1 AND IPAK3D=1 CALCULATIONS OF KERNELS ARE
C         PERFORMED ONLY:
C             FOR ALP_T KNOTS FROM NATSTA TO NATSTO
C             FOR GAM_T KNOTS FROM NGTSTA TO NGTSTO
C         AND THE INTEGRATION OF KERNELS IS SUSPENDED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PARAKER_3D') THEN
C
          READ(NFIREA,*) IPAK3D,NATSTA,NATSTO,NGTSTA,NGTSTO
C
      END IF
C
C=======================================================================
C         READING THE NUMBERS OF BETA AND GAUGE KNOTS FOR PARALLEL
C         CALCULATIONS
C=======================================================================
C         FOR IPAKER=1 AND IPAALL=1 CALCULATIONS  OF  KERNELS  ARE
C         PERFORMED ONLY:
C             FOR BETA  KNOTS FROM NUBSTA TO NUBSTO
C             FOR GAUGE KNOTS FROM NUTSTA TO NUTSTO
C         AND THE INTEGRATION OF KERNELS IS SUSPENDED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PARA_ALL') THEN
C
          READ(NFIREA,*) IPAALL,NUBSTA,NUBSTO,NUTSTA,NUTSTO
C
      END IF
C
C=======================================================================
C         READING THE NUMBER OF THE KERNEL FILE TO BE USED
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NUMBKERNEL') THEN
C
          READ(NFIREA,*) KFIKER
C
      END IF
C
C=======================================================================
C         READING THE SWITCH REQUESTING CALCULATIONS THAT USE THE  NEW
C         PFAFFIAN ROUTINES IMPLEMENTED ON 14/05/2019 BY PIERRE BECKER
C         IN VERSION 2.90D. REMOVED FROM VERSION  2.95O, AFTER  A  NEW
C         IMPLEMENTATION BY JEREMY BONNARD IN  MAY  2020.  IN  VERSION
C         3.01F CHANGED INTO SWITCH "IONISH".
C=======================================================================
C
C      IF (trim(KEYWOR).EQ.'NEWPFAFFIA') THEN
C
C          READ(NFIREA,*) NEWPFA
C
C      END IF
C
C=======================================================================
C         READING THE SWITCH REQUESTING CALCULATIONS THAT USE THE ONISHI
C         FORMULA INSTEAD OF THE PFAFFIAN FORMULA TO CALCULATE  OVERLAPS
C         BETWEEN PAIRED STATES.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ONISHI') THEN
C
          READ(NFIREA,*) IONISH
C
      END IF
C
C=======================================================================
C         READING THE OVERLAP CUTOFF PARAMATERS
C=======================================================================
C         FOR ICUTOV=0 PARAMETERS CUTOVE AND CUTOVF ARE IGNORED AND THE
C                      COLLECTIVE STATES FOR THE  K-MIXING  CALCULATION
C                      ARE SELECTED BY  THEIR  NORM  EIGENVALUES  BEING
C                      LARGER THAN "OVEMIN",  WHICH  IS  EQUAL  TO  THE
C                      NEGATIVE OF THE SMALLEST NORM EIGENVALUE.
C         FOR ICUTOV=1 THE   COLLECTIVE   STATES   FOR   THE   K-MIXING
C                      CALCULATION  ARE   SELECTED   BY    THEIR   NORM
C                      EIGENVALUES BEING LARGER THAN:
C                                    CUTOVE + CUTOVF * OVEMIN.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CUTOVERLAP') THEN
C
          READ(NFIREA,*) ICUTOV,CUTOVE,CUTOVF
C
      END IF
C
C=======================================================================
C               READING THE PARAMATERS FOR BETA TRANSITIONS
C
C               IF IBETME.EQ.0
C                    DO NOTHING
C
C               IF IBETME.EQ.+1
C                    CALCULATE FERMI M.E.
C                           <i;I,T_i,Tz|T_{-/+}|j;I,T_f,Tz+/-1>
C               IF IBETME.EQ.+2
C                    CALCULATE FERMI M.E. & GAMOW-TELLER M.E.
C                         <i;I  ,T_i,Tz| T_{-/+}|j;I  ,T_f,Tz+/-1>
C                         <i;I_i,T_i,Tz|GT_{-/+}|j;I_f,T_f,Tz+/-1>
C               IF IBETME.EQ.+3
C                    CALCULATE .................................
C                         <            |        |                >
C                         <            |        |                >
C               IF IBETME.EQ.-1
C                    STORE  |i;I,T_i,Tz> WAVE FUNCTION WHERE
C                            2I - IIFERR
C                            2T - ITFERR
C                             i - ISFERR
C=======================================================================
C      ATTENTION: BETWEEN  VERSIONS  254E  AND  273I,  INTEGERS  IIFERR,
C                 ITFERR, AND ISFERR WERE READ FROM KEYWORD "PROJECTISO"
C                 ABOVE. THIS BROKE COMPATBILITY  WITH PREVIOUS VERSIONS
C                 AND WAS THUS REMOVED IN VERSION 274E ON 21/05/2015.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FERMIMATEL'.OR.
     *    trim(KEYWOR).EQ.'BETA_MATEL'.OR.
     *    trim(KEYWOR).EQ.'BETA-MATEL') THEN
C
          READ(NFIREA,*) IBETME,IIFERR,ITFERR,ISFERR
C
      END IF
C
C=======================================================================
C         READING THE SWITCH REQUESTING CALCULATIONS OF THE WIGNER D
C         FUNCTIONS BY METHODS OF PHYS. REV. E92, 043307 (2015)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NEW_WIGNER'.OR.
     *    trim(KEYWOR).EQ.'NEW-WIGNER') THEN
C
          READ(NFIREA,*) NEWWIG
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON-MASS RENORMALIZATION SWITCH
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RENORMASS') THEN
C
          READ(NFIREA,*) IRENMA,DISTAX,DISTAY,DISTAZ
C
      END IF
C
C=======================================================================
C         READING THE NUCLEON-MASS RENORMALIZATION FACTORS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'TRANSLMASS') THEN
C
          READ(NFIREA,*) (HBMRIN(KARTEZ),KARTEZ=1,NDKART)
C
      END IF
C
C=======================================================================
C         READING THE NUCLEAR-INERTIA RENORMALIZATION SWITCH
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RENORINERT') THEN
C
          READ(NFIREA,*) IRENIN,ROTATX,ROTATY,ROTATZ
C
      END IF
C
C=======================================================================
C         READING THE NUCLEAR-INERTIA RENORMALIZATION FACTORS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ROTATINERT') THEN
C
          READ(NFIREA,*) (ROTRIN(KARTEZ),KARTEZ=1,NDKART)
C
      END IF
C
C=======================================================================
C         READING THE GAUSSIAN OVERLAP APPROXIMATION (GOA) SWITCH
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'GAUOVERAPP') THEN
C
          READ(NFIREA,*) IDOGOA
C
      END IF
C
C=======================================================================
C
C         READING THE MULTIPOLE CONSTRAINTS:
C
C         CONSTRAINTS FOR SEVERAL VALUES OF LAMBDA AND MIU CAN BE
C         PROVIDED ON CONSECUTIVE LINES  BY  READING-IN  NEGATIVE
C         FLIPPED-SIGN VALUES OF LAMBDA FOR ALL BUT THE LAST LINE
C
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RPA_CONSTR'.OR.
     *    trim(KEYWOR).EQ.'RPA-CONSTR') THEN
C
          READ(NFIREA,*) IF_RPA
C
      END IF
C
      IF (trim(KEYWOR).EQ.'MULTCONSTR') THEN
C
 1002     READ(NFIREA,*,END=2002) LAMBDA,MIU,STIFFQ(ABS(LAMBDA),MIU),
     *                                       QASKED(ABS(LAMBDA),MIU),
     *                                       IFLAGQ(ABS(LAMBDA),MIU)
C
          IF (ABS(LAMBDA).GT.NDMULT.OR.LAMBDA.EQ.0.OR.
     *                        IABS(MIU).GT.ABS(LAMBDA))
     *
     *        STOP ' STIFFQ INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.LT.0) GO TO 1002
C
      END IF
C
C=======================================================================
C
C         READING THE ISOVECTOR MULTIPOLE CONSTRAINTS:
C
C         CONSTRAINTS FOR SEVERAL VALUES OF LAMBDA AND MIU CAN BE
C         PROVIDED ON CONSECUTIVE LINES  BY  READING-IN  NEGATIVE
C         FLIPPED-SIGN VALUES OF LAMBDA FOR ALL BUT THE LAST LINE
C
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ISOVMULCON') THEN
C
 1005     READ(NFIREA,*,END=2005) LAMBDA,MIU,STIFFV(ABS(LAMBDA),MIU),
     *                                       VASKED(ABS(LAMBDA),MIU),
     *                                       IFLAGV(ABS(LAMBDA),MIU)
C
          IF (ABS(LAMBDA).GT.NDMULT.OR.LAMBDA.EQ.0.OR.
     *                        IABS(MIU).GT.ABS(LAMBDA))
     *
     *        STOP ' STIFFV INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.LT.0) GO TO 1005
C
      END IF
C
C=======================================================================
C         READING THE LINEAR MULTIPOLE CONSTRAINTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MULTLAGRAN') THEN
C
 1020     READ(NFIREA,*,END=2020) LAMBDA,MIU,QLINEA(ABS(LAMBDA),MIU),
     *                                       IFLALQ(ABS(LAMBDA),MIU)
C
          IF (ABS(LAMBDA).GT.NDMULT.OR.LAMBDA.EQ.0.OR.
     *                        IABS(MIU).GT.ABS(LAMBDA))
     *
     *        STOP ' QLINEA INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.LT.0) GO TO 1020
C
      END IF
C
C=======================================================================
C         READING THE LINEAR ISOVECTOR MULTIPOLE CONSTRAINTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ISMULAGRAN') THEN
C
 1025     READ(NFIREA,*,END=2025) LAMBDA,MIU,VLINEA(ABS(LAMBDA),MIU),
     *                                       IFLALV(ABS(LAMBDA),MIU)
C
          IF (ABS(LAMBDA).GT.NDMULT.OR.LAMBDA.EQ.0.OR.
     *                        IABS(MIU).GT.ABS(LAMBDA))
     *
     *        STOP ' VLINEA INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.LT.0) GO TO 1025
C
      END IF
C
C=======================================================================
C         READING THE SURFACE-MOMENT OR SCHIFF-MOMENT CONSTRAINTS:
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SURFCONSTR'.OR.
     *    trim(KEYWOR).EQ.'SCHICONSTR') THEN
C
 1003     READ(NFIREA,*,END=2003) LAMBDA,MIU,STIFFS(ABS(LAMBDA),MIU),
     *                                       SASKED(ABS(LAMBDA),MIU),
     *                                       IFLAGS(ABS(LAMBDA),MIU)
C
          IF (ABS(LAMBDA).GT.NDMULT.OR.IABS(MIU).GT.ABS(LAMBDA))
     *
     *        STOP ' STIFFS INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.LT.0) GO TO 1003
C
      END IF
C
C=======================================================================
C         READING THE LINEAR SURFACE-MOMENT OR SCHIFF-MOMENT CONSTRAINTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SURFLAGRAN'.OR.
     *    trim(KEYWOR).EQ.'SCHILAGRAN') THEN
C
 1030     READ(NFIREA,*,END=2030) LAMBDA,MIU,SLINEA(ABS(LAMBDA),MIU),
     *                                       IFLALS(ABS(LAMBDA),MIU)
C
          IF (ABS(LAMBDA).GT.NDMULT.OR.IABS(MIU).GT.ABS(LAMBDA))
     *
     *        STOP ' SLINEA INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.LT.0) GO TO 1030
C
      END IF
C
C=======================================================================
C         READING THE SCALAR MULTIPOLE-MOMENT CONSTRAINTS:
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'MULTCONSCA') THEN
C
 1004     READ(NFIREA,*,END=2004) LAMBDA,STIFFG(ABS(LAMBDA)),
     *                                   GASKED(ABS(LAMBDA)),
     *                                   IFLAGG(ABS(LAMBDA))
C
          IF (ABS(LAMBDA).GT.NDMULT.OR.LAMBDA.EQ.0)
     *
     *        STOP ' STIFFG INDICES OUT OF RANGE IN NAMELI'
C
          IF (LAMBDA.LT.0) GO TO 1004
C
      END IF
C
C=======================================================================
C         READING THE  ONE-DIMENSIONAL QUADRATIC SPIN CONSTRAINT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPINCONSTR') THEN
C
          ISPINY=1
C
          IF (ISPXYZ.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS SPINCONSTR & SPICON_XYZ ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' FOR THE Y COMPONENT (KARTEZ = 2) ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' SPINCONSTR & SPICON_XYZ SIMULTANEOUSLY IN NAMELI 1'
C
          END IF
C
          READ(NFIREA,*) STIFFJ,ASKEDJ,IFLAGI(2)
             IF (IFLAGI(2).NE.0) THEN
                 STIFFI(2)=STIFFJ
                 ASKEDI(2)=ASKEDJ
             END IF
C
      END IF
C
C=======================================================================
C         READING THE THREE-DIMENSIONAL QUADRATIC SPIN CONSTRAINT
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (1.91Z) AND (3.27L), THAT IS, ALSO
C                    IN ALL PUBLISHED VERSIONS AFTER (1.75R), THERE  WAS
C                    A POSSIBLE CONFLICT IN READING THE  SPIN-CONSTRAINT
C                    DATA FOR THE Y DIRECTION  (KARTEZ=2)  AS  THE  SAME
C                    DATA WERE READ UNDER  TWO  DIFFERENT  KEYWORDS.  IN
C                    ADDITION, UNDER BOTH KEYWORDS, THE VALUES WERE READ
C                    INDEPENDENTLY OF WHETHER THE CONSTRAINT WAS  ACTIVE
C                    OR NOT. THOSE  INCONSISTENCIES  WERE  CORRECTED  ON
C                    20/07/2024  IN  VERSION  (3.27M)  BY  REMOVING  THE
C                    POSSIBILITY TO USE KEYWORDS SPINCONSTR & SPICON_XYZ
C                    FOR KARTEZ=2 SIMULTANEOUSLY.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPICON_XYZ'.OR.
     *    trim(KEYWOR).EQ.'SPICON-XYZ') THEN
C
          DO KARTEZ=1,NDKART
             READ(NFIREA,*) STIFFJ,ASKEDJ,IFLAGI(KARTEZ)
             IF (IFLAGI(KARTEZ).NE.0) THEN
                 STIFFI(KARTEZ)=STIFFJ
                 ASKEDI(KARTEZ)=ASKEDJ
             END IF
          END DO
C
          IF (IFLAGI(2).NE.0) THEN
C
              ISPXYZ=1
C
              IF (ISPINY.EQ.1) THEN
C
                  WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' KEYWORDS SPINCONSTR & SPICON_XYZ ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' FOR THE Y COMPONENT (KARTEZ = 2) ''
     *                                                  ,2X,20(1H/),/,
     *                1X,20(1H/),'' CANNOT BE USED SIMULTANEOUSLY    ''
     *                                                  ,2X,20(1H/),/)')
              STOP ' SPINCONSTR & SPICON_XYZ SIMULTANEOUSLY IN NAMELI 2'
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C         READING THE THREE-DIMENSIONAL QUADRATIC ISOVECTOR SPIN
C         CONSTRAINT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'STICON_XYZ'.OR.
     *    trim(KEYWOR).EQ.'STICON-XYZ') THEN
C
          DO KARTEZ=1,NDKART
             READ(NFIREA,*) STIFTJ,ASKETJ,IFTAGI(KARTEZ)
             IF (IFTAGI(KARTEZ).NE.0) THEN
                 STIFTI(KARTEZ)=STIFTJ
                 ASKETI(KARTEZ)=ASKETJ
             END IF
          END DO
C
      END IF
C
C=======================================================================
C         READING THE QUADRATIC ISOSPIN CONSTRAINT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ISO_CONSTR'.OR.
     *    trim(KEYWOR).EQ.'ISO-CONSTR') THEN
C
          DO KARTEZ=1,NDKART
             READ(NFIREA,*) STIFFT(KARTEZ),ASKEDT(KARTEZ),IFLAGT(KARTEZ)
          END DO
C
      END IF
C
C=======================================================================
C         READING THE ONE-DIMENSIONAL AUGMENTED SPIN CONSTRAINT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPINLAGRAN') THEN
C
          READ(NFIREA,*) DALSPI(2),IFLALI(2)
C
      END IF
C
C=======================================================================
C         READING THE THREE-DIMENSIONAL AUGMENTED SPIN CONSTRAINT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPINLA_XYZ'.OR.
     *    trim(KEYWOR).EQ.'SPINLA-XYZ') THEN
C
          DO KARTEZ=1,NDKART
             READ(NFIREA,*) DALSPI(KARTEZ),IFLALI(KARTEZ)
          END DO
C
      END IF
C
C=======================================================================
C         READING THE AUGMENTED ISOSPIN CONSTRAINT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ISO_LAGRAN'.OR.
     *    trim(KEYWOR).EQ.'ISO-LAGRAN') THEN
C
          DO KARTEZ=1,NDKART
             READ(NFIREA,*) DALISO(KARTEZ),IFLALT(KARTEZ)
          END DO
C
      END IF
C
C=======================================================================
C         READING THE COMBINED ISOSPIN CONSTRAINT
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ISOSP_CNST'.OR.
     *    trim(KEYWOR).EQ.'ISOSP-CNST') THEN
C
          DO KARTEZ=1,NDKART
             READ(NFIREA,*) DALISO(KARTEZ),STIFFT(KARTEZ),
     *                      ASKEDT(KARTEZ),JFLAGT
             KFLAGT=0
C
             IF (JFLAGT.EQ.-1.OR.JFLAGT.EQ.0) THEN
                 IFLAGT(KARTEZ)=0
                 IFLALT(KARTEZ)=0
                 KFLAGT=1
             END IF
C
             IF (JFLAGT.EQ.1) THEN
                 IFLAGT(KARTEZ)=1
                 IFLALT(KARTEZ)=1
                 KFLAGT=1
             END IF
C
             IF (JFLAGT.EQ.2) THEN
                 IFLAGT(KARTEZ)=1
                 IFLALT(KARTEZ)=0
                 KFLAGT=1
             END IF
C
             IF (KFLAGT.EQ.0) STOP 'INCORRECT VALUE OF JFLAGT IN NAMELI'
C
          END DO
C
      END IF
C
C=======================================================================
C         READING THE QUADRATIC CONSTRAINT ON PRODUCT OMEGA TIMES SPIN
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'SPICON_OME'.OR.
     *    trim(KEYWOR).EQ.'SPICON-OME') THEN
C
          READ(NFIREA,*) STIFFA,ASKEDA,IFLAGA
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER WHICH CONTROLS THE ONE-LINE PRINTOUT OF
C         ITERATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ONE_LINE'.OR.
     *    trim(KEYWOR).EQ.'ONE-LINE') THEN
C
          READ(NFIREA,*) I1LINE
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS WHICH CONTROL THE PRINTING IN ITERATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINT_ITER'.OR.
     *    trim(KEYWOR).EQ.'PRINT-ITER') THEN
C
          READ(NFIREA,*) IPRSTA,IPRMID,IPRSTO
C
      END IF
C
C=======================================================================
C         READING THE PARAMETERS WHICH CONTROL THE PRINTING OF NEUTRON,
C         PROTON, AND TOTAL MOMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINT_MOME'.OR.
     *    trim(KEYWOR).EQ.'PRINT-MOME') THEN
C
          READ(NFIREA,*) IPRI_N,IPRI_P,IPRI_T
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER WHICH CONTROLS THE PRINTING OF MOMENTS
C         IN THE INTRINSIC FRAME
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINT_INTR'.OR.
     *    trim(KEYWOR).EQ.'PRINT-INTR') THEN
C
          READ(NFIREA,*) INTRIP
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER WHICH CONTROLS THE PRINTING OF
C         SYMMETRIES OF DENSITIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINT_SYME'.OR.
     *    trim(KEYWOR).EQ.'PRINT-SYME') THEN
C
          READ(NFIREA,*) ISYMDE
C
      END IF
C
C=======================================================================
C         READING THE PARAMATERS WHICH CONTROL THE PRINTING OF
C         ANGULAR-MOMENTUM-PROJECTION RESULTS
C=======================================================================
C         ISLPRI - DOUBLED ANGULAR MOMENTUM THAT LIMITS FROM BELOW THE
C                  RANGE OF CALCULATED RESULTS THAT WILL BE PRINTED
C         ISUPRI - DOUBLED ANGULAR MOMENTUM THAT LIMITS FROM ABOVE THE
C                  RANGE OF CALCULATED RESULTS THAT WILL BE PRINTED
C=======================================================================
C         IENPRI=0 NO AVERAGE ENERGIES OR  KERNELS ARE PRINTED
C         IENPRI=1    AVERAGE ENERGIES             ARE PRINTED
C         IENPRI=2    AVERAGE ENERGIES AND KERNELS ARE PRINTED
C=======================================================================
C         ISRPRI=0(1) SUM RULES ARE NOT PRINTED (ARE PRINTED & COMPARED
C                     WITH THE HF DATA)
C         IMIPRI=0(1) K-MIXED ENERGIES ARE NOT  PRINTED  (ARE  PRINTED)
C         IKEPRI=0(1) REDUCED KERNELS BETWEEN THE AMP  STATES  ARE  NOT
C                     PRINTED (ARE PRINTED)
C         IRMPRI=0(1) REDUCED MATRIX ELEMENTS BETWEEN THE K-MIXED STATES
C                     ARE NOT PRINTED (ARE PRINTED)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINT_AMP'.OR.
     *    trim(KEYWOR).EQ.'PRINT-AMP') THEN
C
          READ(NFIREA,*) ISLPRI,ISUPRI,IENPRI,ISRPRI,IMIPRI,
     *                   IKEPRI,IRMPRI
C
      END IF
C
C=======================================================================
C         READING THE SWITCHES THAT GOVERN THE RANGES OF PRINTED REDUCED
C         MOMENTS AND/OR KERNELS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINTMATEL') THEN
C
          READ(NFIREA,*) ILIMAM,IALLAM
C
      END IF
C
C=======================================================================
C         READING THE SWITCH THAT REQUESTS PRINTING ALL REDUCED
C         MOMENTS AND/OR KERNELS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINTALLRM') THEN
C
          READ(NFIREA,*) IPRALL
C
      END IF
C
C=======================================================================
C         READING THE SWITCH THAT ALLOWS FOR PRITING THE  TRUE  ELECTRIC
C         MOMENTS INSTEAD OF THE MULTIPOLE MOMENTS DEFINED IN THE  CODE.
C         THIS ALLOWS FOR USING THE  RESULTS  FOR  CALCULATIONS  OF  THE
C         REDUCED ELECTRIC TRANSITION PROBABILITIES BE(LAMBDA) DIRECTLY.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINT_ELEC'.OR.
     *    trim(KEYWOR).EQ.'PRINT-ELEC') THEN
C
          READ(NFIREA,*) IELPRI
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER WHICH CONTROLS THE PRINTING OF SYMMETRY
C         VIOLATING TERMS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'PRINT_VIOL'.OR.
     *    trim(KEYWOR).EQ.'PRINT-VIOL') THEN
C
          READ(NFIREA,*) IVIPRI
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER WHICH CONTROLS THE TYPE OF NILSSON
C         LABELS THAT WILL BE PRINTED FOR  SINGLE-PARTICLE  STATES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NILSSONLAB') THEN
C
          READ(NFIREA,*) NILXYZ
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER WHICH CONTROLS PRINTING OF NILSSON
C         LABELS FOR SINGLE-QUASIPARTICLE STATES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NILSSONQUA') THEN
C
          READ(NFIREA,*) IQUNIL
C
      END IF
C
C=======================================================================
C         READING THE ENERGY  RANGE FOR ONE COMMON BLOCK OF ALL
C                                      SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EALLMINMAX') THEN
C
          READ(NFIREA,*) EMINAL,EMAXAL
C
      END IF
C
C=======================================================================
C         READING THE MAXIMUM QUASIPARTICLE ENERGY FOR PRINTING THE LIST
C                                     OF SINGLE-QUASIPARTICLE PROPERTIES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EQUASI_MAX'.OR.
     *    trim(KEYWOR).EQ.'EQUASI-MAX') THEN
C
          READ(NFIREA,*) EMAXQU
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE CONTAINING THE REVIEW OF RESULTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REVIEWFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILREV)
C
      END IF
C
C=======================================================================
C         READING THE NUMBER OF NILSSON LABELS TO BE PRINTED ON THE
C         REVIEW FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ALLNILABS') THEN
C
          READ(NFIREA,*) INUNIL
C
      END IF
C
C=======================================================================
C         READING THE PARAMETER WHICH HANDLES THE REVIEW FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REVIEW') THEN
C
          READ(NFIREA,*) IREVIE
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE THE RECORD FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RECORDSAVE') THEN
C
          READ(NFIREA,*) IWRIRE
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE THE YUKAWA FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'YUKAWASAVE') THEN
C
          READ(NFIREA,*) IWRIYU
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE THE GOGNY FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'GOGNYSAVE') THEN
C
          READ(NFIREA,*) IWRIGO
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE THE REGUL FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REGULSAVE') THEN
C
          READ(NFIREA,*) IWRIRO
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE THE LIPKIN FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'LIPKINSAVE') THEN
C
          READ(NFIREA,*) IWRILI
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE THE FIELDS FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FIELD_SAVE'.OR.
     *    trim(KEYWOR).EQ.'FIELD-SAVE') THEN
C
          READ(NFIREA,*) IWRIFI
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE BASIS-DEFORMATION FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'BASIS_SAVE'.OR.
     *    trim(KEYWOR).EQ.'BASIS-SAVE') THEN
C
          READ(NFIREA,*) IWRIBA
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE THE QUASIPARTICLE-WAVEFUNCTION FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'QUASIPSAVE') THEN
C
          READ(NFIREA,*) IWRIQU
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         WRITE THE REDUCED-MATRIX-ELEMENTS FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REDMATSAVE') THEN
C
          READ(NFIREA,*) IWRIRM
C
      END IF
C
C=======================================================================
C         READING THE FLAG THAT DECIDES WHETHER OR NOT THE CODE WILL
C         STORE OLD FIELDS ON THE RECORD FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'FIELD_OLD'.OR.
     *    trim(KEYWOR).EQ.'FIELD-OLD') THEN
C
          READ(NFIREA,*) IWRIOL
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RECORDING INTERMEDIATE RESULTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RECORDFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILREC)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RESTARTING THE ITERATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REPLAYFILE'.OR.
     *    trim(KEYWOR).EQ.'INPUT_FILE'.OR.
     *    trim(KEYWOR).EQ.'INPUT-FILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILREP)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RECORDING THE YUKAWA MEAN FIELDS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RECYUKFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILYUC)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR READING THE YUKAWA MEAN FIELDS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REPYUKFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILYUP)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RECORDING THE GOGNY MEAN FIELDS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RECGOGFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILGOC)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR READING THE GOGNY MEAN FIELDS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REPGOGFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILGOP)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RECORDING THE GOGNY PAIRING FIELD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RECGPAFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILGPC)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR READING THE GOGNY PAIRING FIELD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REPGPAFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILGPP)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RECORDING THE REGUL MEAN FIELDS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RECREGFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILROC)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR READING THE REGUL MEAN FIELDS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REPREGFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILROP)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RECORDING THE DENSITY MATRICES
C         NEEDED FOR THE LIPKIN-NOGAMI CALCULATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RECLIPFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILLIC)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR READING THE DENSITY MATRICES
C         NEEDED FOR THE LIPKIN-NOGAMI CALCULATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REPLIPFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILLIP)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RECORDING THE BASIS DEFORMATIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RECBASFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILBAC)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR  READING  THE BASIS DEFORMATIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REPBASFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILBAP)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR RECORDING THE MEAN-FIELDS  ON
C         THE HARMONIC-OSCILLATOR BASIS, WHICH ARE NEEDED TO RESTART
C         THE CALCULATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REC_FIELDS'.OR.
     *    trim(KEYWOR).EQ.'REC-FIELDS') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILFIC)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE FOR  READING  THE MEAN-FIELDS  ON
C         THE HARMONIC-OSCILLATOR BASIS, WHICH ARE NEEDED TO RESTART
C         THE CALCULATION
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REP_FIELDS'.OR.
     *    trim(KEYWOR).EQ.'REP-FIELDS') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILFIP)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE CONTAINING THE WOODS-SAXON RESULTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'WOODSAFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILWOO)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE CONTAINING THE COULOMB MATRICES
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'COULOMFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILCOU)
C
      END IF
C
C=======================================================================
C
C         READING THE PARAMETERS WHICH HANDLE THE COULOMB FILE
C         ACCORDING TO THE FOLLOWING TABLE OF ACTIONS:
C         ------ ------  -----------------------------------------------
C         ICOULI ICOULO                       ACTIONS
C         ------ ------  -----------------------------------------------
C           0      0     NEITHER READ  NOR WRITE        THE COULOMB FILE
C           1      0             READ  AND DO NOT WRITE THE COULOMB FILE
C           0      1      DO NOT READ  AND WRITE        THE COULOMB FILE
C           1      1     GIVES AN AUTOMATED MODE AS DESCRIBED IN PRECOU:
C                        |>      READ  COULOMB FILE,  PROVIDED IT EXISTS
C                        |>                    AND CONTAINS CORRECT DATA
C                        |>  AND WRITE COULOMB FILE IF IT DOES NOT EXIST
C                        |>           OR THE DATA HAVE BEEN RECALCULATED
C
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'COULOMSAVE') THEN
C
          READ(NFIREA,*) ICOULI,ICOULO
C
      END IF
C
C=======================================================================
C         READING THE NAME OF THE ISOSPIN FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ISOSPIFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILISO)
C
      END IF
C
      IF (trim(KEYWOR).EQ.'WRITE_ISO'.OR.
     *    trim(KEYWOR).EQ.'WRITE-ISO') THEN
C
          READ(NFIREA,*) IWRISO
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE CONTAINING THE WAVE FUNCTIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'WAVEF_FILE'.OR.
     *    trim(KEYWOR).EQ.'WAVEF-FILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILWAV)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE CONTAINING THE GCM KERNELS VERSION
C         FOR NAMKER=1 (DEFAULT)
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'KERNELFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILKER)
C
      END IF
C
C=======================================================================
C         READING THE NAMES OF FILES CONTAINING THE SINGLE-REFERENCE
C         CONFIGURATION DATA AND GCM KERNELS.
C         FOR NAMKER=2, ON SEPARATE LINES THE CODE READS THE LIST OF
C         FILE NAMES PRECEDED BY SWITCHES +1 OR -1 TO INCLUDE OR NOT
C         INCLUDE, RESPECTIVELY, THE GIVEN FILE NAME INTO THE  LIST.
C         THE LIST MUST BE ENDED WITH THE SWITCH  0  FOLLOWED  BY  A
C         DUMMY FILE NAME.
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONFIGFILE') THEN
C
          READ(NFIREA,*) NAMKER
C
          NUCONF=0
C
          IF (NAMKER.NE.1) THEN
C
 2046         READ(NFIREA,*,ERR=2049,END=2049) ISCONF,FILDUM
C
              IF (ISCONF.EQ.-1) GO TO 2046
              IF (ISCONF.EQ.+1) THEN
C
                  NUCONF=NUCONF+1
                  IF (NUCONF.GT.NDCONF) STOP 'INCREASE NDCONF IN NAMELI'
                  CALL NOTABS(FILDUM,FILLEF(NUCONF))
C
                  GO TO 2046
C
              END IF
          END IF
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE CONTAINING THE QUASIPARTICLE WAVE
C         FUNCTIONS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'QUASIPFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILQUA)
C
      END IF
C
C=======================================================================
C         READING THE NAME OF FILE CONTAINING THE REDUCED MATRIX
C         ELEMENTS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'REDMATFILE') THEN
C
          READ(NFIREA,'(A80)') FILDUM
C
          CALL NOTABS(FILDUM,FILRED)
C
      END IF
C
C=======================================================================
C         READING THE RESTART PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'RESTART') THEN
C
          READ(NFIREA,*) ICONTI
C
      END IF
C
C=======================================================================
C         READING THE HFB PAIRING CONTINUATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONT_PAIRI'.OR.
     *    trim(KEYWOR).EQ.'CONT-PAIRI') THEN
C
          READ(NFIREA,*) IPCONT
C
      END IF
C
C=======================================================================
C         READING THE ADJUSTABLE-ANGULAR-FREQUENCY CONTINUATION
C         PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONT_OMEGA'.OR.
     *    trim(KEYWOR).EQ.'CONT-OMEGA') THEN
C
          READ(NFIREA,*) IOCONT
C
      END IF
C
C=======================================================================
C         READING THE YUKAWA-MEAN-FIELDS CONTINUATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTYUKAWA') THEN
C
          READ(NFIREA,*) IYCONT
C
      END IF
C
C=======================================================================
C         READING THE GOGNY-MEAN-FIELDS CONTINUATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTGOGNY') THEN
C
          READ(NFIREA,*) IGCONT
C
      END IF
C
      IF (trim(KEYWOR).EQ.'CONTGOGPAI') THEN
C
          READ(NFIREA,*) IGPCON
C
      END IF
C
C=======================================================================
C         READING THE REGULARIZED-MEAN-FIELDS CONTINUATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTREGUL') THEN
C
          READ(NFIREA,*) IECONT
C
      END IF
C
C=======================================================================
C         READING THE LIPKIN-NOGAMI CONTINUATION PARAMETER
C=======================================================================
C         FOR ILCONT=0, THE LIPKIN-NOGAMI  CALCULATIONS  ARE  RESTARTED,
C                       THAT IS, THE DENSITY MATRICES USED  IN  THE  L-N
C                       MEAN FIELDS ARE SET  TO  ZERO  AND  THE  LAMBDA2
C                       PARAMETERS ARE SET TO THE INITIAL VALUES.
C         FOR ILCONT=1, THE LIPKIN-NOGAMI  CALCULATIONS  ARE   CONTINUED
C                       USING THE DATA READ FROM THE LIPKIN FILE. USE OF
C                       THE LIPKIN FILE IS OBSOLETE.
C         FOR ILCONT=2, THE LIPKIN-NOGAMI  CALCULATIONS  ARE   CONTINUED
C                       USING THE MEAN FIELDS READ FROM THE FIELDS  FILE
C                       AND LAMBDA2 PARAMETERS READ FROM THE RECORD FILE
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTLIPKIN') THEN
C
          READ(NFIREA,*) ILCONT
C
      END IF
C
C=======================================================================
C         READING THE CM CORRECTION CONTINUATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTCMCORR') THEN
C
          READ(NFIREA,*) IMCONT
C
      END IF
C
C=======================================================================
C         READING THE ROTATIONAL CORRECTION CONTINUATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTROTCOR') THEN
C
          READ(NFIREA,*) IRCONT
C
      END IF
C
C=======================================================================
C         READING THE LINEAR-CONSTRAINT CONTINUATION PARAMETER FOR
C         THE AUGMENTED LAGRANGE METHOD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTAUGMEN') THEN
C
          READ(NFIREA,*) IACONT
C
      END IF
C
C=======================================================================
C         READING THE LINEAR-CONSTRAINT CONTINUATION PARAMETER FOR
C         THE SPIN AUGMENTED LAGRANGE METHOD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTAUGSPI') THEN
C
          READ(NFIREA,*) ISCONT
C
      END IF
C
C=======================================================================
C         READING THE LINEAR-CONSTRAINT CONTINUATION PARAMETER FOR
C         THE ISOSPIN AUGMENTED LAGRANGE METHOD
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTAUGISO') THEN
C
          READ(NFIREA,*) ITCONT
C
      END IF
C
C=======================================================================
C         READING THE FIELDS CONTINUATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONTFIELDS') THEN
C
          READ(NFIREA,*) IFCONT
C
      END IF
C
C=======================================================================
C         READING THE BASIS CONTINUATION PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'CONT_BASIS'.OR.
     *    trim(KEYWOR).EQ.'CONT-BASIS') THEN
C
          READ(NFIREA,*) IBCONT
C
      END IF
C
C=======================================================================
C         READING THE WOODS-SAXON-FILE PARAMETER
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'READ_WOODS'.OR.
     *    trim(KEYWOR).EQ.'READ-WOODS') THEN
C
          READ(NFIREA,*) IREAWS
C
      END IF
C
C=======================================================================
C         READING THE NILSSON MODEL PARAMETERS
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'NILSSONPAR') THEN
C
          READ(NFIREA,*) NILDAT,CNILSN,DNILSN,CNILSP,DNILSP,
     *                                 HBANIX,HBANIY,HBANIZ
C
      END IF
C
C=======================================================================
C         READING THE COLLECTIVE MASS PARAMETERS DATA
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'COLCOOR') THEN
C
        icolmult=0
        do
                        read (nfirea,*) laba, mi
                        lambda=abs(laba)
                if ((lambda.lt.2).or.(lambda.gt.nccmult)) then
                        print *, "bad lambda",laba,mi
                        stop
                end if
C
                if ((mi.lt.0).or.(mi.gt.lambda)) then
                        print *, "bad mi",laba,mi
                        stop
                end if
C
                icolmult(lambda,mi)=1
                if (laba.gt.0) exit
        end do
C
        ms=0
        nk=1
        do lambda=2,4
                do mi=0,4
                if (icolmult(lambda,mi).eq.1) then
                ms=icolmult(lambda,mi)+ms
                icolcoor(nk,1)=lambda
                icolcoor(nk,2)=mi
                nk=nk+1
                end if
                enddo
        enddo
        numcoor=ms
        end if
C
      IF (trim(KEYWOR).EQ.'MASMOMIN') THEN
                read(nfirea,*) imaspar, imominer
      end if
C
C=======================================================================
C         READY TO RUN ?
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'EXECUTE') THEN
C
          NO_RUN=NO_RUN+1
C
          RETURN
C
      END IF
C
C=======================================================================
C         ALL DONE ?
C=======================================================================
C
      IF (trim(KEYWOR).EQ.'ALL_DONE'.OR.
     *    trim(KEYWOR).EQ.'ALL-DONE') THEN
C
          GO TO 2
C
      END IF
C
C=======================================================================
C        SCANNING CONTINUES ...
C=======================================================================
C
      GO TO  1
C
C=======================================================================
C        EOF IN THE INPUT DATA STREAM
C=======================================================================
C
    2 IF (NO_RUN.EQ.0) THEN
C
         STOP ' NO "EXECUTE" FOUND IN THE INPUT DATA STREAM (IN NAMELI)'
C
      END IF
C
      CALL CPUTIM('HFODD ',0)
C
      CALL TIMPRI
C
C=======================================================================
C         PRINTING THE DATE AND TIME
C=======================================================================
C
      CALL DATE_AND_TIME(MYDATE,MYTIME,MYZONE,MYVALU)
C
      WRITE(NFIPRI,'(                         1H*,77X,1H*,/,1H*,2X,
     *      ''EXECUTION ENDS ON '',A4,''.'',A2,''.'',A2,'' AT '',
     *                               A2,'':'',A2,'':'',A6,
     *                              31X,1H*,/,1H*,77X,1H*,/,79(1H*))')
     *
     *      MYDATE(1:4),MYDATE(5:6),MYDATE(7:8),
     *      MYTIME(1:2),MYTIME(3:4),MYTIME(5:10)
C
C=======================================================================
C
#if(USE_MPI==1)
      RETURN
#else
      STOP ' ALL DONE'
#endif
C
C=======================================================================
C
 2001 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD SURFAC_DEF'
C
 2002 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD MULTCONSTR'
C
 2005 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD ISOVMULCON'
C
 2020 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD MULTLAGRAN'
C
 2025 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD ISMULAGRAN'
C
 2003 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD SURFCONSTR'
C
 2030 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD SURFLAGRAN'
C
 2004 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD MULTCONSCA'
C
 2049 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD CONFIGFILE'
c
 2050 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD FRAGCONSTR'
C
 2051 STOP ' UNEXPECTED END OF INPUT DATA AFTER KEYWORD FRAGMULDEF'
C
C=======================================================================
C
      END
C
C=======================================================================
C
      SUBROUTINE RHODEP(IRHODE,PRHO_X,PRHODX,PRHOSX,POWERX)
C
C=======================================================================
C         FOR IRHODE=1  THIS SUBROUTINE CALCULATES THE VALUE OF THE
C                       SATURATION DENSITY "PRHOSX"  THAT  REPLACES
C                       STRENGTH "PRHODX" OF THE  DENSITY-DEPENDENT
C                       TERM IN THE PAIRING INTERACTION.
C         FOR IRHODE<>1 THIS SUBROUTINE CALCULATES THE VALUE OF THE
C                       STRENGTH "PRHODX" OF THE  DENSITY-DEPENDENT
C                       TERM THAT REPLACES THE  SATURATION  DENSITY
C                       "PRHOSX" IN THE PAIRING INTERACTION.
C=======================================================================
C
      IF (IRHODE.EQ.1) THEN
C
          IF (POWERX.NE.0) THEN
C
              IF (PRHODX.NE.0) THEN
C
C=======================================================================
C         AS A SECURITY MEASURE, BELOW THE ABSOLUTE VALUE IS USED
C         INSTEAD OF "-PRHO_X/PRHODX". THEREFORE, THE FORMULA  IS
C         CORRECT ONLY FOR VALUES OF PRHO_X AND PRHODX THAT  HAVE
C         OPPOSITE SIGNS.
C=======================================================================
C
                  PRHOSX=ABS(PRHO_X/PRHODX)**(1.0D0/POWERX)
C
              ELSE
C
C=======================================================================
C         AS A SECURITY MEASURE, BELOW PRHOSX IS SET TO 1 IN CASE IT
C         CANNOT BE CALCULATED BECAUSE OF VANISHING PRHODX.
C=======================================================================
C
                  PRHOSX=1.0D0
C
              END IF
C
          ELSE
C
C=======================================================================
C         AS A SECURITY MEASURE, BELOW PRHOSX IS SET TO 1 IN CASE IT
C         CANNOT BE CALCULATED BECAUSE OF VANISHING POWERX.
C=======================================================================
C
              PRHOSX=1.0D0
C
          END IF
C
      ELSE
C
          IF (POWERX.NE.0) THEN
C
              IF (PRHOSX.NE.0) THEN
C
                  PRHODX=-PRHO_X/PRHOSX**POWERX
C
              ELSE
C
C=======================================================================
C         AS A SECURITY MEASURE, BELOW PRHODX IS SET TO  LARGE  NUMBER
C         IN CASE IT CANNOT BE CALCULATED BECAUSE OF VANISHING PRHOSX.
C=======================================================================
C
                  PRHODX=-PRHO_X/1.0D-30
C
              END IF
C
          ELSE
C
C=======================================================================
C         AS A SECURITY MEASURE, BELOW PRHODX IS SET TO "-PRHO_X" IN
C         CASE IT CANNOT BE CALCULATED BECAUSE OF  VANISHING  POWERX.
C=======================================================================
C
              PRHODX=-PRHO_X
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SIGREV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /SIGKPH/ KPPPSP(NDPAHO,0:NDISOS),KPPPSM(NDPAHO,0:NDISOS),
     *                KPPMSP(NDPAHO,0:NDISOS),KPPMSM(NDPAHO,0:NDISOS),
     *                KHPPSP(NDPAHO,0:NDISOS),KHPPSM(NDPAHO,0:NDISOS),
     *                KHPMSP(NDPAHO,0:NDISOS),KHPMSM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIMKPH/ KPSIMP(NDPAHO,0:NDISOS),KPSIMM(NDPAHO,0:NDISOS),
     *                KHSIMP(NDPAHO,0:NDISOS),KHSIMM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIQKPH/ KPSIQP(NDPAHO,0:NDISOS),KPSIQM(NDPAHO,0:NDISOS),
     *                KHSIQP(NDPAHO,0:NDISOS),KHSIQM(NDPAHO,0:NDISOS)
      COMMON
     *       /SIZKPH/ KPNONE(NDPAHO,0:NDISOS),
     *                KHNONE(NDPAHO,0:NDISOS)
      COMMON
     *       /MIGKPH/ LPPPSP(NDPAHO),LPPPSM(NDPAHO),
     *                LPPMSP(NDPAHO),LPPMSM(NDPAHO),
     *                LHPPSP(NDPAHO),LHPPSM(NDPAHO),
     *                LHPMSP(NDPAHO),LHPMSM(NDPAHO)
      COMMON
     *       /MIMKPH/ LPSIMP(NDPAHO),LPSIMM(NDPAHO),
     *                LHSIMP(NDPAHO),LHSIMM(NDPAHO)
      COMMON
     *       /MIQKPH/ LPSIQP(NDPAHO),LPSIQM(NDPAHO),
     *                LHSIQP(NDPAHO),LHSIQM(NDPAHO)
      COMMON
     *       /MIZKPH/ LPNONE(NDPAHO),
     *                LHNONE(NDPAHO)
      COMMON
     *       /SIGKVA/ KVASIG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /SIMKVA/ KVASIM(         0:NDSIMP,0:NDISOS)
      COMMON
     *       /SIQKVA/ KVASIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /MIGKVA/ KVAMIG(0:NDPARI,0:NDSIGN)
      COMMON
     *       /MIMKVA/ KVAMIM(0:NDSIMP)
      COMMON
     *       /MIQKVA/ KVAMIQ(0:NDPARI)
      COMMON
     *       /K_FLIG/ KPFLIG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KHFLIG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KOFLIG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /K_FLIM/ KPFLIM(         0:NDSIMP,0:NDISOS),
     *                KHFLIM(         0:NDSIMP,0:NDISOS),
     *                KOFLIM(         0:NDSIMP,0:NDISOS)
      COMMON
     *       /K_FLIQ/ KPFLIQ(0:NDPARI,         0:NDISOS),
     *                KHFLIQ(0:NDPARI,         0:NDISOS),
     *                KOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /K_FLIZ/ KPFLIZ(                  0:NDISOS),
     *                KHFLIZ(                  0:NDISOS),
     *                KOFLIZ(                  0:NDISOS)
      COMMON
     *       /K_MLIG/ KPMLIG(0:NDPARI,0:NDSIGN),
     *                KHMLIG(0:NDPARI,0:NDSIGN),
     *                KOMLIG(0:NDPARI,0:NDSIGN)
      COMMON
     *       /K_MLIM/ KPMLIM(0:NDSIMP),
     *                KHMLIM(0:NDSIMP),
     *                KOMLIM(0:NDSIMP)
      COMMON
     *       /K_MLIQ/ KPMLIQ(0:NDPARI),
     *                KHMLIQ(0:NDPARI),
     *                KOMLIQ(0:NDPARI)
      COMMON
     *       /K_MLIZ/ KPMLIZ,
     *                KHMLIZ,
     *                KOMLIZ
      COMMON
     *       /K_FILG/ KPFILG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KHFILG(0:NDPARI,0:NDSIGN,0:NDISOS),
     *                KOFILG(0:NDPARI,0:NDSIGN,0:NDISOS)
      COMMON
     *       /K_FILZ/ KPFILZ(                  0:NDISOS),
     *                KHFILZ(                  0:NDISOS),
     *                KOFILZ(                  0:NDISOS)
C
      COMMON
     *       /SIGNPH/ NP_SIG(NDPAHO,0:NDPARI,0:NDREVE,0:NDISOS),
     *                NH_SIG(NDPAHO,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMNPH/ NP_SIM(NDPAHO,0:NDSIMP,0:NDISOS),
     *                NH_SIM(NDPAHO,0:NDSIMP,0:NDISOS)
      COMMON
     *       /SIQNPH/ NP_SIQ(NDPAHO,0:NDPARI,0:NDISOS),
     *                NH_SIQ(NDPAHO,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIZNPH/ NP_SIZ(NDPAHO,0:NDISOS),
     *                NH_SIZ(NDPAHO,0:NDISOS)
      COMMON
     *       /MIGNPH/ NP_MIG(NDPAHO,0:NDPARI,0:NDREVE),
     *                NH_MIG(NDPAHO,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIMNPH/ NP_MIM(NDPAHO,0:NDSIMP),
     *                NH_MIM(NDPAHO,0:NDSIMP)
      COMMON
     *       /MIQNPH/ NP_MIQ(NDPAHO,0:NDPARI),
     *                NH_MIQ(NDPAHO,0:NDPARI)
      COMMON
     *       /MIZNPH/ NP_MIZ(NDPAHO),
     *                NH_MIZ(NDPAHO)
      COMMON
     *       /SIGNVA/ NVASIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMNVA/ NVASIM(         0:NDREVE,0:NDISOS)
      COMMON
     *       /SIQNVA/ NVASIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /MIGNVA/ NVAMIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /MIMNVA/ NVAMIM(0:NDREVE)
      COMMON
     *       /MIQNVA/ NVAMIQ(0:NDPARI)
      COMMON
     *       /N_FLIG/ NPFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFLIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIM/ NPFLIM(         0:NDREVE,0:NDISOS),
     *                NHFLIM(         0:NDREVE,0:NDISOS),
     *                NOFLIM(         0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIQ/ NPFLIQ(0:NDPARI,         0:NDISOS),
     *                NHFLIQ(0:NDPARI,         0:NDISOS),
     *                NOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /N_FLIZ/ NPFLIZ(                  0:NDISOS),
     *                NHFLIZ(                  0:NDISOS),
     *                NOFLIZ(                  0:NDISOS)
      COMMON
     *       /N_MLIG/ NPMLIG(0:NDPARI,0:NDREVE),
     *                NHMLIG(0:NDPARI,0:NDREVE),
     *                NOMLIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MLIM/ NPMLIM(0:NDREVE),
     *                NHMLIM(0:NDREVE),
     *                NOMLIM(0:NDREVE)
      COMMON
     *       /N_MLIQ/ NPMLIQ(0:NDPARI),
     *                NHMLIQ(0:NDPARI),
     *                NOMLIQ(0:NDPARI)
      COMMON
     *       /N_MLIZ/ NPMLIZ,
     *                NHMLIZ,
     *                NOMLIZ
      COMMON
     *       /N_FILG/ NPFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFILG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FILZ/ NPFILZ(                  0:NDISOS),
     *                NHFILZ(                  0:NDISOS),
     *                NOFILZ(                  0:NDISOS)
C
C=======================================================================
C
C         FOR CONSERVED PARITY/SIGNATURE:
C         THIS SUBROUTINE PERFORMS ALL NECESSARY OPERATIONS
C         TO CHANGE THE PARITY/SIGNATURE NOTATION INTO  THE
C         PARITY/TIME-REVERSAL NOTATION.
C
C         FOR CONSERVED SIMPLEX, CONSERVED PARITY, OR NO SYMMETRY:
C         THIS SUBROUTINE COPIES THE INPUT DATA INTO ANOTHER
C         ARRAYS. THIS IS DONE ONLY TO  KEEP  A  CONSISTENCY
C         WITH THE CASE OF PARITY/SIGNATURE SYMMETRY.
C
C=======================================================================
C         FOR CONSERVED PARITY/SIGNATURE:
C         THE PROGRAM WORKS BY USING TWO BLOCKS DENOTED  BY  IREVER.
C         THE BLOCK FOR IREVER=1 IS OBTAINED BY THE TIME-REVERSAL OF
C         THE BLOCK FOR IREVER=0.
C=======================================================================
C
C         THE BLOCK IREVER=0 CORRESPONDS TO: TIME-FORWARD  AND
C                                            Y-SIMPLEX=+i
C         THE BLOCK IREVER=1 CORRESPONDS TO: TIME-BACKWARD AND
C                                            Y-SIMPLEX=-i
C
C         THE SIMPLEX IS DEFINED ACCORDING TO THE COPENHAGEN CONVENTION
C                         SY=EXP(-i*PI*JY)*PARITY
C         THE |T+> STATES OF THE T-BASIS HAVE THEN SY=+i
C         THE |T-> STATES OF THE T-BASIS HAVE THEN SY=-i
C
C         CONFIGURATIONS ARE DEFINED IN TERMS OF    PARITY
C                                            AND    SIGNATURE RY
C         SIMPLEX IS EQUAL TO THE PRODUCT SY=RY*PARITY AND THEREFORE:
C
C                                       *********************
C         THE BLOCK IREVER=0 CONTAINS   * (RY=+i,PARITY=+1) * AND
C                                       * (RY=-i,PARITY=-1) *
C                                       *********************
C         THE BLOCK IREVER=1 CONTAINS   * (RY=-i,PARITY=+1) * AND
C                                       * (RY=+i,PARITY=-1) *
C                                       *********************
C
C=======================================================================
C         HERE WE TRANSFORM THE PARITY-SIGNATURE NOTATION INTO
C         THE IREVER CONVENTION. THIS IS REALIZED BY EXCHANGING
C         THE VALUES FOR TWO SIGNATURES IN THE NEGATIVE PARITY.
C=======================================================================
C         ARRAYS KVASIG, K_P_S_, AND K_FLIG CONCERN PARITY-SIGNATURE
C         ARRAYS NVASIG, N_P_R_, AND N_FLIG CONCERN PARITY-IREVER
C=======================================================================
C         VACUUM CONFIGURATION:
C=======================================================================
C
      NVASIG(0,0,0)=KVASIG(0,0,0)
      NVASIG(0,1,0)=KVASIG(0,1,0)
      NVASIG(1,0,0)=KVASIG(1,1,0)
      NVASIG(1,1,0)=KVASIG(1,0,0)
C
      NVASIG(0,0,1)=KVASIG(0,0,1)
      NVASIG(0,1,1)=KVASIG(0,1,1)
      NVASIG(1,0,1)=KVASIG(1,1,1)
      NVASIG(1,1,1)=KVASIG(1,0,1)
C
      NVAMIG(0,0)=KVAMIG(0,0)
      NVAMIG(0,1)=KVAMIG(0,1)
      NVAMIG(1,0)=KVAMIG(1,1)
      NVAMIG(1,1)=KVAMIG(1,0)
C
C=======================================================================
C         PARTICLE-HOLE CONFIGURATIONS:
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
         DO ICHARG=0,NDISOS
C
            NP_SIG(NUPAHO,0,0,ICHARG) = KPPPSP(NUPAHO,ICHARG)
            NP_SIG(NUPAHO,0,1,ICHARG) = KPPPSM(NUPAHO,ICHARG)
            NP_SIG(NUPAHO,1,0,ICHARG) = KPPMSM(NUPAHO,ICHARG)
            NP_SIG(NUPAHO,1,1,ICHARG) = KPPMSP(NUPAHO,ICHARG)
C
            NH_SIG(NUPAHO,0,0,ICHARG) = KHPPSP(NUPAHO,ICHARG)
            NH_SIG(NUPAHO,0,1,ICHARG) = KHPPSM(NUPAHO,ICHARG)
            NH_SIG(NUPAHO,1,0,ICHARG) = KHPMSM(NUPAHO,ICHARG)
            NH_SIG(NUPAHO,1,1,ICHARG) = KHPMSP(NUPAHO,ICHARG)
C
         END DO
      END DO
C
      DO NUPAHO=1,NDPAHO
C
         NP_MIG(NUPAHO,0,0) = LPPPSP(NUPAHO)
         NP_MIG(NUPAHO,0,1) = LPPPSM(NUPAHO)
         NP_MIG(NUPAHO,1,0) = LPPMSM(NUPAHO)
         NP_MIG(NUPAHO,1,1) = LPPMSP(NUPAHO)
C
         NH_MIG(NUPAHO,0,0) = LHPPSP(NUPAHO)
         NH_MIG(NUPAHO,0,1) = LHPPSM(NUPAHO)
         NH_MIG(NUPAHO,1,0) = LHPMSM(NUPAHO)
         NH_MIG(NUPAHO,1,1) = LHPMSP(NUPAHO)
C
      END DO
C
C=======================================================================
C         DIABATIC BLOCKING CONFIGURATIONS:
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO ISIGNA=0,NDSIGN
            DO ICHARG=0,NDISOS
C
               IREVER=ISIGNA*(1-IPARIT)+(1-ISIGNA)*IPARIT
C
               NPFLIG(IPARIT,IREVER,ICHARG)=KPFLIG(IPARIT,ISIGNA,ICHARG)
               NHFLIG(IPARIT,IREVER,ICHARG)=KHFLIG(IPARIT,ISIGNA,ICHARG)
               NOFLIG(IPARIT,IREVER,ICHARG)=KOFLIG(IPARIT,ISIGNA,ICHARG)
C
            END DO
         END DO
      END DO
C
      DO IPARIT=0,NDPARI
         DO ISIGNA=0,NDSIGN
C
            IREVER=ISIGNA*(1-IPARIT)+(1-ISIGNA)*IPARIT
C
            NPMLIG(IPARIT,IREVER)=KPMLIG(IPARIT,ISIGNA)
            NHMLIG(IPARIT,IREVER)=KHMLIG(IPARIT,ISIGNA)
            NOMLIG(IPARIT,IREVER)=KOMLIG(IPARIT,ISIGNA)
C
         END DO
      END DO
C
C=======================================================================
C         FILLING CONFIGURATIONS:
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO ISIGNA=0,NDSIGN
            DO ICHARG=0,NDISOS
C
               IREVER=ISIGNA*(1-IPARIT)+(1-ISIGNA)*IPARIT
C
               NPFILG(IPARIT,IREVER,ICHARG)=KPFILG(IPARIT,ISIGNA,ICHARG)
               NHFILG(IPARIT,IREVER,ICHARG)=KHFILG(IPARIT,ISIGNA,ICHARG)
               NOFILG(IPARIT,IREVER,ICHARG)=KOFILG(IPARIT,ISIGNA,ICHARG)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         HERE WE COPY THE ARRAYS CONCERNING THE SIMPLEX NOTATION
C         INTO THE ARRAYS CONCERNING THE  IREVER  CONVENTION.
C         THIS IS DONE ONLY TO KEEP THE CONSISTENCY WITH THE
C         PARITY/SIGNATURE CASE.
C=======================================================================
C         ARRAYS KVASIM, K_SIM_, AND K_FLIM CONCERN SIMPLEX
C         ARRAYS NVASIM, N_SIM_, AND N_FLIM CONCERN TIME-REVERSAL
C=======================================================================
C         VACUUM CONFIGURATION:
C=======================================================================
C
      NVASIM(0,0)=KVASIM(0,0)
      NVASIM(1,0)=KVASIM(1,0)
C
      NVASIM(0,1)=KVASIM(0,1)
      NVASIM(1,1)=KVASIM(1,1)
C
      NVAMIM(0)=KVAMIM(0)
      NVAMIM(1)=KVAMIM(1)
C
C=======================================================================
C         PARTICLE-HOLE CONFIGURATIONS:
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
         DO ICHARG=0,NDISOS
C
            NP_SIM(NUPAHO,0,ICHARG) = KPSIMP(NUPAHO,ICHARG)
            NP_SIM(NUPAHO,1,ICHARG) = KPSIMM(NUPAHO,ICHARG)
C
            NH_SIM(NUPAHO,0,ICHARG) = KHSIMP(NUPAHO,ICHARG)
            NH_SIM(NUPAHO,1,ICHARG) = KHSIMM(NUPAHO,ICHARG)
C
         END DO
      END DO
C
      DO NUPAHO=1,NDPAHO
C
         NP_MIM(NUPAHO,0) = LPSIMP(NUPAHO)
         NP_MIM(NUPAHO,1) = LPSIMM(NUPAHO)
C
         NH_MIM(NUPAHO,0) = LHSIMP(NUPAHO)
         NH_MIM(NUPAHO,1) = LHSIMM(NUPAHO)
C
      END DO
C
C=======================================================================
C         DIABATIC BLOCKING CONFIGURATIONS:
C=======================================================================
C
      DO ISIMPL=0,NDSIMP
         DO ICHARG=0,NDISOS
C
            IREVER=ISIMPL
C
            NPFLIM(IREVER,ICHARG)=KPFLIM(ISIMPL,ICHARG)
            NHFLIM(IREVER,ICHARG)=KHFLIM(ISIMPL,ICHARG)
            NOFLIM(IREVER,ICHARG)=KOFLIM(ISIMPL,ICHARG)
C
         END DO
      END DO
C
      DO ISIMPL=0,NDSIMP
C
         IREVER=ISIMPL
C
         NPMLIM(IREVER)=KPMLIM(ISIMPL)
         NHMLIM(IREVER)=KHMLIM(ISIMPL)
         NOMLIM(IREVER)=KOMLIM(ISIMPL)
C
      END DO
C
C=======================================================================
C         HERE WE COPY THE ARRAYS CONCERNING THE CASE  OF  NON-CONSERVED
C         SIMPLEX AND CONSERVED PARITY. THIS IS DONE ONLY  TO  KEEP  THE
C         CONSISTENCY WITH THE PARITY/SIGNATURE CASE.
C=======================================================================
C=======================================================================
C         VACUUM CONFIGURATION:
C=======================================================================
C
      NVASIQ(0,0)=KVASIQ(0,0)
      NVASIQ(1,0)=KVASIQ(1,0)
C
      NVASIQ(0,1)=KVASIQ(0,1)
      NVASIQ(1,1)=KVASIQ(1,1)
C
      NVAMIQ(0)=KVAMIQ(0)
      NVAMIQ(1)=KVAMIQ(1)
C
C=======================================================================
C         PARTICLE-HOLE CONFIGURATIONS:
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
         DO ICHARG=0,NDISOS
C
            NP_SIQ(NUPAHO,0,ICHARG) = KPSIQP(NUPAHO,ICHARG)
            NP_SIQ(NUPAHO,1,ICHARG) = KPSIQM(NUPAHO,ICHARG)
C
            NH_SIQ(NUPAHO,0,ICHARG) = KHSIQP(NUPAHO,ICHARG)
            NH_SIQ(NUPAHO,1,ICHARG) = KHSIQM(NUPAHO,ICHARG)
C
         END DO
      END DO
C
      DO NUPAHO=1,NDPAHO
C
         NP_MIQ(NUPAHO,0) = LPSIQP(NUPAHO)
         NP_MIQ(NUPAHO,1) = LPSIQM(NUPAHO)
C
         NH_MIQ(NUPAHO,0) = LHSIQP(NUPAHO)
         NH_MIQ(NUPAHO,1) = LHSIQM(NUPAHO)
C
      END DO
C
C=======================================================================
C         DIABATIC BLOCKING CONFIGURATIONS:
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO ICHARG=0,NDISOS
C
            NPFLIQ(IPARIT,ICHARG)=KPFLIQ(IPARIT,ICHARG)
            NHFLIQ(IPARIT,ICHARG)=KHFLIQ(IPARIT,ICHARG)
            NOFLIQ(IPARIT,ICHARG)=KOFLIQ(IPARIT,ICHARG)
C
         END DO
      END DO
C
      DO IPARIT=0,NDPARI
C
         NPMLIQ(IPARIT)=KPMLIQ(IPARIT)
         NHMLIQ(IPARIT)=KHMLIQ(IPARIT)
         NOMLIQ(IPARIT)=KOMLIQ(IPARIT)
C
      END DO
C
C=======================================================================
C         HERE WE COPY THE ARRAYS CONCERNING THE CASE OF NO SYMMETRY.
C         THIS IS DONE ONLY TO KEEP THE CONSISTENCY WITH THE
C         PARITY/SIGNATURE CASE.
C=======================================================================
C=======================================================================
C         PARTICLE-HOLE CONFIGURATIONS:
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
         DO ICHARG=0,NDISOS
C
            NP_SIZ(NUPAHO,ICHARG) = KPNONE(NUPAHO,ICHARG)
            NH_SIZ(NUPAHO,ICHARG) = KHNONE(NUPAHO,ICHARG)
C
         END DO
      END DO
C
      DO NUPAHO=1,NDPAHO
C
         NP_MIZ(NUPAHO) = LPNONE(NUPAHO)
         NH_MIZ(NUPAHO) = LHNONE(NUPAHO)
C
      END DO
C
C=======================================================================
C         DIABATIC BLOCKING CONFIGURATIONS:
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         NPFLIZ(ICHARG)=KPFLIZ(ICHARG)
         NHFLIZ(ICHARG)=KHFLIZ(ICHARG)
         NOFLIZ(ICHARG)=KOFLIZ(ICHARG)
C
      END DO
C
      NPMLIZ=KPMLIZ
      NHMLIZ=KHMLIZ
      NOMLIZ=KOMLIZ
C
C=======================================================================
C         FILLING CONFIGURATIONS:
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         NPFILZ(ICHARG)=KPFILZ(ICHARG)
         NHFILZ(ICHARG)=KHFILZ(ICHARG)
         NOFILZ(ICHARG)=KOFILZ(ICHARG)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECORD(NFIREP,NFIREC,INPFLD,NUMITE,
     *                  IVEREP,NXHERM,NYHERM,NZHERM,
     *                                IPCONT,ILCONT,
     *                         ISCONT,ITCONT,IACONT,
     *                                IMCONT,IRCONT,
     *                                IRENMA,IRENIN,
     *                                LIPKIN,LIPKIP,
     *                                REFERN,REFERP,
     *                                REDELN,REDELP,
     *                                REFE2N,REFE2P,
     *                                IDSIGN,IDSIGP,
     *                                IDSIMN,IDSIMP,
     *                                IDSIQN,IDSIQP,
     *                                IDSIZN,IDSIZP,
     *                                       INIBLN,
     *                                       INIBLP,
     *                                NMUMAX,NSIMAX,
     *                                IPNMIX,ISHIFT,
     *                                JETA_T,JETAPA,IERROR,
     *                                       LDTWCE,LDTWDD,
     *                                              IFRCNT)
C=======================================================================
      USE HE_DEN
      USE VE_FLD
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      integer :: currentVersion, minimalVersion
C
      COMPLEX
     *          WAVBLO,C_ZERO
C
      DIMENSION
     *          IDSIZN(1:NDBLOC),IDSIZP(1:NDBLOC)
      DIMENSION
     *          IDSIQN(1:NDBLOC),IDSIQP(1:NDBLOC)
      DIMENSION
     *          RLMFRA(0:NDISOS,1:NDTWCE),
     *          RALMTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
C
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /ANGSPI/ SPIN_N(1:NDKART),SPIN_P(1:NDKART),SPIN_T(1:NDKART)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /LINMOM/ DLINSN(0:NDKART),DLINSP(0:NDKART),DLINST(0:NDKART)
     *               ,ELINSN(0:NDKART),ELINSP(0:NDKART),ELINST(0:NDKART)
     *               ,TLINSN(0:NDKART),TLINSP(0:NDKART),TLINST(0:NDKART)
     *               ,ALINLN(0:NDKART),ALINLP(0:NDKART),ALINLT(0:NDKART)
      COMMON
     *       /ROTMOM/ DROTSN(0:NDKART),DROTSP(0:NDKART),DROTST(0:NDKART)
     *               ,EROTSN(0:NDKART),EROTSP(0:NDKART),EROTST(0:NDKART)
     *               ,TROTSN(0:NDKART),TROTSP(0:NDKART),TROTST(0:NDKART)
     *               ,AROTLN(0:NDKART),AROTLP(0:NDKART),AROTLT(0:NDKART)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /RLASTR/ RALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                RALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                RALMUV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /JLASTR/ RALSPI(1:NDKART)
      COMMON
     *       /ULASTR/ RALISO(1:NDKART)
      COMMON
     *       /PAIINI/ FERINI(0:NDISOS),DELINI(0:NDISOS),FE2INI(0:NDISOS)
      COMMON
     *       /SHIFTR/ RSHIFT(1:NDKART)
      COMMON
     *       /BLOWAV/ WAVBLO(1:2*NDBASE,0:NDISOS,0:NDREVE,1:NDBLOC)
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /RENORM/ HBMREN(NDKART)
      COMMON
     *       /RENROT/ ROTREN(NDKART)
      COMMON
     *       /REAORM/ HBMREA(NDKART)
      COMMON
     *       /REAROT/ ROTREA(NDKART)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
     *       /NCKFLA/ IFNECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
      COMMON
     *       /FRCONS/ FRGSTF(0:NDISOS,1:NDTWCE),
     *                FRGASK(0:NDISOS,1:NDTWCE),
     *                IFLFRG(0:NDISOS,1:NDTWCE),
     *                CLMFRA(0:NDISOS,1:NDTWCE),
     *                AVEFRA(0:NDISOS,1:NDTWCE)
      COMMON
     *       /QTWCNS/ STQTWC(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QTWCAS(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                IFLQTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                GALMTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
C=======================================================================
      ALLOCATABLE DPRRHO(:,:,:,:)
      ALLOCATABLE DNRRHO(:,:,:,:)
      ALLOCATABLE VNRMAS(:,:,:,:)
      ALLOCATABLE VNRCEN(:,:,:,:)
      ALLOCATABLE VPRMAS(:,:,:,:)
      ALLOCATABLE VPRCEN(:,:,:,:)
      ALLOCATABLE VNRKIS(:,:,:,:,:)
      ALLOCATABLE VNRSPI(:,:,:,:,:)
      ALLOCATABLE VNRCUR(:,:,:,:,:)
      ALLOCATABLE VPRKIS(:,:,:,:,:)
      ALLOCATABLE VPRSPI(:,:,:,:,:)
      ALLOCATABLE VPRCUR(:,:,:,:,:)
      ALLOCATABLE VNRSOR(:,:,:,:,:,:)
      ALLOCATABLE VPRSOR(:,:,:,:,:,:)
C=======================================================================
C
      CALL CPUTIM('RECORD',1)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      currentVersion = 25
      minimalVersion =  4
C
      IF (.NOT.ALLOCATED(DPRRHO)) THEN
          ALLOCATE (DPRRHO(NDXHRM,NDYHRM,NDZHRM,LDTWDD),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DPRRHO','RECORD')
      END IF
      IF (.NOT.ALLOCATED(DNRRHO)) THEN
          ALLOCATE (DNRRHO(NDXHRM,NDYHRM,NDZHRM,LDTWDD),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DNRRHO','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VNRMAS)) THEN
          ALLOCATE (VNRMAS(NDXHRM,NDYHRM,NDZHRM,LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VNRMAS','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VNRCEN)) THEN
          ALLOCATE (VNRCEN(NDXHRM,NDYHRM,NDZHRM,LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VNRCEN','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VPRMAS)) THEN
          ALLOCATE (VPRMAS(NDXHRM,NDYHRM,NDZHRM,LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VPRMAS','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VPRCEN)) THEN
          ALLOCATE (VPRCEN(NDXHRM,NDYHRM,NDZHRM,LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VPRCEN','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VNRKIS)) THEN
          ALLOCATE (VNRKIS(NDXHRM,NDYHRM,NDZHRM,NDKART,
     *                                              LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VNRKIS','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VNRSPI)) THEN
          ALLOCATE (VNRSPI(NDXHRM,NDYHRM,NDZHRM,NDKART,
     *                                              LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VNRSPI','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VNRCUR)) THEN
          ALLOCATE (VNRCUR(NDXHRM,NDYHRM,NDZHRM,NDKART,
     *                                              LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VNRCUR','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VPRKIS)) THEN
          ALLOCATE (VPRKIS(NDXHRM,NDYHRM,NDZHRM,NDKART,
     *                                              LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VPRKIS','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VPRSPI)) THEN
          ALLOCATE (VPRSPI(NDXHRM,NDYHRM,NDZHRM,NDKART,
     *                                              LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VPRSPI','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VPRCUR)) THEN
          ALLOCATE (VPRCUR(NDXHRM,NDYHRM,NDZHRM,NDKART,
     *                                              LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VPRCUR','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VNRSOR)) THEN
          ALLOCATE (VNRSOR(NDXHRM,NDYHRM,NDZHRM,NDKART, NDKART,
     *                                              LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VNRSOR','RECORD')
      END IF
      IF (.NOT.ALLOCATED(VPRSOR)) THEN
          ALLOCATE (VPRSOR(NDXHRM,NDYHRM,NDZHRM,NDKART,NDKART,
     *                                              LDTWCE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('VPRSOR','RECORD')
      END IF
C=======================================================================
C
       DPRRHO=0.0D0
       DNRRHO=0.0D0
       VNRMAS=0.0D0
       VNRCEN=0.0D0
       VPRMAS=0.0D0
       VPRCEN=0.0D0
       VNRKIS=0.0D0
       VNRSPI=0.0D0
       VNRCUR=0.0D0
       VPRKIS=0.0D0
       VPRSPI=0.0D0
       VPRCUR=0.0D0
       VNRSOR=0.0D0
       VPRSOR=0.0D0
C
C
C=======================================================================
C     INPFLD - IF .NE.0 => THE FILE WITH THE UNIT NUMBER  NFIREP WILL BE
C                          USED TO  R E A D  THE RESULTS OF THE PREVIOUS
C                          CALCULATION            (FROM THE UNIT NFIREP)
C=======================================================================
C
      IF (INPFLD.NE.0) THEN
C
          REWIND(UNIT=NFIREP,IOSTAT=IERROR)
          IF (IERROR.NE.0) THEN
              WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *              ''REWINDING FILE '',i4)') NFIREP
              CALL CPUTIM('RECORD',0)
              RETURN
          END IF
C
          IFIRED=0
C
          READ (NFIREP,IOSTAT=IERROR) IVERIN
          IF (IERROR.NE.0) THEN
              WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *              ''READING IVERIN'')')
              CALL CPUTIM('RECORD',0)
              RETURN
          END IF
C
          IVEREP=IVERIN
C
          IF (IVERIN.GE.minimalVersion.AND.
     *        IVERIN.LE.currentVersion) THEN
C
              READ (NFIREP,IOSTAT=IERROR) NUMITE
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING NUMITE'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              READ (NFIREP,IOSTAT=IERROR) MXHERM,MYHERM,MZHERM
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING MXHERM'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              IF (MXHERM.NE.NXHERM.OR.
     *            MYHERM.NE.NYHERM.OR.
     *            MZHERM.NE.NZHERM) THEN
C
                  WRITE(NFIPRI,'(/,1X,19(1H/),
     *                          ''  WRONG NXHERM,NYHERM,NZHERM:'',
     *                3I3,2X,19(1H/),/)') MXHERM,MYHERM,MZHERM
C
                  STOP '  WRONG NXHERM,NYHERM,NZHERM IN RECORD'
C
              END IF
C
              MDTWCE=1
C
              IF (IVERIN.GE.23) READ (NFIREP,IOSTAT=IERROR) MDTWCE
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING MDTWCE'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              IF (MDTWCE.GT.LDTWCE) THEN
C
                  WRITE(NFIPRI,'(/,1X,19(1H/),
     *                          ''  WRONG LDTWCE:              '',
     *                3I3,2X,19(1H/),/)') MDTWCE
C
                  STOP '  WRONG LDTWCE IN RECORD'
C
                  WRITE(NFIPRI,'(/,1X,10(1H/),
     *                      ''  INCOMPATIBLE NUMBERS OF CENTRES     '',
     *                         5X,10(1H/),/,
     *                         1X,10(1H/),
     *                      ''  CANNOT READ THE REPLAY FILE VERSION:'',
     *                      I3,2X,10(1H/),/)') IVERIN
C
          STOP ' NOS. OF CENTRES: CANNOT READ THE REPLAY FILE IN RECORD'
C
              END IF
C
              MDTWDD=1
C
              IF (IVERIN.GE.24) READ (NFIREP,IOSTAT=IERROR) MDTWDD
C
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING MDTWDD'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              IF (MDTWDD.GT.LDTWDD.AND.LDTWDD.EQ.1) THEN
C
                  WRITE(NFIPRI,'(/,1X,19(1H/),
     *                          ''  WRONG LDTWDD:              '',
     *                3I3,2X,19(1H/),/)') MDTWDD
C
                  STOP '  WRONG LDTWDD IN RECORD'
C
                  WRITE(NFIPRI,'(/,1X,10(1H/),
     *                      ''  INCOMPATIBLE NUMBERS OF CENTRES     '',
     *                         5X,10(1H/),/,
     *                         1X,10(1H/),
     *                      ''  CANNOT READ THE REPLAY FILE VERSION:'',
     *                      I3,2X,10(1H/),/)') IVERIN
C
          STOP ' NOS. OF CENTRES: CANNOT READ THE REPLAY FILE IN RECORD'
C
              END IF
C
C=======================================================================
C     TWO-CENTER OPTION: IF THE CODE RESTARTS FROM A HFB CALCULATION AND
C     A HF CALCULATION IS REQUESTED TWO ADDITIONAL DENSITIES ARE FOUND
C     IN THE REC. FILE. HOWEVER THOSE TWO CANNOT BE PROPERLY STORED AS
C     LDTWDD=22. TO AVOID PROBLEMS WE SET MDTWDD=22.
C=======================================================================
C
              IF (MDTWDD.EQ.24.AND.LDTWDD.EQ.22) MDTWDD=22
C
              IF (IVERIN.LE.13) THEN
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                           ((((VNRMAS(IX,IY,IZ,LTWCEN),
     *                               VNRCEN(IX,IY,IZ,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VNRMAS'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                          (((((VNRKIS(IX,IY,IZ,L,LTWCEN),
     *                               VNRSPI(IX,IY,IZ,L,LTWCEN),
     *                               VNRCUR(IX,IY,IZ,L,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                             L=1,NDKART),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VNRKIS'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                         ((((((VNRSOR(IX,IY,IZ,L,K,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                L=1,NDKART), K=1,NDKART),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VNRSOR'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                           ((((VPRMAS(IX,IY,IZ,LTWCEN),
     *                               VPRCEN(IX,IY,IZ,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VPRMAS'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                          (((((VPRKIS(IX,IY,IZ,L,LTWCEN),
     *                               VPRSPI(IX,IY,IZ,L,LTWCEN),
     *                               VPRCUR(IX,IY,IZ,L,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                             L=1,NDKART),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VPRKIS'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                         ((((((VPRSOR(IX,IY,IZ,L,K,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                L=1,NDKART), K=1,NDKART),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VPRSOR'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  VE_MAS(:,:,:,0,:)=VNRMAS(:,:,:,:)
                  VE_CEN(:,:,:,0,:)=VNRCEN(:,:,:,:)
                  VE_MAS(:,:,:,1,:)=VPRMAS(:,:,:,:)
                  VE_CEN(:,:,:,1,:)=VPRCEN(:,:,:,:)
C
                  VE_KIS(:,:,:,:,0,:)=VNRKIS(:,:,:,:,:)
                  VE_SPI(:,:,:,:,0,:)=VNRSPI(:,:,:,:,:)
                  VE_CUR(:,:,:,:,0,:)=VNRCUR(:,:,:,:,:)
                  VE_KIS(:,:,:,:,1,:)=VPRKIS(:,:,:,:,:)
                  VE_SPI(:,:,:,:,1,:)=VPRSPI(:,:,:,:,:)
                  VE_CUR(:,:,:,:,1,:)=VPRCUR(:,:,:,:,:)
C
                  VE_SOR(:,:,:,:,:,0,:)=VNRSOR(:,:,:,:,:,:)
                  VE_SOR(:,:,:,:,:,1,:)=VPRSOR(:,:,:,:,:,:)
C
              ELSE
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                           ((((VE_MAS(IX,IY,IZ,0,LTWCEN),
     *                               VE_CEN(IX,IY,IZ,0,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VE_MAS'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                          (((((VE_KIS(IX,IY,IZ,L,0,LTWCEN),
     *                               VE_SPI(IX,IY,IZ,L,0,LTWCEN),
     *                               VE_CUR(IX,IY,IZ,L,0,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                             L=1,NDKART),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VE_KIS'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                         ((((((VE_SOR(IX,IY,IZ,L,K,0,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                L=1,NDKART), K=1,NDKART),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VE_SOR'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                           ((((VE_MAS(IX,IY,IZ,1,LTWCEN),
     *                               VE_CEN(IX,IY,IZ,1,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VE_MAS'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                          (((((VE_KIS(IX,IY,IZ,L,1,LTWCEN),
     *                               VE_SPI(IX,IY,IZ,L,1,LTWCEN),
     *                               VE_CUR(IX,IY,IZ,L,1,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                             L=1,NDKART),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VE_KIS'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                         ((((((VE_SOR(IX,IY,IZ,L,K,1,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                L=1,NDKART), K=1,NDKART),
     *                                        LTWCEN=1,MDTWCE)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING VE_SOR'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
              END IF
C
              IF (IVERIN.LE.6) THEN
C
                  IF (IVERIN.GT.5) THEN
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                        ((((DNRRHO(IX,IY,IZ,LTWCEN),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM),
     *                                            LTWCEN=1,MDTWDD)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING DNRRHO'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                  ELSE
C
                      DO IX=1,NXHERM
                         DO IY=1,NYHERM
                            DO IZ=1,NZHERM
C
                               DNRRHO(IX,IY,IZ,:)=0.0D0
C
                            END DO
                         END DO
                      END DO
C
                      IF (IPCONT.EQ.1)
     *
     *                    WRITE(NFIPRI,'(/,
     *                        1X,13(1H/),'' WARNING:  THE  NEUTRON '',
     *                                   '' DENSITY HAS NOT BEEN'',
     *                                                   1X,13(1H/),/,
     *                        1X,13(1H/),'' FOUND ON THE OLD REPLAY'',
     *                                   '' FILE VERSION NO. ='',I2,
     *                                                   1X,13(1H/),/,
     *                        1X,13(1H/),'' THE HFB PAIRING CANNOT'',
     *                                   '' BE SMOOTHLY CONTINUED'',
     *                                                   1X,13(1H/),/)')
     *
     *                        IVERIN
C
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                     ((((DPRRHO(IX,IY,IZ,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,MDTWDD)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING DPRRHO'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  DO IX=1,NXHERM
                     DO IY=1,NYHERM
                        DO IZ=1,NZHERM
                           DO LTWCEN=1,MDTWDD
C
                           DE_RHO(IX,IY,IZ,0,LTWCEN)=
     *                     DNRRHO(IX,IY,IZ,  LTWCEN)
                           DE_RHO(IX,IY,IZ,1,LTWCEN)=
     *                     DPRRHO(IX,IY,IZ,  LTWCEN)
C
                           END DO
                        END DO
                     END DO
                  END DO
C
              ELSE
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                    ((((DE_RHO(IX,IY,IZ,0,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,MDTWDD)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING DN_RHO'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                    ((((DE_RHO(IX,IY,IZ,1,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,MDTWDD)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING DP_RHO'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
              END IF
C
              READ (NFIREP,IOSTAT=IERROR) MMUMAX
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING NMUMAX'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              IF (MMUMAX.LT.NMUMAX) THEN
C
                  WRITE(NFIPRI,'(
     *                 1X,20(1H/),''  WARNING:  TOO FEW MULTIPOLE'',
     *                            '' MOMENTS'',         1X,20(1H/),/
     *                 1X,20(1H/),''  FOUND ON THE REPLAY FILE. '',
     *                            ''         '',         1X,20(1H/),/
     *                 1X,20(1H/),''  REQUESTED MAXIMUM '',
     *                            '' MULTIPOLARITY='',I2,1X,20(1H/),/
     *                 1X,20(1H/),''  FOUND     MAXIMUM '',
     *                            '' MULTIPOLARITY='',I2,1X,20(1H/),/
     *                 1X,20(1H/),''  A CONSTRAINT ON A MISSING '',
     *                            ''MULTIPOLE'',         1X,20(1H/),/
     *                 1X,20(1H/),''  WILL BE  INCLUDED  ONLY  A'',
     *                            ''FTER  THE'',         1X,20(1H/),/
     *                 1X,20(1H/),''  FIRST DIAGONALIZATION IS '',
     *                            '' PERFORMED'',        1X,20(1H/),/)')
     *
     *            NMUMAX,MMUMAX
C
                  DO LAMBDA=MMUMAX+1,NMUMAX
                     DO MIU=-LAMBDA,LAMBDA
C
                        QMUL_N(LAMBDA,MIU)=0.0D0
                        QMUL_P(LAMBDA,MIU)=0.0D0
                        QMUL_T(LAMBDA,MIU)=0.0D0
C
                     END DO
                  END DO
C
              END IF
C
              READ (NFIREP,IOSTAT=IERROR) ((QMUL_N(LAMBDA,MIU),
     *                                      QMUL_P(LAMBDA,MIU),
     *                                      QMUL_T(LAMBDA,MIU),
     *
     *                        MIU=-LAMBDA,LAMBDA),LAMBDA=0,MMUMAX)
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING QMUL_N'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              DO LAMBDA=0,NSIMAX
                 DO MIU=-LAMBDA,LAMBDA
C
                    SMUL_N(LAMBDA,MIU)=0.0D0
                    SMUL_P(LAMBDA,MIU)=0.0D0
                    SMUL_T(LAMBDA,MIU)=0.0D0
C
                 END DO
              END DO
C
              IF (IVERIN.LE.4) GO TO 4
C
              READ (NFIREP,IOSTAT=IERROR) MSIMAX
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING MSIMAX'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              IF (MSIMAX.LT.NSIMAX) THEN
C
                  WRITE(NFIPRI,'(
     *                 1X,20(1H/),''  WARNING:  TOO FEW SURFACE  '',
     *                            '' MOMENTS'',         1X,20(1H/),/
     *                 1X,20(1H/),''  FOUND ON THE REPLAY FILE. '',
     *                            ''         '',         1X,20(1H/),/
     *                 1X,20(1H/),''  REQUESTED MAXIMUM '',
     *                            '' MULTIPOLARITY='',I2,1X,20(1H/),/
     *                 1X,20(1H/),''  FOUND     MAXIMUM '',
     *                            '' MULTIPOLARITY='',I2,1X,20(1H/),/
     *                 1X,20(1H/),''  A CONSTRAINT ON A MISSING '',
     *                            ''MULTIPOLE'',         1X,20(1H/),/
     *                 1X,20(1H/),''  WILL BE  INCLUDED  ONLY  A'',
     *                            ''FTER  THE'',         1X,20(1H/),/
     *                 1X,20(1H/),''  FIRST DIAGONALIZATION IS '',
     *                            '' PERFORMED'',        1X,20(1H/),/)')
     *
     *            NSIMAX,MSIMAX
C
                  DO LAMBDA=MSIMAX+1,NSIMAX
                     DO MIU=-LAMBDA,LAMBDA
C
                        SMUL_N(LAMBDA,MIU)=0.0D0
                        SMUL_P(LAMBDA,MIU)=0.0D0
                        SMUL_T(LAMBDA,MIU)=0.0D0
C
                     END DO
                  END DO
C
              END IF
C
C=======================================================================
C             ATTENTION!
C             THE CODE DOES NOT CHECK WHETHER THE SURFACE OR  SCHIFF
C             MOMENTS HAVE BEEN PREVIOUSLY STORED ON THE RECORD FILE
C             (DEPENDING ON THE PREVIOUS VALUE OF "ISCHIF")
C=======================================================================
C
              READ (NFIREP,IOSTAT=IERROR) ((SMUL_N(LAMBDA,MIU),
     *                                      SMUL_P(LAMBDA,MIU),
     *                                      SMUL_T(LAMBDA,MIU),
     *
     *                        MIU=-LAMBDA,LAMBDA),LAMBDA=0,MSIMAX)
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING SMUL_N'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
    4         CONTINUE
C
              READ (NFIREP,IOSTAT=IERROR) ISHIFT,
     *                                   (RSHIFT(L),L=1,NDKART)
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING ISHIFT'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              READ (NFIREP,IOSTAT=IERROR)
     *                      (ANGU_N(L),ANGU_P(L),ANGU_T(L),
     *                       SPIN_N(L),SPIN_P(L),SPIN_T(L),L=1,NDKART)
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING ANGU_N'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              READ (NFIREP,IOSTAT=IERROR)
     *                 ((((WD_CEN(IX,IY,IZ,0,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                    LTWCEN=1,MDTWCE)
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING WD_CEN(0)'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              READ (NFIREP,IOSTAT=IERROR)
     *                 ((((WD_CEN(IX,IY,IZ,1,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                    LTWCEN=1,MDTWCE)
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING WD_CEN(1)'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
              READ (NFIREP,IOSTAT=IERROR)
     *
     *              REFERN,REDELN,
     *              REFERP,REDELP
C
              IF (IERROR.NE.0) THEN
                  WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                  ''READING REFERN'')')
                  CALL CPUTIM('RECORD',0)
                  RETURN
              END IF
C
C              LN lambda_2 (IVERIN=8)
C
              IF (IVERIN.GT.7) THEN
C
                  READ (NFIREP,IOSTAT=IERROR) REFE2N,REFE2P
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING REFE2N'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
              ELSE
C
                  REFE2N=FE2INI(0)
                  REFE2P=FE2INI(1)
C
                  IF ((LIPKIN.EQ.1.OR.LIPKIP.EQ.1).AND.ILCONT.GE.1)
     *
     *                WRITE(NFIPRI,'(/,
     *                    1X,13(1H/),'' WARNING: THE LIPKIN-NOGAMI'',
     *                               '' LAMBDA2S HAVE NOT BEEN'',
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' FOUND ON THE  OLD  REPLAY '',
     *                               '' FILE  VERSION  NO. ='',I2,
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' THE  LN  CORRECTIONS CANNOT'',
     *                               '' BE SMOOTHLY CONTINUED'',
     *                                               1X,13(1H/),/)')
     *
     *                IVERIN
C
              END IF
C
C              Blocked state wave-function (IVERIN=9)
C
              IF (IVERIN.GT.8) THEN
C
                  READ (NFIREP,IOSTAT=IERROR)
     *
     *                 MDBASE,(IDEBLO(ICHARG),ICHARG=0,NDISOS)
C
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING MDBASE'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  IF (IVERIN.GE.21) THEN
C
                      DO ICHARG=0,NDISOS
C
                         IF (IDEBLO(ICHARG).GE.1) THEN
C
                             IF (MDBASE.LE.NDBASE) THEN
C
                                 READ (NFIREP,IOSTAT=IERROR)
     *
     *                           (((WAVBLO(IBASE,ICHARG,IREVER,NUBLOC),
     *                                                IBASE= 1,MDBASE),
     *                                                IREVER=0,NDREVE),
     *                                         NUBLOC=1,IDEBLO(ICHARG))
C
                                 IF (IERROR.NE.0) THEN
                                     WRITE(NFIPRI,'(''RECORD - ERROR'',
     *                                     '' IN READING WAVBLO 3'')')
                                     CALL CPUTIM('RECORD',0)
                                     RETURN
                                 END IF
C
                             ELSE
C
                                 READ (NFIREP,IOSTAT=IERROR)
                                 IF (IERROR.NE.0) THEN
                                     WRITE(NFIPRI,'(''RECORD - ERROR'',
     *                                     '' IN READING WAVBLO 4'')')
                                     CALL CPUTIM('RECORD',0)
                                     RETURN
                                 END IF
C
                             END IF
C
                         END IF
C
                      END DO
C
                  END IF
C
                  IF (IVERIN.LT.21) THEN
C
                      IF (MDBASE.LE.NDBASE) THEN
C
                          READ (NFIREP,IOSTAT=IERROR)
     *
     *                    (((WAVBLO(IBASE,ICHARG,IREVER,1),
     *                                    IBASE= 1,MDBASE),
     *                                    ICHARG=0,NDISOS),
     *                                    IREVER=0,NDREVE)
C
                          IF (IERROR.NE.0) THEN
                              WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                              ''READING WAVBLO 1'')')
                              CALL CPUTIM('RECORD',0)
                              RETURN
                          END IF
C
                      ELSE
C
                          READ (NFIREP,IOSTAT=IERROR)
                          IF (IERROR.NE.0) THEN
                              WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                              ''READING WAVBLO 2'')')
                              CALL CPUTIM('RECORD',0)
                              RETURN
                          END IF
C
                      END IF
C
                  END IF
C
                  IF ((((IABS(IDSIGN).EQ.1.OR.IABS(IDSIMN).EQ.1.OR.
     *                   MAXVAL(IABS(IDSIQN)).GE.1.OR.
     *                   MAXVAL(IABS(IDSIZN)).GE.1)
     *                   .AND.INIBLN.EQ.0).OR.
     *                 ((IABS(IDSIGP).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *                   MAXVAL(IABS(IDSIQP)).GE.1.OR.
     *                   MAXVAL(IABS(IDSIZP)).GE.1)
     *                   .AND.INIBLP.EQ.0)).AND.
     *                  (MDBASE.NE.LDBTOT.OR.MDBASE.GT.NDBASE)) THEN
C
                      WRITE(NFIPRI,'(/,1X,10(1H/),
     *                    '' INCOMPATIBLE DIMENSIONS FOUND'',
     *                    '' ON THE RECORD FILE:'',      1X,10(1H/),/,
     *                     1X,10(1H/),'' LDBASE='',I4,'' MDBASE='',I4,
     *                                '' NDBASE='',I4,
     *                                                   1X,10(1H/),/)')
     *                     LDBTOT,MDBASE,NDBASE
C
                      STOP 'MDBASE<>LDBASE OR MDBASE>NDBASE IN RECORD'
C
                  END IF
C
              END IF
C
C              Average value <P> (IVERIN=10)
C
              IF (IVERIN.GE.10) THEN
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                 (ALINLT(KARTEZ),KARTEZ=0,NDKART)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING ALINLT'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
              ELSE
C
                  DO KARTEZ=0,NDKART
C
                     ALINLT(KARTEZ)=0.0D0
C
                  END DO
C
                  IF (IMCONT.EQ.1)
     *
     *                WRITE(NFIPRI,'(/,
     *                    1X,13(1H/),'' WARNING: THE AVERAGE LINEAR'',
     *                               '' MOMENTA HAVE NOT BEEN'',
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' FOUND ON THE  OLD  REPLAY '',
     *                               '' FILE  VERSION  NO. ='',I2,
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' THE EXACT CM CORREC. CANNOT'',
     *                               '' BE SMOOTHLY CONTINUED'',
     *                                               1X,13(1H/),/)')
     *
     *                IVERIN
C
              END IF
C
              IF (IVERIN.GE.11) THEN
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                 (AROTLT(KARTEZ),KARTEZ=0,NDKART)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING AROTLT'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
              ELSE
C
                  DO KARTEZ=0,NDKART
C
                     AROTLT(KARTEZ)=0.0D0
C
                  END DO
C
                  IF (IRCONT.EQ.1)
     *
     *                WRITE(NFIPRI,'(/,
     *                    1X,13(1H/),'' WARNING: THE AVERAGE ANGULAR'',
     *                               '' MOMENTA HAVE NOT BEEN'',
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' FOUND ON  THE  OLD  REPLAY '',
     *                               '' FILE  VERSION  NO. ='',I2,
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' THE EXACT ROT CORREC. CANNOT'',
     *                               '' BE SMOOTHLY CONTINUED'',
     *                                               1X,13(1H/),/)')
     *
     *                IVERIN
C
              END IF
C
C              Linear Constraints for ALM (IVERIN=12)
C
              IF (IVERIN.GE.12) THEN
C
                  READ (NFIREP,IOSTAT=IERROR) MDMULT
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING MDMULT'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  IF (MDMULT.NE.NDMULT) THEN
C
                      WRITE(NFIPRI,'(
     *                 1X,20(1H/),''  WARNING: NOT ALL LINEAR'',
     *                            '' CONSTRAINTS'',      1X,20(1H/),/
     *                 1X,20(1H/),''  FOUND ON THE REPLAY FILE. '',
     *                            ''         '',         1X,20(1H/),/
     *                 1X,20(1H/),''  REQUESTED MAXIMUM '',
     *                            '' MULTIPOLARITY='',I2,1X,20(1H/),/
     *                 1X,20(1H/),''  FOUND     MAXIMUM '',
     *                            '' MULTIPOLARITY='',I2,1X,20(1H/),/
     *                 1X,20(1H/),''  A CONSTRAINT ON A MISSING '',
     *                            ''MULTIPOLE'',         1X,20(1H/),/
     *                 1X,20(1H/),''  WILL BE  INCLUDED  ONLY  A'',
     *                            ''FTER  THE'',         1X,20(1H/),/
     *                 1X,20(1H/),''  FIRST DIAGONALIZATION IS '',
     *                            '' PERFORMED'',        1X,20(1H/),/)')
     *
     *                NDMULT,MDMULT
C
                      DO LAMBDA=0,NDMULT
                         DO MIU=-LAMBDA,LAMBDA
C
                            RALMUQ(LAMBDA,MIU)=QLINEA(LAMBDA,MIU)
                            RALMUS(LAMBDA,MIU)=SLINEA(LAMBDA,MIU)
C
                            RALMUV(LAMBDA,MIU)=VLINEA(LAMBDA,MIU)
C
                         END DO
                      END DO
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                              ((DUMMY,
     *                                DUMMY,
     *                                MIU=-LAMBDA,LAMBDA),
     *                                LAMBDA=0,MDMULT)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING DUMMY'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                  ELSE
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                              ((RALMUQ(LAMBDA,MIU),
     *                                RALMUS(LAMBDA,MIU),
     *                                MIU=-LAMBDA,LAMBDA),
     *                                LAMBDA=0,MDMULT)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING RALMUQ'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      IF (IVERIN.GE.22) THEN
C
                          READ (NFIREP,IOSTAT=IERROR)
     *                                  ((RALMUV(LAMBDA,MIU),
     *                                    MIU=-LAMBDA,LAMBDA),
     *                                    LAMBDA=0,MDMULT)
                          IF (IERROR.NE.0) THEN
                              WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                              ''READING RALMUV'')')
                              CALL CPUTIM('RECORD',0)
                              RETURN
                          END IF
C
                      ELSE
C
                          RALMUV(:,:)=VLINEA(:,:)
C
                      END IF
C
                  END IF
C
              ELSE
C
                  DO LAMBDA=0,NDMULT
                     DO MIU=-LAMBDA,LAMBDA
C
                        RALMUQ(LAMBDA,MIU)=QLINEA(LAMBDA,MIU)
                        RALMUS(LAMBDA,MIU)=SLINEA(LAMBDA,MIU)
C
                     END DO
                  END DO
C
                  IF (IACONT.EQ.1)
     *
     *                WRITE(NFIPRI,'(/,
     *                    1X,13(1H/),'' WARNING: THE LINEAR CONSTRAI'',
     *                               ''NTS  H A V E  NOT BEEN'',
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' FOUND ON  THE  OLD  REPLAY '',
     *                               '' FILE  VERSION  NO. ='',I2,
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' THE EXACT AUGM.LAGRA. CANNOT'',
     *                               '' BE SMOOTHLY CONTINUED'',
     *                                               1X,13(1H/),/)')
     *
     *                IVERIN
C
              END IF
C
              IF (IVERIN.GE.13) THEN
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                 (HBMREA(KARTEZ),KARTEZ=1,NDKART)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING HBMREA'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                 (ROTREA(KARTEZ),KARTEZ=1,NDKART)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                      ''READING ROTREA'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
                  IF (IMCONT.EQ.1.AND.IRENMA.GE.1) THEN
C
                      DO KARTEZ=1,NDKART
C
                         HBMREN(KARTEZ)=HBMREA(KARTEZ)
C
                      END DO
C
                  END IF
C
                  IF (IRCONT.EQ.1.AND.IRENIN.GE.1) THEN
C
                      DO KARTEZ=1,NDKART
C
                         ROTREN(KARTEZ)=ROTREA(KARTEZ)
C
                      END DO
C
                  END IF
C
              ELSE
C
                  IF (IMCONT.EQ.1.AND.IRENMA.GE.1)
     *
     *                WRITE(NFIPRI,'(/,
     *                    1X,13(1H/),'' WARNING:  THE  RENORMALIZED'',
     *                               '' MASSES  HAVE NOT BEEN'',
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' FOUND ON  THE  OLD  REPLAY'',
     *                               '' FILE  VERSION  NO. ='',I2,
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' THE EXACT CM CORREC. CANNOT'',
     *                               '' BE SMOOTHLY CONTINUED'',
     *                                               1X,13(1H/),/)')
     *
     *                IVERIN
C
                  IF (IRCONT.EQ.1.AND.IRENIN.GE.1)
     *
     *                WRITE(NFIPRI,'(/,
     *                    1X,13(1H/),'' WARNING:  THE   RENORMALIZED'',
     *                               '' INERTIA HAVE NOT BEEN'',
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' FOUND  ON  THE  OLD  REPLAY'',
     *                               '' FILE  VERSION  NO. ='',I2,
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' THE EXACT ROT CORREC. CANNOT'',
     *                               '' BE SMOOTHLY CONTINUED'',
     *                                               1X,13(1H/),/)')
     *
     *                IVERIN
C
              END IF
C
C              Linear Constraints for the neck (IVERIN=17)
C
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.59) AND (2.65B) "G_NECK" WAS
C                       STORED ON THE RECORD FILE WITH INCORRECT VERSION
C                       OF THE FILE EQUAL 16. THIS CREATED  INCOMPABILTY
C                       PROBLEMS FOR THE RECORD VERSION 16 STORED IN THE
C                       CODE VERSIONS FROM (2.55I) TILL (2.56I) AND FROM
C                       (2.59) TILL (2.65B). IF READING OF THESE  RECORD
C                       FILES 16 CAUSES THE CRASH, ONE CAN RECOMPILE THE
C                       CODE BY SETTING THE VARIABLE:
C                          I16VERSION=0 FOR THE OLDER RECORD FILES 16
C                          I16VERSION=1 FOR THE NEWER RECORD FILES 16
C                       THIS BUG WAS CORRECTED ON 23/06/2013 IN  VERSION
C                       (2.65C).
C=======================================================================
C
              I16VERSION=0
C
              IF (IVERIN.GE.17.OR.
     *           (IVERIN.EQ.16.AND.I16VERSION.EQ.1)) THEN
C
                  READ (NFIREP,IOSTAT=IERROR) G_NECK
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                    ''READING G_NECK, TRY CHANGING I16VERSION'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
              ELSE
C
                  G_NECK=0.0
C
                  IF (IFNECK.GE.2)
     *
     *                WRITE(NFIPRI,'(/,
     *                1X,13(1H/),'' WARNING : THE  NECK  CONSTRAI'',
     *                           ''NTS  H A S  NOT  BEEN'',
     *                                           1X,13(1H/),/,
     *                1X,13(1H/),'' FOUND ON  THE  OLD  REPLAY '',
     *                           '' FILE  VERSION  NO. ='',I2,
     *                                           1X,13(1H/),/,
     *                1X,13(1H/),'' THE NECK CONSTRAINT CAN NOT'',
     *                           '' BE  SMOOTHLY CONTINUED'',
     *                                           1X,13(1H/),/)')
     *
     *            IVERIN
C
              END IF
C
C              Linear Spin Constraints for ALM (IVERIN=15)
C
              IF (IVERIN.GE.15) THEN
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                 (RALSPI(KARTEZ),KARTEZ=1,NDKART)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                    ''READING RALSPI, TRY CHANGING I16VERSION'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
              ELSE
C
                  RALSPI=DALSPI
C
                  IF (ISCONT.EQ.1)
     *
     *                WRITE(NFIPRI,'(/,
     *                    1X,13(1H/),'' WARNING: THE  SPIN  CONSTRAI'',
     *                               ''NTS  H A V E  NOT BEEN'',
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' FOUND ON  THE  OLD  REPLAY '',
     *                               '' FILE  VERSION  NO. ='',I2,
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' THE  SPIN AUGM.LAGRA. CANNOT'',
     *                               '' BE SMOOTHLY CONTINUED'',
     *                                               1X,13(1H/),/)')
     *
     *                IVERIN
C
              END IF
C
              IF (IVERIN.GE.18) THEN
C
                  READ (NFIREP,IOSTAT=IERROR)
     *                 (RALISO(KARTEZ),KARTEZ=1,NDKART)
                  IF (IERROR.NE.0) THEN
                      WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                    ''READING RALISO'')')
                      CALL CPUTIM('RECORD',0)
                      RETURN
                  END IF
C
              ELSE
C
                  RALISO=DALISO
C
                  IF (ITCONT.EQ.1)
     *
     *                WRITE(NFIPRI,'(/,
     *                    1X,13(1H/),'' WARNING THE ISOSPIN CONSTRAI'',
     *                               ''NTS  H A V E  NOT BEEN'',
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' FOUND ON  THE  OLD  REPLAY '',
     *                               '' FILE  VERSION  NO. ='',I2,
     *                                               1X,13(1H/),/,
     *                    1X,13(1H/),'' THE ISOSPIN AUG.LAGR. CANNOT'',
     *                               '' BE SMOOTHLY CONTINUED'',
     *                                               1X,13(1H/),/)')
     *
     *                IVERIN
C
              END IF
C
              IF (IPNMIX.EQ.1) THEN
C
                  VE_MAS(:,:,:,2,:)=C_ZERO
                  VE_CEN(:,:,:,2,:)=C_ZERO
                  VE_MAS(:,:,:,3,:)=C_ZERO
                  VE_CEN(:,:,:,3,:)=C_ZERO
C
                  VE_KIS(:,:,:,:,2,:)=C_ZERO
                  VE_SPI(:,:,:,:,2,:)=C_ZERO
                  VE_CUR(:,:,:,:,2,:)=C_ZERO
                  VE_KIS(:,:,:,:,3,:)=C_ZERO
                  VE_SPI(:,:,:,:,3,:)=C_ZERO
                  VE_CUR(:,:,:,:,3,:)=C_ZERO
C
                  VE_SOR(:,:,:,:,:,2,:)=C_ZERO
                  VE_SOR(:,:,:,:,:,3,:)=C_ZERO
C
              END IF
C
              IF (IVERIN.GE.16) THEN
C
                  READ (NFIREP,IOSTAT=IERROR) JPNMIX
C
                  IF (JPNMIX.EQ.1) THEN
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                                (((VE_MAS(IX,IY,IZ,2,1),
     *                                   VE_CEN(IX,IY,IZ,2,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_MAS(2)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                               ((((VE_KIS(IX,IY,IZ,L,2,1),
     *                                   VE_SPI(IX,IY,IZ,L,2,1),
     *                                   VE_CUR(IX,IY,IZ,L,2,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM),
     *                                                 L=1,NDKART)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_KIS(2)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                              (((((VE_SOR(IX,IY,IZ,L,K,2,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM),
     *                                    L=1,NDKART), K=1,NDKART)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_SOR(2)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                                (((VE_MAS(IX,IY,IZ,3,1),
     *                                   VE_CEN(IX,IY,IZ,3,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_MAS(3)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                               ((((VE_KIS(IX,IY,IZ,L,3,1),
     *                                   VE_SPI(IX,IY,IZ,L,3,1),
     *                                   VE_CUR(IX,IY,IZ,L,3,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM),
     *                                                 L=1,NDKART)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_KIS(3)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                              (((((VE_SOR(IX,IY,IZ,L,K,3,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM),
     *                                    L=1,NDKART), K=1,NDKART)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_SOR(3)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                  END IF
C
              END IF
C
              IF (IVERIN.GE.19) THEN
C
                  READ (NFIREP,IOSTAT=IERROR) META_T
C
                  IF (META_T.GE.1) THEN
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                                (((VE_SPT(IX,IY,IZ,0,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_SPT(0)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                               ((((VE_KIT(IX,IY,IZ,L,0,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM),
     *                                                 L=1,NDKART)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_KIT(0)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                                (((VE_SPT(IX,IY,IZ,1,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_SPT(1)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                               ((((VE_KIT(IX,IY,IZ,L,1,1),
     *
     *                                   IX=1,NXHERM),IY=1,NYHERM),
     *                                                IZ=1,NZHERM),
     *                                                 L=1,NDKART)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING VE_KIT(1)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                  ELSE
C
                      VE_SPT(:,:,:,0,:)=C_ZERO
                      VE_SPT(:,:,:,1,:)=C_ZERO
C
                      VE_KIT(:,:,:,:,0,:)=C_ZERO
                      VE_KIT(:,:,:,:,1,:)=C_ZERO
C
                  END IF
C
              END IF
C
              IF (IVERIN.GE.20) THEN
C
                  READ (NFIREP,IOSTAT=IERROR) METAPA
C
                  IF (METAPA.GE.1) THEN
C
                      READ (NFIREP,IOSTAT=IERROR)
     *
     *                     ((((WD_TAU(IX,IY,IZ,0,LTWCEN),
     *
     *                      IX=1,NXHERM),IY=1,NYHERM),
     *                                   IZ=1,NZHERM),
     *                               LTWCEN=1,MDTWCE)
C
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING WD_TAU(0)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *
     *                     ((((((WD_SOR(IX,IY,IZ,L,K,0,LTWCEN),
     *
     *                      IX=1,NXHERM),IY=1,NYHERM),
     *                                   IZ=1,NZHERM),
     *                       L=1,NDKART), K=1,NDKART),
     *                               LTWCEN=1,MDTWCE)
C
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING WD_SOR(0)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *
     *                     ((((WD_TAU(IX,IY,IZ,1,LTWCEN),
     *
     *                      IX=1,NXHERM),IY=1,NYHERM),
     *                                   IZ=1,NZHERM),
     *                               LTWCEN=1,MDTWCE)
C
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING WD_TAU(1)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *
     *                     ((((((WD_SOR(IX,IY,IZ,L,K,1,LTWCEN),
     *
     *                      IX=1,NXHERM),IY=1,NYHERM),
     *                                   IZ=1,NZHERM),
     *                       L=1,NDKART), K=1,NDKART),
     *                               LTWCEN=1,MDTWCE)
C
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING WD_SOR(1)'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                  ELSE
C
                      IF (JETAPA.GE.1) THEN
C
                          WD_TAU(:,:,:,0,:)=C_ZERO
                          WD_TAU(:,:,:,1,:)=C_ZERO
C
                          WD_SOR(:,:,:,:,:,0,:)=C_ZERO
                          WD_SOR(:,:,:,:,:,1,:)=C_ZERO
C
                      END IF
C
                  END IF
C
              END IF
C
              IF (IVERIN.GE.25) THEN
C
                  IF (MDTWCE.GT.1) THEN
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                              ((RLMFRA(ICHARG,LTWCEN),
     *                                ICHARG=0,NDISOS),
     *                                LTWCEN=1,NDTWCE)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING RLMFRA'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      READ (NFIREP,IOSTAT=IERROR)
     *                              (((RALMTW(LAMBDA,MIU,LTWCEN),
     *                                MIU=-LAMBDA,LAMBDA),
     *                                LAMBDA=0,MDMULT),
     *                                LTWCEN=1,NDTWCE)
                      IF (IERROR.NE.0) THEN
                          WRITE(NFIPRI,'(''RECORD() - ERROR IN '',
     *                          ''READING RALMUQ'')')
                          CALL CPUTIM('RECORD',0)
                          RETURN
                      END IF
C
                      IF (IFRCNT.EQ.1) THEN
C
                          CLMFRA(:,:)  =RLMFRA(:,:)
                          GALMTW(:,:,:)=RALMTW(:,:,:)
C
                      END IF
C
                  END IF
C
              END IF
C
              IFIRED=1
C
          END IF
C
          IF (IFIRED.EQ.0) THEN
C
              WRITE(NFIPRI,'(/,1X,10(1H/),
     *                  ''  CANNOT READ THE REPLAY FILE VERSION:'',
     *                  I3,2X,10(1H/),/)') IVERIN
C
              STOP ' CANNOT READ THE REPLAY FILE IN RECORD'
C
          END IF
C
          IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIMN).EQ.1.OR.
     *         MAXVAL(IABS(IDSIQN)).GE.1.OR.
     *         MAXVAL(IABS(IDSIZN)).GE.1).AND.
     *         INIBLN.EQ.0.AND.IDEBLO(0).LT.1) THEN
C
              WRITE(NFIPRI,'(/,
     *            1X,10(1H/),'' NEUTRON SINGLE-PARTICLE WF NOT FOUND'',
     *                       '' ON THE RECORD FILE'',   1X,10(1H/),/,
     *
     *            1X,10(1H/),'' RERUN THE BLOCKING CALCULATION WITH'',
     *                       '' INIBLN=1           '',  1X,10(1H/),/)')
C
              STOP ' NEUTRON SINGLE-PARTICLE WF NOT FOUND IN RECORD'
C
          END IF
C
          IF ((IABS(IDSIGP).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *         MAXVAL(IABS(IDSIQP)).GE.1.OR.
     *         MAXVAL(IABS(IDSIZP)).GE.1).AND.
     *         INIBLP.EQ.0.AND.IDEBLO(1).LT.1) THEN
C
              WRITE(NFIPRI,'(/,
     *            1X,10(1H/),'' PROTON  SINGLE-PARTICLE WF NOT FOUND'',
     *                       '' ON THE RECORD FILE'',   1X,10(1H/),/,
     *
     *            1X,10(1H/),'' RERUN THE BLOCKING CALCULATION WITH'',
     *                       '' INIBLP=1           '',  1X,10(1H/),/)')
C
              STOP ' PROTON SINGLE-PARTICLE WF NOT FOUND IN RECORD'
C
          END IF
C
      ELSE
C
C=======================================================================
C     INPFLD - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER  NFIREC WILL BE
C                          USED TO RECORD THE RESULTS OF THE CALCULATION
C=======================================================================
C
          REWIND NFIREC
C
          IVEROU=currentVersion
C
          IVEREP=IVEROU
C
          WRITE(NFIREC) IVEROU
C
          IF (IVEROU.EQ.currentVersion) THEN
C
              WRITE(NFIREC) NUMITE
C
              WRITE(NFIREC) NXHERM,NYHERM,NZHERM

              WRITE(NFIREC) LDTWCE
              WRITE(NFIREC) LDTWDD
C
              WRITE(NFIREC)  ((((VE_MAS(IX,IY,IZ,0,LTWCEN),
     *                           VE_CEN(IX,IY,IZ,0,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                    LTWCEN=1,LDTWCE)
C
              WRITE(NFIREC) (((((VE_KIS(IX,IY,IZ,L,0,LTWCEN),
     *                           VE_SPI(IX,IY,IZ,L,0,LTWCEN),
     *                           VE_CUR(IX,IY,IZ,L,0,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                         L=1,NDKART),
     *                                    LTWCEN=1,LDTWCE)
C
              WRITE(NFIREC) ((((((VE_SOR(IX,IY,IZ,L,K,0,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                            L=1,NDKART), K=1,NDKART),
     *                                    LTWCEN=1,LDTWCE)
C
              WRITE(NFIREC)  ((((VE_MAS(IX,IY,IZ,1,LTWCEN),
     *                           VE_CEN(IX,IY,IZ,1,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                    LTWCEN=1,LDTWCE)
C
              WRITE(NFIREC) (((((VE_KIS(IX,IY,IZ,L,1,LTWCEN),
     *                           VE_SPI(IX,IY,IZ,L,1,LTWCEN),
     *                           VE_CUR(IX,IY,IZ,L,1,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                         L=1,NDKART),
     *                                    LTWCEN=1,LDTWCE)
C
              WRITE(NFIREC) ((((((VE_SOR(IX,IY,IZ,L,K,1,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                            L=1,NDKART), K=1,NDKART),
     *                                    LTWCEN=1,LDTWCE)
C
              WRITE(NFIREC)  ((((DE_RHO(IX,IY,IZ,0,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                    LTWCEN=1,LDTWDD)
C
              WRITE(NFIREC)  ((((DE_RHO(IX,IY,IZ,1,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                    LTWCEN=1,LDTWDD)
C
              WRITE(NFIREC) NMUMAX
C
              WRITE(NFIREC) ((QMUL_N(LAMBDA,MIU),
     *                        QMUL_P(LAMBDA,MIU),
     *                        QMUL_T(LAMBDA,MIU),
     *
     *                        MIU=-LAMBDA,LAMBDA),LAMBDA=0,NMUMAX)
C
              WRITE(NFIREC) NSIMAX
C
              WRITE(NFIREC) ((SMUL_N(LAMBDA,MIU),
     *                        SMUL_P(LAMBDA,MIU),
     *                        SMUL_T(LAMBDA,MIU),
     *
     *                        MIU=-LAMBDA,LAMBDA),LAMBDA=0,NSIMAX)
C
              WRITE(NFIREC) ISHIFT,(RSHIFT(L),L=1,NDKART)
C
              WRITE(NFIREC) (ANGU_N(L),ANGU_P(L),ANGU_T(L),
     *                       SPIN_N(L),SPIN_P(L),SPIN_T(L),L=1,NDKART)
C
              WRITE(NFIREC)   ((((WD_CEN(IX,IY,IZ,0,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                    LTWCEN=1,LDTWCE)
C
              WRITE(NFIREC)   ((((WD_CEN(IX,IY,IZ,1,LTWCEN),
     *
     *                           IX=1,NXHERM),IY=1,NYHERM),
     *                                        IZ=1,NZHERM),
     *                                    LTWCEN=1,LDTWCE)
C
              WRITE(NFIREC)
     *
     *              EFERMN,DELTAN,
     *              EFERMP,DELTAP
C
              WRITE(NFIREC)
     *
     *              EFER2N,EFER2P
C
              WRITE(NFIREC)
     *
     *              LDBTOT,(IDEBLO(ICHARG),ICHARG=0,NDISOS)
C
              DO ICHARG=0,NDISOS
C
                 IF (IDEBLO(ICHARG).GE.1) THEN
C
                     WRITE(NFIREC)
     *
     *               (((WAVBLO(IBASE,ICHARG,IREVER,NUBLOC),
     *                                    IBASE= 1,LDBTOT),
     *                                    IREVER=0,NDREVE),
     *                             NUBLOC=1,IDEBLO(ICHARG))
                 END IF
C
              END DO
C
              WRITE(NFIREC) (ALINLT(KARTEZ),KARTEZ=0,NDKART)
C
              WRITE(NFIREC) (AROTLT(KARTEZ),KARTEZ=0,NDKART)
C
              WRITE(NFIREC) NDMULT
C
              WRITE(NFIREC) ((GALMUQ(LAMBDA,MIU),GALMUS(LAMBDA,MIU),
     *                        MIU=-LAMBDA,LAMBDA),LAMBDA=0,NDMULT)
C
              WRITE(NFIREC) ((GALMUV(LAMBDA,MIU),
     *                        MIU=-LAMBDA,LAMBDA),LAMBDA=0,NDMULT)
C
              WRITE(NFIREC) (HBMREN(KARTEZ),KARTEZ=1,NDKART)
C
              WRITE(NFIREC) (ROTREN(KARTEZ),KARTEZ=1,NDKART)
C
              WRITE(NFIREC) G_NECK
C
              WRITE(NFIREC) (GALSPI(KARTEZ),KARTEZ=1,NDKART)
C
              WRITE(NFIREC) (GALISO(KARTEZ),KARTEZ=1,NDKART)
C
              WRITE(NFIREC) IPNMIX
C
C=======================================================================
C      ATTENTION: TWO-CENTER FIELDS NOT RECORDED WITH PN MIXING
C=======================================================================
C
              IF (IPNMIX.EQ.1) THEN
C
                  WRITE(NFIREC)   (((VE_MAS(IX,IY,IZ,2,1),
     *                               VE_CEN(IX,IY,IZ,2,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM)
C
                  WRITE(NFIREC)  ((((VE_KIS(IX,IY,IZ,L,2,1),
     *                               VE_SPI(IX,IY,IZ,L,2,1),
     *                               VE_CUR(IX,IY,IZ,L,2,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                             L=1,NDKART)
C
                  WRITE(NFIREC) (((((VE_SOR(IX,IY,IZ,L,K,2,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                L=1,NDKART), K=1,NDKART)
C
                  WRITE(NFIREC)   (((VE_MAS(IX,IY,IZ,3,1),
     *                               VE_CEN(IX,IY,IZ,3,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM)
C
                  WRITE(NFIREC)  ((((VE_KIS(IX,IY,IZ,L,3,1),
     *                               VE_SPI(IX,IY,IZ,L,3,1),
     *                               VE_CUR(IX,IY,IZ,L,3,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                             L=1,NDKART)
C
                  WRITE(NFIREC) (((((VE_SOR(IX,IY,IZ,L,K,3,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                L=1,NDKART), K=1,NDKART)
C
              END IF
C
              WRITE(NFIREC) JETA_T
C
              IF (JETA_T.GE.1) THEN
C
                  WRITE(NFIREC)   (((VE_SPT(IX,IY,IZ,0,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM)
C
                  WRITE(NFIREC)  ((((VE_KIT(IX,IY,IZ,L,0,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                             L=1,NDKART)
C
                  WRITE(NFIREC)   (((VE_SPT(IX,IY,IZ,1,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM)
C
                  WRITE(NFIREC)  ((((VE_KIT(IX,IY,IZ,L,1,1),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                             L=1,NDKART)
C
              END IF
C
              WRITE(NFIREC) JETAPA
C
              IF (JETAPA.GE.1) THEN
C
                  WRITE(NFIREC)   ((((WD_TAU(IX,IY,IZ,0,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,LDTWCE)

C
                  WRITE(NFIREC) ((((((WD_SOR(IX,IY,IZ,L,K,0,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                L=1,NDKART), K=1,NDKART),
     *                                        LTWCEN=1,LDTWCE)
C
                  WRITE(NFIREC)   ((((WD_TAU(IX,IY,IZ,1,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                        LTWCEN=1,LDTWCE)
C
                  WRITE(NFIREC) ((((((WD_SOR(IX,IY,IZ,L,K,1,LTWCEN),
     *
     *                               IX=1,NXHERM),IY=1,NYHERM),
     *                                            IZ=1,NZHERM),
     *                                L=1,NDKART), K=1,NDKART),
     *                                        LTWCEN=1,LDTWCE)
C
              END IF
C
              IF (LDTWCE.GT.1) THEN
C
                  WRITE(NFIREC) ((CLMFRA(ICHARG,LTWCEN),
     *                        ICHARG=0,NDISOS),LTWCEN=1,NDTWCE)
C
                  WRITE(NFIREC) (((GALMTW(LAMBDA,MIU,LTWCEN),
     *                        MIU=-LAMBDA,LAMBDA),LAMBDA=0,NDMULT),
     *                                            LTWCEN=1,NDTWCE)
C
              END IF
C
          END IF
C
      END IF
C
C
C=======================================================================
C
      DEALLOCATE (DPRRHO,DNRRHO,VNRMAS,VNRCEN,VPRMAS,VPRCEN,VNRKIS,
     *            VNRSPI,VNRCUR,VPRKIS,VPRSPI,VPRCUR,VNRSOR,VPRSOR)
C
C=======================================================================
C
      CALL CPUTIM('RECORD',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECBAS(NFIBAP,NFIBAC,INPFLD,IERROR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /BMULTI/ BMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                BMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                BMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /CFIPRI/ NFIPRI
C=======================================================================
C
      IVEBAC = 1
C
C=======================================================================
C     INPFLD - IF .NE.0 => THE FILE WITH THE UNIT NUMBER  NFIBAP WILL BE
C                          USED TO  R E A D  THE RESULTS OF THE PREVIOUS
C                          CALCULATION            (FROM THE UNIT NFIBAP)
C=======================================================================
C
      IF (INPFLD.NE.0) THEN
C
          REWIND(UNIT=NFIBAP,IOSTAT=IERROR)
          IF (IERROR.NE.0) THEN
              WRITE(NFIPRI,'(''RECBAS() - ERROR IN '',
     *              ''REWINDING FILE '',i4)') NFIBAP
              RETURN
          END IF
C
          IFIRED=0
C
          READ (NFIBAP,*,IOSTAT=IERROR) IVERIN
          IF (IERROR.NE.0) THEN
              WRITE(NFIPRI,'(''RECBAS() - ERROR IN '',
     *              ''READING IVERIN'')')
              RETURN
          END IF
C
          IF (IVERIN.LE.IVEBAC) THEN
C
              READ (NFIBAP,*) MDMULT
C
              IF (MDMULT.GT.NDLAMB)
     *
     *        WRITE(NFIPRI,'(
     *                1H*,20(1H/),2X,''WARNING ---- WARNING ---- WA'',
     *                               ''RNING''       ,2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''TOO MANY MULTIPOLES (NDMULT='',
     *                                 I1,'')  '',   2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''INSTEAD OF (NDLAMB='',I1,'')'',
     *                               ''FOUND ON THE'',2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''BASIS FILE. RECOMPILE AND RE'',
     *                               ''RUN  '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''WITH NDMULT=NDLAMB.         '',
     *                               ''     '',      2X,20(1H/),1H*,/)')
     *        MDMULT,NDLAMB
C
              IF (MDMULT.LT.NDLAMB)
     *
     *        WRITE(NFIPRI,'(
     *                1H*,20(1H/),2X,''WARNING ---- WARNING ---- WA'',
     *                               ''RNING''       ,2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''TOO FEW  MULTIPOLES (NDMULT='',
     *                                 I1,'')  '',   2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''INSTEAD OF (NDLAMB='',I1,'')'',
     *                               ''FOUND ON THE'',2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''BASIS FILE. RECOMPILE AND RE'',
     *                               ''RUN  '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''WITH NDMULT=NDLAMB.         '',
     *                               ''     '',      2X,20(1H/),1H*,/)')
     *        MDMULT,NDLAMB
C
              ALPHAR(:,:)=0.0D0
C
              DO LAM=0,MIN(MDMULT,NDLAMB)
                 READ (NFIBAP,*) LDUMMY,(ALPHAR(LAM,MIU),MIU=0,LAM)
              END DO
C
              IFIRED=1
C
          END IF
C
          IF (IFIRED.EQ.0) THEN
C
              WRITE(NFIPRI,'(/,1X,10(1H/),
     *                  ''  CANNOT READ THE BASIS FILE VERSION: '',
     *                  I3,2X,10(1H/),/)') IVERIN
C
              STOP ' CANNOT READ THE BASIS FILE IN RECBAS'
C
          END IF
C
      ELSE
C
C=======================================================================
C     INPFLD - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER  NFIBAC WILL BE
C                          USED TO RECORD THE RESULTS OF THE CALCULATION
C=======================================================================
C     ATTENTION: 1) ONLY REAL PARTS OF  BOHR  DEFORMATIONS  ARE  STORED.
C                2) THE INFORMATION ON WHETHER THE  LINEAR-APPROXIMATION
C                   OR EXACT METHOD  WAS  USED  TO  CALCULATE  THE  BOHR
C                   DEFORMATIONS IS NOT STORED (YET).
C=======================================================================
C
          REWIND NFIBAC
C
          IVEROU=IVEBAC
C
          WRITE(NFIBAC,*) IVEROU
C
          IF (IVEROU.EQ.IVEBAC) THEN
C
              WRITE(NFIBAC,*) NDMULT
C
              DO LAM=0,NDMULT
                 WRITE(NFIBAC,*) LAM,(BMUL_T(LAM,MIU),MIU=0,LAM)
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECYUK(NFIYUP,NFIYUC,INPYUK)
C=======================================================================
      USE YUKSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMENS/ LDBASE
C=======================================================================
C     INPYUK - IF .NE.0 => THE FILE WITH THE UNIT NUMBER  NFIYUP WILL BE
C                          USED TO  R E A D  THE  YUKAWA   MEAN   FIELDS
C=======================================================================
C
      IF (INPYUK.NE.0) THEN
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(YUKASV)) THEN
          ALLOCATE (YUKASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('YUKASV','RECYUK')
      END IF
C=======================================================================
C
          REWIND(UNIT=NFIYUP,IOSTAT=IERROR)
C
          IF (IERROR.NE.0) STOP 'ERROR IN REWINDING (9)'
C
          READ (NFIYUP) MDBASE
C
          IF (MDBASE.NE.LDBASE) THEN
C
              WRITE(NFIPRI,'(/,
     *             1X,10(1H/),'' INCOMPATIBLE DIMENSIONS'',
     *                        '' FOUND ON THE'',         1X,10(1H/),/,
     *             1X,10(1H/),'' YUKAWA FILE,'',
     *                        '' LDBASE='',I4,'' MDBASE='',I4,
     *                                                   1X,10(1H/),/)')
     *             LDBASE,MDBASE
C
              STOP 'MDBASE.NE.LDBASE IN RECYUK'
C
          END IF
C
          READ (NFIYUP)((((YUKASV(IBRA,IKET,KARTEZ,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      KARTEZ=0,NDKART),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
      ELSE
C
C=======================================================================
C     INPYUK - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER  NFIYUC WILL BE
C                          USED TO  RECORD  THE   YUKAWA   MEAN   FIELDS
C=======================================================================
C
          REWIND(UNIT=NFIYUC,IOSTAT=IERROR)
C
          IF (IERROR.NE.0) STOP 'ERROR IN REWINDING (10)'
C
          WRITE(NFIYUC) LDBASE
C
          WRITE(NFIYUC)((((YUKASV(IBRA,IKET,KARTEZ,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      KARTEZ=0,NDKART),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECGOG(NFIGOP,NFIGOC,INPGOG)
C=======================================================================
      USE GOGSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMENS/ LDBASE
C=======================================================================
C     INPGOG - IF .NE.0 => THE FILE WITH THE UNIT NUMBER  NFIGOP WILL BE
C                          USED TO  R E A D  THE  GOGNY    MEAN   FIELDS
C=======================================================================
C
      IF (INPGOG.NE.0) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(GOGASV)) THEN
              ALLOCATE (GOGASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),
     *                                             STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GOGASV','RECGOG')
          END IF
C
          REWIND NFIGOP
C
          READ (NFIGOP) MDBASE
C
          IF (MDBASE.NE.LDBASE) THEN
C
              WRITE(NFIPRI,'(/,
     *             1X,10(1H/),'' INCOMPATIBLE DIMENSIONS'',
     *                        '' FOUND ON THE'',         1X,10(1H/),/,
     *             1X,10(1H/),'' GOGNY  FILE,'',
     *                        '' LDBASE='',I4,'' MDBASE='',I4,
     *                                                   1X,10(1H/),/)')
     *             LDBASE,MDBASE
C
              STOP 'MDBASE.NE.LDBASE IN RECGOG'
C
          END IF
C
          READ (NFIGOP)((((GOGASV(IBRA,IKET,KARTEZ,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      KARTEZ=0,NDKART),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
      ELSE
C
C=======================================================================
C     INPGOG - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER  NFIGOC WILL BE
C                          USED TO  RECORD  THE   GOGNY    MEAN   FIELDS
C=======================================================================
C
          REWIND NFIGOC
C
          WRITE(NFIGOC) LDBASE
C
          WRITE(NFIGOC)((((GOGASV(IBRA,IKET,KARTEZ,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      KARTEZ=0,NDKART),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECGPA(NFIGPP,NFIGPC,INPGPA)
C=======================================================================
      USE GOGKAP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMENS/ LDBASE
C=======================================================================
C     INPGOG - IF .NE.0 => THE FILE WITH THE UNIT NUMBER  NFIGOP WILL BE
C                          USED TO  R E A D  THE  GOGNY    MEAN   FIELDS
C=======================================================================
C
      IF (INPGPA.NE.0) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(GOGCHI)) THEN
              ALLOCATE (GOGCHI(NDBASE,NDBASE,0:NDKART,0:NDISOS),
     *                                             STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GOGCHI','RECGPA')
          END IF
C
          REWIND NFIGPP
C
          READ (NFIGPP) MDBASE
C
          IF (MDBASE.NE.LDBASE) THEN
C
              WRITE(NFIPRI,'(/,
     *             1X,10(1H/),'' INCOMPATIBLE DIMENSIONS'',
     *                        '' FOUND ON THE'',         1X,10(1H/),/,
     *             1X,10(1H/),'' GOGNY  FILE,'',
     *                        '' LDBASE='',I4,'' MDBASE='',I4,
     *                                                   1X,10(1H/),/)')
     *             LDBASE,MDBASE
C
              STOP 'MDBASE.NE.LDBASE IN RECGPA'
C
          END IF
C
          READ (NFIGPP)((((GOGCHI(IBRA,IKET,KARTEZ,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      KARTEZ=0,NDKART),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
      ELSE
C
C=======================================================================
C     INPGOG - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER  NFIGOC WILL BE
C                          USED TO  RECORD  THE   GOGNY    MEAN   FIELDS
C=======================================================================
C
          REWIND NFIGPC
C
          WRITE(NFIGPC) LDBASE
C
          WRITE(NFIGPC)((((GOGCHI(IBRA,IKET,KARTEZ,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      KARTEZ=0,NDKART),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECREG(NFIROP,NFIROC,INPREG)
C=======================================================================
      USE REGSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMENS/ LDBASE
C=======================================================================
C     INPREG - IF .NE.0 => THE FILE WITH THE UNIT NUMBER  NFIROP WILL BE
C                          USED TO  R E A D  THE  REGNY    MEAN   FIELDS
C=======================================================================
C
      IF (INPREG.NE.0) THEN
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(REGASV)) THEN
          ALLOCATE (REGASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REGASV','RECREG')
      END IF
C=======================================================================
C
          REWIND NFIROP
C
          READ (NFIROP) MDBASE
C
          IF (MDBASE.NE.LDBASE) THEN
C
              WRITE(NFIPRI,'(/,
     *             1X,10(1H/),'' INCOMPATIBLE DIMENSIONS'',
     *                        '' FOUND ON THE'',         1X,10(1H/),/,
     *             1X,10(1H/),'' REGUL  FILE,'',
     *                        '' LDBASE='',I4,'' MDBASE='',I4,
     *                                                   1X,10(1H/),/)')
     *             LDBASE,MDBASE
C
              STOP 'MDBASE.NE.LDBASE IN RECREG'
C
          END IF
C
          READ (NFIROP)((((REGASV(IBRA,IKET,KARTEZ,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      KARTEZ=0,NDKART),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
      ELSE
C
C=======================================================================
C     INPREG - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER  NFIROC WILL BE
C                          USED TO  RECORD  THE   REGUL    MEAN   FIELDS
C=======================================================================
C
          REWIND NFIROC
C
          WRITE(NFIROC) LDBASE
C
          WRITE(NFIROC)((((REGASV(IBRA,IKET,KARTEZ,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      KARTEZ=0,NDKART),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECFIL(NFIFIP,NFIFIC,INPFIL,ISIMPY,IPAHFB,
     *                                IPNMIX,NOSCIL,NUMITE,
     *                         EFERMN,EFERMP,EFER2N,EFER2P,
     *                                DELTAN,DELTAP,IF_THO,
     *                                       NLIMIT,FILTHO,
     *                         ISGOGP,ISREGP,REA2PP,IVEFIP,
     *                                              ITWCEN)
C=======================================================================
      USE hfodd_interface
      USE MAF_PP
      USE MAF_PM
      USE MAPIDE
      USE PNMXPP
      USE PNMXPM
      USE MAFTWC
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO,CDUMMY
C
      DIMENSION
     *          ROMSCA(NDKART),RO2SCA(NDKART)
C
      CHARACTER
     *          FILTHO*30
C
      LOGICAL
     *          REA2PP
C
      COMMON
     *       /PAIINI/ FERINI(0:NDISOS),DELINI(0:NDISOS),FE2INI(0:NDISOS)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMENS/ LDBASE
C
      DATA
     *     IVEFIL /4/
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(FIL_PP)) THEN
          ALLOCATE (FIL_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FIL_PP','RECFIL')
      END IF
      IF (.NOT.ALLOCATED(FIL_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (FIL_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FIL_PM','RECFIL')
      END IF
      IF (.NOT.ALLOCATED(FIPIDE).AND.IPAHFB.GE.1) THEN
          ALLOCATE (FIPIDE(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FIPIDE','RECFIL')
      END IF
C
      IF (.NOT.ALLOCATED(FIP2DE).AND.REA2PP) THEN
          ALLOCATE (FIP2DE(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FIP2DE','RECFIL')
      END IF
C
      IF (ITWCEN.EQ.2) THEN
C
      IF (.NOT.ALLOCATED(FITWPP)) THEN
          ALLOCATE (FITWPP(1:NDBASE,1:NDBASE,0:NDREVE,1:NDTWBL,
     *                                       0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FITWPP','RECFIL')
      END IF
      IF (.NOT.ALLOCATED(FITWPM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (FITWPM(1:NDBASE,1:NDBASE,0:NDREVE,1:NDTWBL,
     *                                       0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FITWPM','RECFIL')
      END IF
      IF (.NOT.ALLOCATED(FITWDE).AND.IPAHFB.GE.1) THEN
          ALLOCATE (FITWDE(1:NDBASE,1:NDBASE,0:NDREVE,1:NDTWBL,
     *                                       0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FITWDE','RECFIL')
      END IF
C
      END IF
C=======================================================================
      IF (IPNMIX.EQ.1) THEN
          IF (.NOT.ALLOCATED(PNM_PP)) THEN
              ALLOCATE (PNM_PP(1:2*NDBASE,1:2*NDBASE,0:NDREVE),
     *                        STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('PNM_PP','RECFIL')
          END IF
          IF (ISIMPY.NE.1) THEN
              IF (.NOT.ALLOCATED(PNM_PM)) THEN
                  ALLOCATE (PNM_PM(1:2*NDBASE,1:2*NDBASE,0:NDREVE),
     *                            STAT=IALLOC)
                  IF (IALLOC.NE.0) CALL NOALLO('PNM_PM','RECFIL')
              END IF
          END IF
      END IF
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C     INPFIL - IF .NE.0 => THE FILE WITH THE UNIT NUMBER NFIFIP WILL  BE
C                          USED TO  R E A D  THE MEAN FIELDS
C=======================================================================
C
      IVEFIP=0
C
      IF (INPFIL.NE.0) THEN
C
C=======================================================================
C          READING THE FILE GENERATED BY HFBTHO AND UPDATING VARIOUS
C          VARIABLES SUCH AS TO GUARANTEE A SMOOTH RESTART
C=======================================================================
C
          IF (IF_THO.GE.1) THEN
C
              IFSHAP=1
              NUMITE=1
C
C              Fermi levels, LN lambda_2 and pairing gaps are output
C              of HFBTHO, and are used as educated guesses for HFODD
C              restart. BETTHO, NOSCIL have been set as HFODD inputs,
C              passed to HFBTHO, read again here. Only NLIMIT may be
C              different from what HFODD would have produced, as the
C              counting convention in subroutine base() of HFBTHO is
C              different from that of SETBAS() of HFODD.
C
              CALL ReadHFBTHO(EFERMN,EFERMP,EFER2N,EFER2P,
     *                                      DELTAN,DELTAP,
     *                        PRHO_N,PRHODN,PRHOSN,POWERN,
     *                        PRHO_P,PRHODP,PRHOSP,POWERP,
     *                        BETTHO,NOSCIL,NLIMIT,FILTHO,
     *                               B0_THO,BZ_THO,BP_THO)
C
              FERINI(0)=EFERMN
              FERINI(1)=EFERMP
              DELINI(0)=DELTAN
              DELINI(1)=DELTAP
C
              HBAROX_THO=(H_BARC/BP_THO)**2/XMASSN
              HBAROY_THO=(H_BARC/BP_THO)**2/XMASSN
              HBAROZ_THO=(H_BARC/BZ_THO)**2/XMASSN
C
              HOMSCX_THO=1.0D0/BP_THO
              HOMSCY_THO=1.0D0/BP_THO
              HOMSCZ_THO=1.0D0/BZ_THO
C
              DO LAMBDA=1,maxLambda
                 GALMUQ(LAMBDA,0)=xmultLag(LAMBDA)
                 QLINEA(LAMBDA,0)=xmultLag(LAMBDA)
              END DO
C
              DEALLOCATE(xmultLag)
C
C              Overwriting pairing force with convention from HFBTHO
C
              CALL RHODEP(2,PRHO_N,PRHODN,PRHOSN,POWERN)
              CALL RHODEP(2,PRHO_P,PRHODP,PRHOSP,POWERP)
C
              RETURN
C
          END IF
C
C=======================================================================
C         NORMAL COURSE OF RECFIL WHEN USING FIELDS TO RESTART AND
C         NO HFBTHO OPTION
C=======================================================================
C
          REWIND(UNIT=NFIFIP,IOSTAT=IERROR)
C
          IF (IERROR.NE.0) STOP 'ERROR IN REWINDING (3)'
C
          READ (NFIFIP) MVEFIL,MDBASE
C
          IVEFIP=MVEFIL
C
          IF (MVEFIL.GT.IVEFIL) THEN
C
              WRITE(NFIPRI,'(/,1X,10(1H/),
     *                  ''  CANNOT READ THE FIELDS FILE VERSION:'',
     *                  I3,2X,10(1H/),/)') MVEFIL
C
              STOP '  WRONG MVEFIL IN RECFIL'
C
          END IF

          JTWCEN = 1
C
          IF (MVEFIL.GE.4) READ (NFIFIP) JTWCEN

          IF (ITWCEN.NE.JTWCEN)
     *        STOP 'NUMBER OF CENTERS MUST BE EQUAL IN RECFIL'
C
          IF (JTWCEN.EQ.1) THEN
C
              IF (MDBASE.NE.LDBASE) THEN
C
                  WRITE(NFIPRI,'(/,
     *             1X,10(1H/),'' INCOMPATIBLE DIMENSIONS'',
     *                        '' FOUND ON THE'',         1X,10(1H/),/,
     *             1X,10(1H/),'' FIELDS FILE,'',
     *                        '' LDBASE='',I4,'' MDBASE='',I4,
     *                                                   1X,10(1H/),/)')
     *             MDBASE,LDBASE
C
                   STOP 'MDBASE.NE.LDBASE IN RECFIL'
C
              END IF
C
          ELSEIF (JTWCEN.EQ.2) THEN
C
              IF (MDBASE.NE.LDBTOT) THEN
C
                  WRITE(NFIPRI,'(/,
     *             1X,10(1H/),'' INCOMPATIBLE DIMENSIONS'',
     *                        '' FOUND ON THE'',         1X,10(1H/),/,
     *             1X,10(1H/),'' FIELDS FILE,'',
     *                        '' LDBASE='',I4,'' MDBASE='',I4,
     *                                                   1X,10(1H/),/)')
     *             MDBASE,LDBTOT
C
                   STOP 'MDBASE.NE.LDBTOT IN RECFIL'
C
              END IF
C
          END IF
C
C=======================================================================
C         READING THE HARMONIC-OSCILLATOR FREQUENCIES
C=======================================================================
C
          READ (NFIFIP) RBAROX,RBAROY,RBAROZ
C
          IF (RBAROX.NE.HBAROX(1).OR.RBAROY.NE.HBAROY(1)
     *       .OR.RBAROZ.NE.HBAROZ(1)) THEN
C
              WRITE(NFIPRI,'(
     *            1X,19(1H/),'' WARNING:  INCOMPATIBLE HO FREQUENCIES'',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''       FOUND ON THE FIELDS FILE       '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    FREQUENCY  FROM FILE  FROM CODE   '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    ---------  ---------  ---------   '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    HBAROX = '',2F11.7,  4X,19(1H/),/,
     *            1X,19(1H/),''    HBAROY = '',2F11.7,  4X,19(1H/),/,
     *            1X,19(1H/),''    HBAROZ = '',2F11.7,  4X,19(1H/),/)')
     *
     *            RBAROX,HBAROX(1),RBAROY,HBAROY(1),RBAROZ,HBAROZ(1)
C
          END IF
C
          IF (MVEFIL.GE.4.AND.JTWCEN.EQ.2) THEN
C
              READ (NFIFIP) RBA2OX,RBA2OY,RBA2OZ
C
              IF (RBA2OX.NE.HBAROX(JTWCEN).OR.RBA2OY.NE.
     *                HBAROY(JTWCEN).OR.RBA2OZ.NE.HBAROZ(JTWCEN)) THEN
C
                  WRITE(NFIPRI,'(
     *            1X,19(1H/),'' WARNING:  INCOMPATIBLE HO FREQUENCIES'',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''       FOUND ON THE FIELDS FILE       '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    FREQUENCY  FROM FILE  FROM CODE   '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    ---------  ---------  ---------   '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    HBAROX2= '',2F11.7,  4X,19(1H/),/,
     *            1X,19(1H/),''    HBAROY2= '',2F11.7,  4X,19(1H/),/,
     *            1X,19(1H/),''    HBAROZ2= '',2F11.7,  4X,19(1H/),/)')
     *
     *            RBA2OX,HBAROX(JTWCEN),RBA2OY,HBAROY(JTWCEN),RBA2OZ,
     *            HBAROZ(JTWCEN)
C
              END IF
C
          END IF
C
C=======================================================================
C         READING THE HARMONIC-OSCILLATOR LENGTHS
C=======================================================================
C
          READ (NFIFIP) ROMSCA(1),ROMSCA(2),ROMSCA(3)
C
          IF (ROMSCA(1).NE.HOMSCA(1,1).OR.
     *        ROMSCA(2).NE.HOMSCA(2,1).OR.
     *        ROMSCA(3).NE.HOMSCA(3,1)) THEN
C
              WRITE(NFIPRI,'(
     *            1X,19(1H/),'' WARNING:  INCOMPATIBLE  H.O.  LENGTHS'',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''       FOUND ON THE FIELDS FILE       '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    HO LENGTH  FROM FILE  FROM CODE   '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    ---------  ---------  ---------   '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    HOMSCA-X='',2F11.7,  4X,19(1H/),/,
     *            1X,19(1H/),''    HOMSCA-Y='',2F11.7,  4X,19(1H/),/,
     *            1X,19(1H/),''    HOMSCA-Z='',2F11.7,  4X,19(1H/),/)')
     *
     *            ROMSCA(1),HOMSCA(1,1),
     *            ROMSCA(2),HOMSCA(2,1),
     *            ROMSCA(3),HOMSCA(3,1)
C
          END IF
C
          IF (MVEFIL.GE.4.AND.JTWCEN.EQ.2) THEN
C
              READ (NFIFIP) RO2SCA(1),RO2SCA(2),RO2SCA(3)
C
              IF (RO2SCA(1).NE.HOMSCA(1,JTWCEN).OR.
     *            RO2SCA(2).NE.HOMSCA(2,JTWCEN).OR.
     *            RO2SCA(3).NE.HOMSCA(3,JTWCEN)) THEN
C
                  WRITE(NFIPRI,'(
     *            1X,19(1H/),'' WARNING:  INCOMPATIBLE  H.O.  LENGTHS'',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''       FOUND ON THE FIELDS FILE       '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    HO LENGTH  FROM FILE  FROM CODE   '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    ---------  ---------  ---------   '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''    HO2SCA-X='',2F11.7,  4X,19(1H/),/,
     *            1X,19(1H/),''    HO2SCA-Y='',2F11.7,  4X,19(1H/),/,
     *            1X,19(1H/),''    HO2SCA-Z='',2F11.7,  4X,19(1H/),/)')
     *
     *            RO2SCA(1),HOMSCA(1,JTWCEN),
     *            RO2SCA(2),HOMSCA(2,JTWCEN),
     *            RO2SCA(3),HOMSCA(3,JTWCEN)
C
              END IF
C
          END IF
C
C=======================================================================
C         READING THE BASIS QUANTUM NUMBERS
C=======================================================================
C
          I_HEAD=0
C
          DO IBASE=1,LDBATW(1)
C
             READ (NFIFIP) MXVECT,MYVECT,MZVECT
C
             IF (MXVECT.NE.NXVECT(IBASE,1).OR.
     *           MYVECT.NE.NYVECT(IBASE,1).OR.
     *           MZVECT.NE.NZVECT(IBASE,1)) THEN
C
                 IF (I_HEAD.NE.1)
     *
     *               WRITE(NFIPRI,'(
     *
     *            1X,19(1H/),'' WARNING: INCOMPATIBLE QUANTUM NUMBERS'',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''       FOUND ON THE FIELDS FILE       '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''   STATE    FROM  FILE    FROM  CODE  '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''   -----    ----------    ----------  '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''   IBASE    NX  NY  NZ    NX  NY  NZ  '',
     *                                                  1X,19(1H/))')
C
                 I_HEAD=1
C
                 WRITE(NFIPRI,'(
     *
     *            1X,19(1H/),I8,I6,I4,I4,I6,I4,I4,      3X,19(1H/))')
     *
     *            IBASE,
     *            MXVECT,       MYVECT,       MZVECT,
     *            NXVECT(IBASE,1),NYVECT(IBASE,1),NZVECT(IBASE,1)
C
             END IF
C
          END DO
C
          IF (I_HEAD.EQ.1) WRITE(NFIPRI,*)
C
          IF (JTWCEN.EQ.2.AND.MVEFIL.GE.4) THEN
C
              I_HEAD=0

              DO IBASE=1,LDBATW(JTWCEN)
C
                 READ (NFIFIP) MXVEC2,MYVEC2,MZVEC2
C
                 IF (MXVEC2.NE.NXVECT(IBASE,JTWCEN).OR.
     *               MYVEC2.NE.NYVECT(IBASE,JTWCEN).OR.
     *               MZVEC2.NE.NZVECT(IBASE,JTWCEN)) THEN
C
                     IF (I_HEAD.NE.1)
     *
     *                  WRITE(NFIPRI,'(
     *
     *            1X,19(1H/),'' WARNING: INCOMPATIBLE QUANTUM NUMBERS'',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''       FOUND ON THE FIELDS FILE       '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''   STATE    FROM  FILE    FROM  CODE  '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''   -----    ----------    ----------  '',
     *                                                  1X,19(1H/),/,
     *            1X,19(1H/),''   IBASE    NX  NY  NZ    NX  NY  NZ  '',
     *                                                  1X,19(1H/))')
C
                     I_HEAD=1
C
                     WRITE(NFIPRI,'(
     *
     *            1X,19(1H/),I8,I6,I4,I4,I6,I4,I4,      3X,19(1H/))')
     *
     *               IBASE,
     *               MXVEC2,       MYVEC2,       MZVEC2,
     *               NXVECT(IBASE,JTWCEN),NYVECT(IBASE,JTWCEN),
     *               NZVECT(IBASE,JTWCEN)
C
                 END IF
C
              END DO
C
          END IF
C
          IF (I_HEAD.EQ.1) WRITE(NFIPRI,*)
C
C=======================================================================
C         READING THE SYMMETRY SWITCHES
C=======================================================================
C
          READ (NFIFIP) JSIMPY,JPAHFB
C
          JPNMIX=0
          IF (MVEFIL.GE.2) READ (NFIFIP) JPNMIX
C
C=======================================================================
C         READING THE MEAN FIELDS
C=======================================================================
C
          IF (JPNMIX.EQ.1) THEN
C
              READ (NFIFIP)(((PNM_PP(IBRA,IKET,IREVER),
     *                                         IREVER=0,NDREVE),
     *                                    IKET=1,2*LDBASE),
     *                               IBRA=1,2*LDBASE)
C
              IF (JSIMPY.NE.1) THEN
C
                  IF (ISIMPY.NE.1) THEN
C
                      READ (NFIFIP) (((PNM_PM(IBRA,IKET,IREVER),
     *                                         IREVER=0,NDREVE),
     *                                    IKET=1,2*LDBASE),
     *                               IBRA=1,2*LDBASE)
C
                  ELSE
C
                      READ (NFIFIP) (((CDUMMY,
     *                                         IREVER=0,NDREVE),
     *                                    IKET=1,2*LDBASE),
     *                               IBRA=1,2*LDBASE)
C
                  END IF
C
              ELSE
C
                  IF (ISIMPY.NE.1) PNM_PM=C_ZERO
C
              END IF
C
              IF (IPNMIX.NE.1) THEN
C
                  DO IREVER=0,NDREVE
                     DO IKET=1,LDBASE
                        DO IBRA=1,LDBASE
C
                           FIL_PP(IBRA       ,IKET       ,IREVER,0)=
     *                     PNM_PP(IBRA       ,IKET       ,IREVER)
                           FIL_PP(IBRA       ,IKET       ,IREVER,1)=
     *                     PNM_PP(IBRA+LDBASE,IKET+LDBASE,IREVER)
C
                           IF (ISIMPY.NE.1) THEN
C
                               FIL_PM(IBRA       ,IKET       ,IREVER,0)=
     *                         PNM_PM(IBRA       ,IKET       ,IREVER)
                               FIL_PM(IBRA       ,IKET       ,IREVER,1)=
     *                         PNM_PM(IBRA+LDBASE,IKET+LDBASE,IREVER)
C
                           END IF
C
                        END DO
                     END DO
                  END DO
C
              END IF
C
          ELSE
C
              IF (JTWCEN.EQ.1) THEN
C
              READ (NFIFIP)((((FIL_PP(IBRA,IKET,IREVER,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
              ELSEIF(JTWCEN.EQ.2) THEN
C
              READ (NFIFIP)(((((FITWPP(IBRA,IKET,IREVER,LTWCEN,ICHARG),
     *                                            ICHARG=0,NDISOS),
     *                                            IREVER=0,NDREVE),
     *                                IKET=1,LDBATW(IND2HR(LTWCEN))),
     *                                IBRA=1,LDBATW(IND2HL(LTWCEN))),
     *                                            LTWCEN=1,NDTWBL)
C
              END IF
C
              IF (JSIMPY.NE.1) THEN
C
                  IF (ISIMPY.NE.1) THEN
C
                      IF (JTWCEN.EQ.1) THEN
C
                      READ (NFIFIP)((((FIL_PM(IBRA,IKET,IREVER,ICHARG),
     *                                                ICHARG=0,NDISOS),
     *                                         IREVER=0,NDREVE),
     *                                    IKET=1,LDBASE),
     *                               IBRA=1,LDBASE)
C
C TWO-CENTER BASIS IS ONLY IMPLEMENT FOR SIMPLEX BREAKING CASE
C
                      ELSEIF (JTWCEN.EQ.2) THEN
C
              READ (NFIFIP)(((((FITWPM(IBRA,IKET,IREVER,LTWCEN,ICHARG),
     *                                            ICHARG=0,NDISOS),
     *                                            IREVER=0,NDREVE),
     *                                IKET=1,LDBATW(IND2HR(LTWCEN))),
     *                                IBRA=1,LDBATW(IND2HL(LTWCEN))),
     *                                            LTWCEN=1,NDTWBL)
C
                      END IF
C
                  ELSE
C
                      IF (JTWCEN.EQ.2)
     *                STOP 'CANNOT READ FIELDS FOR JTWCEN=2/ISIMPY=1'
C
                      READ (NFIFIP)((((CDUMMY,
     *                                                ICHARG=0,NDISOS),
     *                                         IREVER=0,NDREVE),
     *                                    IKET=1,LDBASE),
     *                               IBRA=1,LDBASE)
C
                  END IF
C
              ELSE
C
                  IF (JTWCEN.EQ.2)
     *            STOP 'CANNOT READ FIELDS FOR JTWCEN=2/JSIMPY=1'
C
                  IF (ISIMPY.NE.1) FIL_PM=C_ZERO
C
              END IF
C
              IF (IPNMIX.EQ.1) THEN
C
                  IF (JTWCEN.EQ.2)
     *            STOP 'CANNOT READ FIELDS FOR JTWCEN=2/IPNMIX=1'
C
                  DO IREVER=0,NDREVE
                     DO IKET=1,LDBASE
                        DO IBRA=1,LDBASE
C
                           PNM_PP(IBRA       ,IKET       ,IREVER)=
     *                     FIL_PP(IBRA       ,IKET       ,IREVER,0)
                           PNM_PP(IBRA+LDBASE,IKET+LDBASE,IREVER)=
     *                     FIL_PP(IBRA       ,IKET       ,IREVER,1)
                           PNM_PP(IBRA+LDBASE,IKET       ,IREVER)=C_ZERO
                           PNM_PP(IBRA       ,IKET+LDBASE,IREVER)=C_ZERO
C
                           IF (ISIMPY.NE.1) THEN
C
                           PNM_PM(IBRA       ,IKET       ,IREVER)=
     *                     FIL_PM(IBRA       ,IKET       ,IREVER,0)
                           PNM_PM(IBRA+LDBASE,IKET+LDBASE,IREVER)=
     *                     FIL_PM(IBRA       ,IKET       ,IREVER,1)
                           PNM_PM(IBRA+LDBASE,IKET       ,IREVER)=C_ZERO
                           PNM_PM(IBRA       ,IKET+LDBASE,IREVER)=C_ZERO
C
                           END IF
C
                        END DO
                     END DO
                  END DO
C
              END IF
C
          END IF
C
C=======================================================================
C         READING THE PAIRING FIELDS
C=======================================================================
C
          IF (JPAHFB.GE.1) THEN
C
              IF (IPAHFB.GE.1) THEN
C
                  IF (JTWCEN.EQ.1) THEN
C
                      READ (NFIFIP)((((FIPIDE(IBRA,IKET,IREVER,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
                  ELSEIF (JTWCEN.EQ.2) THEN
C
              READ (NFIFIP)(((((FITWDE(IBRA,IKET,IREVER,LTWCEN,ICHARG),
     *                                            ICHARG=0,NDISOS),
     *                                            IREVER=0,NDREVE),
     *                                IKET=1,LDBATW(IND2HR(LTWCEN))),
     *                                IBRA=1,LDBATW(IND2HL(LTWCEN))),
     *                                            LTWCEN=1,NDTWBL)
C
                  END IF
C
                  IF (MVEFIL.GE.3) THEN
C
                      READ (NFIFIP) KIP2PP
C
                      IF (KIP2PP.EQ.1) THEN
C
C  ONLY FOR ONE-CENTER. NOT INTENDED
C
                          IF (JTWCEN.EQ.1) THEN
C
                          IF (REA2PP) THEN
C
                              READ (NFIFIP)((((FIP2DE(IBRA,IKET,IREVER,
     *                                                          ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
                          ELSE
C
                              READ (NFIFIP)((((CDUMMY,
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
                          END IF
C
                          END IF
C
                      ELSE
C
                          IF (REA2PP) FIP2DE=FIPIDE
C
                      END IF
C
                  ELSE
C
                      IF (REA2PP) FIP2DE=FIPIDE
C
                  END IF
C
C                 ISGOGP=1
                  ISREGP=1
C
              ELSE
C
                  IF (JTWCEN.EQ.1) THEN
C
                      READ (NFIFIP)((((CDUMMY,
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
                  END IF
C
              END IF
C
          ELSE
C
              IF (IPAHFB.GE.1) THEN
C
                              FIPIDE(:,:,:,:)=C_ZERO
                  IF (REA2PP) FIP2DE(:,:,:,:)=C_ZERO
C
                  IF (ITWCEN.EQ.2) FITWDE=C_ZERO
C
              END IF
C
C             ISGOGP=0
              ISREGP=0
C
          END IF
C
      ELSE
C
C=======================================================================
C     INPFIL - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER NFIFIC WILL  BE
C                          USED TO  R E C O R D  THE MEAN FIELDS
C=======================================================================
C
          REWIND(UNIT=NFIFIC,IOSTAT=IERROR)
C
          IF (IERROR.NE.0) STOP 'ERROR IN REWINDING (4)'
C
          WRITE(NFIFIC) IVEFIL,LDBTOT
C
          IVEFIP=IVEFIL
C
          WRITE(NFIFIC) ITWCEN
C
C=======================================================================
C         WRITING THE HARMONIC-OSCILLATOR FREQUENCIES
C=======================================================================
C
          WRITE(NFIFIC) HBAROX(1),HBAROY(1),HBAROZ(1)
C
          IF (ITWCEN.EQ.2) WRITE(NFIFIC) HBAROX(ITWCEN),HBAROY(ITWCEN),
     *                                                  HBAROZ(ITWCEN)
C
C=======================================================================
C         WRITING THE HARMONIC-OSCILLATOR LEMGTHS
C=======================================================================
C
          WRITE(NFIFIC) HOMSCA(1,1),HOMSCA(2,1),HOMSCA(3,1)
C
          IF (ITWCEN.EQ.2) WRITE(NFIFIC) HOMSCA(1,ITWCEN),
     *                                   HOMSCA(2,ITWCEN),
     *                                   HOMSCA(3,ITWCEN)
C
C=======================================================================
C         WRITING THE BASIS QUANTUM NUMBERS
C=======================================================================
C
          DO IBASE=1,LDBATW(1)
C
           WRITE(NFIFIC) NXVECT(IBASE,1),NYVECT(IBASE,1),NZVECT(IBASE,1)
C
          END DO
C
          IF (ITWCEN.EQ.2) THEN
C
              DO IBASE=1,LDBATW(ITWCEN)
C
                 WRITE(NFIFIC) NXVECT(IBASE,ITWCEN),
     *                         NYVECT(IBASE,ITWCEN),
     *                         NZVECT(IBASE,ITWCEN)
C
              END DO
C
          END IF
C
C=======================================================================
C         WRITING THE SYMMETRY SWITCHES
C=======================================================================
C
          WRITE(NFIFIC) ISIMPY,IPAHFB
          WRITE(NFIFIC) IPNMIX
C
C=======================================================================
C         WRITING THE MEAN FIELDS
C=======================================================================
C
          IF (IPNMIX.EQ.1) THEN
C
              WRITE(NFIFIC)(((PNM_PP(IBRA,IKET,IREVER),
     *                                         IREVER=0,NDREVE),
     *                                    IKET=1,2*LDBASE),
     *                               IBRA=1,2*LDBASE)
C
              IF (ISIMPY.NE.1) THEN
C
                  WRITE(NFIFIC)(((PNM_PM(IBRA,IKET,IREVER),
     *                                             IREVER=0,NDREVE),
     *                                        IKET=1,2*LDBASE),
     *                                   IBRA=1,2*LDBASE)
C
              END IF
C
          ELSE
C
              IF (ITWCEN.EQ.1)
     *        WRITE(NFIFIC)((((FIL_PP(IBRA,IKET,IREVER,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
              IF (ITWCEN.EQ.2)
     *        WRITE(NFIFIC)(((((FITWPP(IBRA,IKET,IREVER,LTWCEN,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                   IKET=1,LDBATW(IND2HR(LTWCEN))),
     *                              IBRA=1,LDBATW(IND2HL(LTWCEN))),
     *                         LTWCEN=1,NDTWBL)
C
              IF (ISIMPY.NE.1) THEN
C
                  IF (ITWCEN.EQ.1)
     *             WRITE(NFIFIC)((((FIL_PM(IBRA,IKET,IREVER,ICHARG),
     *                                            ICHARG=0,NDISOS),
     *                                     IREVER=0,NDREVE),
     *                                IKET=1,LDBASE),
     *                           IBRA=1,LDBASE)
C
              IF (ITWCEN.EQ.2)
     *        WRITE(NFIFIC)(((((FITWPM(IBRA,IKET,IREVER,LTWCEN,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                   IKET=1,LDBATW(IND2HR(LTWCEN))),
     *                              IBRA=1,LDBATW(IND2HL(LTWCEN))),
     *                         LTWCEN=1,NDTWBL)
              END IF
C
          END IF
C
C=======================================================================
C         WRITING THE PAIRING FIELDS
C=======================================================================
C
          IF (IPAHFB.GE.1) THEN
C
              IF (ITWCEN.EQ.1)
     *        WRITE(NFIFIC)((((FIPIDE(IBRA,IKET,IREVER,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
              IF (ITWCEN.EQ.2)
     *        WRITE(NFIFIC)(((((FITWDE(IBRA,IKET,IREVER,LTWCEN,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                   IKET=1,LDBATW(IND2HR(LTWCEN))),
     *                              IBRA=1,LDBATW(IND2HL(LTWCEN))),
     *                         LTWCEN=1,NDTWBL)
C
              IF (REA2PP) THEN
C
                                KIP2PP=1
                  WRITE(NFIFIC) KIP2PP
C
                  WRITE(NFIFIC)((((FIP2DE(IBRA,IKET,IREVER,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
              ELSE
                                KIP2PP=0
                  WRITE(NFIFIC) KIP2PP
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECQUA(NFIQUA,ISIMPY,IPAHFB,IPNMIX)
C=======================================================================
      USE SAVQUA
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
C
      DATA
     *     IVEQUA /1/
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
      REWIND(UNIT=NFIQUA,IOSTAT=IERROR)
C
      IF (IERROR.NE.0) STOP 'ERROR IN REWINDING NFIQUA'
C
      WRITE(NFIQUA) IVEQUA,LDBASE
C
C=======================================================================
C         WRITING THE HARMONIC-OSCILLATOR FREQUENCIES
C=======================================================================
C
      WRITE(NFIQUA) HBAROX(1),HBAROY(1),HBAROZ(1)
C
C=======================================================================
C         WRITING THE HARMONIC-OSCILLATOR LENGTHS
C=======================================================================
C
      WRITE(NFIQUA) HOMSCA(1,1),HOMSCA(2,1),HOMSCA(3,1)
C
C=======================================================================
C         WRITING THE BASIS QUANTUM NUMBERS
C=======================================================================
C
      DO IBASE=1,LDBASE
C
         WRITE(NFIQUA) NXVECT(IBASE,1),NYVECT(IBASE,1),NZVECT(IBASE,1)
C
      END DO
C
C=======================================================================
C         WRITING THE SYMMETRY SWITCHES
C=======================================================================
C
      WRITE(NFIQUA) ISIMPY,IPAHFB
      WRITE(NFIQUA) IPNMIX
C
C=======================================================================
C         WRITING THE NUMBERS OF QUASIPARTICLE WAVE FUNCTIONS
C=======================================================================
C
      WRITE(NFIQUA) ((NUMBQP(IREVER,ICHARG),IREVER=0,NDREVE),
     *                                      ICHARG=0,NDISOS)
C
C=======================================================================
C         WRITING THE QUASIPARTICLE WAVE FUNCTIONS
C=======================================================================
C
      IF (IPNMIX.EQ.1) THEN
C
          STOP ' IPNMIX.EQ.1 NOT IMPLEMENTED YET IN RECQUA'
C
          WRITE(NFIQUA)
C
      ELSE
C
          WRITE(NFIQUA)((((BSVQUA(IBASE,ISTAT,0,ICHARG),IBASE=1,LDBASE),
     *                                   ISTAT=1,NUMBQP(IREVER,ICHARG)),
     *                                IREVER=0,NDREVE),
     *                             ICHARG=0,NDISOS)
C
          WRITE(NFIQUA)((((BSVQUA(IBASE,ISTAT,1,ICHARG),IBASE=1,LDBASE),
     *                                   ISTAT=1,NUMBQP(IREVER,ICHARG)),
     *                                IREVER=0,NDREVE),
     *                             ICHARG=0,NDISOS)
C
          WRITE(NFIQUA)((((ASVQUA(IBASE,ISTAT,0,ICHARG),IBASE=1,LDBASE),
     *                                   ISTAT=1,NUMBQP(IREVER,ICHARG)),
     *                                IREVER=0,NDREVE),
     *                             ICHARG=0,NDISOS)
C
          WRITE(NFIQUA)((((ASVQUA(IBASE,ISTAT,1,ICHARG),IBASE=1,LDBASE),
     *                                   ISTAT=1,NUMBQP(IREVER,ICHARG)),
     *                                IREVER=0,NDREVE),
     *                             ICHARG=0,NDISOS)
C
          IF (ISIMPY.NE.1) THEN
C
              STOP ' ISIMPY.NE.1 NOT IMPLEMENTED YET IN RECQUA'
C
              WRITE(NFIQUA)
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERCOU(ICOUDI,ICOUEX,I_COUA,ICOUPA,NEWCOU)
C=======================================================================
      USE HCOULO
      USE COUSTO
      USE CPASTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      ALLOCATION AND INITIALIZATION OF COULOMB MEAN-FIELD AND PAIRING
C      FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IF (ICOUDI.EQ.1) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(HPPCOU)) THEN
              ALLOCATE (HPPCOU(1:NDBASE,1:NDBASE),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('HPPCOU','ZERCOU')
          END IF
C
C          Array HPMCOU must be allocated even if ISIMPY=0, because  an
C          allocatable array can not be passed as a subroutine argument
C          if not allocated (use pointers instead). HPMCOU is passed to
C          routine INTCOU in routine COUMAT.
C
          IF (.NOT.ALLOCATED(HPMCOU)) THEN
              ALLOCATE (HPMCOU(1:NDBASE,1:NDBASE),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('HPMCOU','ZERCOU')
          END IF
C
          HPPCOU(:,:)=C_ZERO
          HPMCOU(:,:)=C_ZERO
C
      END IF
C
C=======================================================================
C
      IF (ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.
     *   (I_COUA.GE.2.AND.NEWCOU.EQ.1)) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(COULSV)) THEN
              ALLOCATE (COULSV(NDBASE,NDBASE,0:NDKART,
     *                                         NDTWBL),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('COULSV','ZERCOU')
          END IF
C
          COULSV=C_ZERO
C
      END IF
C
C=======================================================================
C
      IF (ICOUPA.EQ.2.AND.NEWCOU.EQ.1) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(COUPSV)) THEN
              ALLOCATE (COUPSV(NDBASE,NDBASE,0:NDKART),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('COUPSV','ZERCOU')
          END IF
C
          COUPSV(:,:,:)=C_ZERO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERYUK
C=======================================================================
      USE YUKSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE YUKAWA MEAN-FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(YUKASV)) THEN
          ALLOCATE (YUKASV(1:NDBASE,1:NDBASE,0:NDKART,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('YUKASV','ZERYUK')
      END IF
C
      YUKASV(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERGOG
C=======================================================================
      USE GOGSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE GOGNY MEAN-FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(GOGASV)) THEN
          ALLOCATE (GOGASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGASV','ZERGOG')
      END IF
C
      GOGASV(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERGPA
C=======================================================================
      USE GOGKAP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE GOGNY PAIRING FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(GOGCHI)) THEN
          ALLOCATE (GOGCHI(NDBASE,NDBASE,0:NDKART,0:NDISOS),
     *                                         STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGCHI','ZERGPA')
      END IF
C
      GOGCHI(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERREG
C=======================================================================
      USE REGSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE REGULARIZED SKYRME MEAN-FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(REGASV)) THEN
          ALLOCATE (REGASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REGASV','ZERREG')
      END IF
C
      REGASV(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERSEP(LDPNMX)
C=======================================================================
      USE SEPSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE SEPARABLE MEAN-FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(SEPASV)) THEN
          ALLOCATE (SEPASV(NDBASE,NDBASE,0:NDKART,0:LDPNMX),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SEPASV','ZERSEP')
      END IF
C
      SEPASV(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERFST
C=======================================================================
      USE FSTSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE SPIN-ORBIT/TENSOR MEAN-FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(FSTASV)) THEN
          ALLOCATE (FSTASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FSTASV','ZERFST')
      END IF
C
      FSTASV(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERRPA
C=======================================================================
      USE RPASTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE REGULARIZED SKYRME PAIRING FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(REGPSV)) THEN
          ALLOCATE (REGPSV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REGPSV','ZERRPA')
      END IF
C
      REGPSV(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERSPA(LDPNMX)
C=======================================================================
      USE SPASTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE SEPARABLE PAIRING FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(SEPPSV)) THEN
          ALLOCATE (SEPPSV(NDBASE,NDBASE,0:NDKART,0:LDPNMX),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SEPPSV','ZERSPA')
      END IF
C
      SEPPSV(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERFPA
C=======================================================================
      USE FPASTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C      THIS ROUTINE INITIALIZES THE SPIN-ORBIT/TENSOR PAIRING FIELD
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(FSTPSV)) THEN
          ALLOCATE (FSTPSV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FSTPSV','ZERFPA')
      END IF
C
      FSTPSV(:,:,:,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECLIP(NFILIP,NFILIC,INPLIP,ISIMPY)
C=======================================================================
      USE MLI_PP
      USE MLI_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /ISDLIP/ IS_DLI(0:NDISOS)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(DLI_PP).AND.INPLIP.EQ.1) THEN
          ALLOCATE (DLI_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DLI_PP','RECLIP')
      END IF
      IF (.NOT.ALLOCATED(DLI_PM).AND.ISIMPY.NE.1.AND.INPLIP.EQ.1) THEN
          ALLOCATE (DLI_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DLI_PM','RECLIP')
      END IF
C
C=======================================================================
C     INPLIP - IF .NE.0 => THE FILE WITH THE UNIT NUMBER  NFILIP WILL BE
C                          USED  TO   R E A D   THE   DENSITY   MATRICES
C=======================================================================
C
      IF (INPLIP.NE.0) THEN
C
          REWIND(UNIT=NFILIP,IOSTAT=IERROR)
C
          IF (IERROR.NE.0) STOP 'ERROR IN REWINDING (5)'
C
          READ (NFILIP) MDBASE
C
          IF (MDBASE.NE.LDBASE) THEN
C
              WRITE(NFIPRI,'(/,
     *             1X,10(1H/),'' INCOMPATIBLE DIMENSIONS'',
     *                        '' FOUND ON THE'',         1X,10(1H/),/,
     *             1X,10(1H/),'' LIPKIN FILE,'',
     *                        '' LDBASE='',I4,'' MDBASE='',I4,
     *                                                   1X,10(1H/),/)')
     *             LDBASE,MDBASE
C
              STOP 'MDBASE.NE.LDBASE IN RECLIP'
C
          END IF
C
          READ (NFILIP)((((DLI_PP(IBRA,IKET,IREVER,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      IREVER=0,NDREVE),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
          IF (ISIMPY.NE.1) THEN
C
              READ (NFILIP)((((DLI_PM(IBRA,IKET,IREVER,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
          END IF
C
          IS_DLI(0)=1
          IS_DLI(1)=1
C
      ELSE
C
C=======================================================================
C     INPLIP - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER  NFILIP WILL BE
C                          USED   TO   RECORD   THE   DENSITY   MATRICES
C=======================================================================
C
          REWIND(UNIT=NFILIC,IOSTAT=IERROR)
C
          IF (IERROR.NE.0) STOP 'ERROR IN REWINDING (6)'
C
          WRITE(NFILIC) LDBASE
C
          IF (IS_DLI(0).NE.1.OR.IS_DLI(1).NE.1)
     *                                       STOP ' NO DLI_PP IN RECLIP'
C
          WRITE(NFILIC)((((DLI_PP(IBRA,IKET,IREVER,ICHARG),
     *                                             ICHARG=0,NDISOS),
     *                                      IREVER=0,NDREVE),
     *                                 IKET=1,LDBASE),
     *                            IBRA=1,LDBASE)
C
          IF (ISIMPY.NE.1) THEN
C
              WRITE(NFILIC)((((DLI_PM(IBRA,IKET,IREVER,ICHARG),
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
          ELSE
C
C
              WRITE(NFILIC)((((C_ZERO,
     *                                                 ICHARG=0,NDISOS),
     *                                          IREVER=0,NDREVE),
     *                                     IKET=1,LDBASE),
     *                                IBRA=1,LDBASE)
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERLIP(ISIMPY,IFCONT)
C=======================================================================
      USE MLI_PP
      USE MLI_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
      COMMON
     *       /ISDLIP/ IS_DLI(0:NDISOS)
C
C=======================================================================
C     THIS ROUTINE INITIALIZES THE DENSITY MATRIX TO ZERO
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(DLI_PP)) THEN
          ALLOCATE (DLI_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DLI_PP','ZERLIP')
      END IF
      IF (.NOT.ALLOCATED(DLI_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (DLI_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DLI_PM','ZERLIP')
      END IF
C
      DLI_PP(:,:,:,:)=C_ZERO
      IF (ISIMPY.NE.1) THEN
          DLI_PM(:,:,:,:)=C_ZERO
      END IF
C
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.83R) AND (2.89) THE SWITCHES
C                       BELOW WERE INCORRECTLY SET TO 1,  WHICH  WRONGLY
C                       IMPLIED THAT THE DENSITY MATRICES  USED  IN  THE
C                       LIPKIN METHOD WERE PRESENT IN THE MEMORY, WHREAS
C                       THEY HAVE BEEN MERLY  ALLOCATED.  AS  A  RESULT,
C                       AFTER A CONTINUATION  FROM  FIELDS,  THE  LIPKIN
C                       COULD NOT BE SMOOTHLY CONTINUED.
C                       THIS BUG WAS CORRECTED ON 11/03/2019 IN  VERSION
C                       (2.89A).
C                       NOTE ALSO  THAN  EVEN  NOW  A  PERFECTLY  SMOOTH
C                       CONTINUATION IS NOT POSSIBLE, BECAUSE THE MIXING
C                       OF NEW AND OLD DENSITY MATRICES CANNOT BE  DONE.
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.89A) AND (3.04G)THE SWITCHES
C                       BELOW WERE INCORRECTLY ALWAYS SET  TO  0,  WHICH
C                       MADE IT IMPOSSIBLE TO INITIATE THE LIPKIN-NOGAMI
C                       CALCULATIONS AFTER A PREVIOUS RUN WHERE  NEITHER
C                       THE LIPKIN NOR FIELDS FILE WAS SAVED.
C                       THIS BUG WAS CORRECTED ON 29/03/2021 IN  VERSION
C                       (3.04H).
C=======================================================================
C
      IF (IFCONT.EQ.1) THEN
C
          IS_DLI=0
      ELSE
          IS_DLI=1
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERLIN(ISIMPY,IPAIRI)
C=======================================================================
      USE ALISTO
      USE PLISTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(ALINPP)) THEN
          ALLOCATE (ALINPP(NDBASE,NDBASE,1:NDKART,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ALINPP','ZERLIN')
      END IF
      IF (.NOT.ALLOCATED(ALINPM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (ALINPM(NDBASE,NDBASE,1:NDKART,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ALINPM','ZERLIN')
      END IF
C
      ALINPP(:,:,:,:,:)=C_ZERO
C
      IF (ISIMPY.NE.1) THEN
          ALINPM(:,:,:,:,:)=C_ZERO
      END IF
C
      IF (IPAIRI.EQ.1) THEN
C
          IF (.NOT.ALLOCATED(PLINPM)) THEN
              ALLOCATE (PLINPM(NDBASE,NDBASE,1:NDKART,0:NDREVE,
     *                                       0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('PLINPM','ZERLIN')
          END IF
          IF (.NOT.ALLOCATED(PLINPP).AND.ISIMPY.NE.1) THEN
              ALLOCATE (PLINPP(NDBASE,NDBASE,1:NDKART,0:NDREVE,
     *                                       0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('PLINPP','ZERLIN')
          END IF
C
          PLINPM(:,:,:,:,:)=C_ZERO
C
          IF (ISIMPY.NE.1) THEN
              PLINPP(:,:,:,:,:)=C_ZERO
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZERROT(ISIMPY,IPAIRI)
C=======================================================================
      USE AROSTO
      USE PROSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(AROTPP)) THEN
          ALLOCATE (AROTPP(NDBASE,NDBASE,1:NDKART,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('AROTPP','ZERROT')
      END IF
      IF (.NOT.ALLOCATED(AROTPM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (AROTPM(NDBASE,NDBASE,1:NDKART,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('AROTPM','ZERROT')
      END IF
C
      AROTPP(:,:,:,:,:)=C_ZERO
      IF (ISIMPY.NE.1) THEN
          AROTPM(:,:,:,:,:)=C_ZERO
      END IF
C
      IF (IPAIRI.EQ.1) THEN
C
          IF (.NOT.ALLOCATED(PROTPM)) THEN
              ALLOCATE (PROTPM(NDBASE,NDBASE,1:NDKART,0:NDREVE,
     *                                       0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('PROTPM','ZERROT')
          END IF
          IF (.NOT.ALLOCATED(PROTPP).AND.ISIMPY.NE.1) THEN
              ALLOCATE (PROTPP(NDBASE,NDBASE,1:NDKART,0:NDREVE,
     *                                       0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('PROTPP','ZERROT')
          END IF
C
          PROTPM(:,:,:,:,:)=C_ZERO
          IF (ISIMPY.NE.1) THEN
              PROTPP(:,:,:,:,:)=C_ZERO
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TESDAT(IOPTGS,NOSCIL,NLIMIT,ISTAND,
     *                  KETA_J,KETA_W,KETACM,KETA_M,
     *                         KETA_P,KETA_T,KETAPA,
     *                         JETACM,JETA_T,JETAPA,
     *                                       NOZEPA,
     *                                ITWOLI,KETA_R,
     *                                KETAJ2,KETAT2,
     *                         ISIMPY,ISIGNY,ISIQTY,
     *                         ISIMTX,JSIMTY,ISIMTZ,
     *                                       IAXIAP,
     *                         NMUCON,NMUCOU,NMUPRI,
     *                                ICOUMD,ICOUMX,
     *                  ISCHIF,NSICON,NSIPRI,IDOPLM,
     *                         NMACON,NMAPRI,NMAORD,
     *                         NASCON,NASPRI,NASORD,
     *                                       NRAORD,
     *                  NMURED,NMARED,NASRED,NSIRED,
     *                         NEXBET,IPRIBE,IPRIBL,
     *                  NUPING,EPSPNG,EPSITE,EPSCON,
     *                                NULAST,NUCONS,
     *                  ISYMDE,INIROT,INIINV,INIKAR,
     *                                IWRIOL,IWRIBA,
     *                                IRENMA,IRENIN,
     *                  IFRWAV,ITOWAV,IWRWAV,ISAKER,
     *           ISLPRI,ISUPRI,IENPRI,ISRPRI,IMIPRI,
     *                         IKEPRI,IRMPRI,IELPRI,
     *                  QMUCUT,QMACUT,QASCUT,QSICUT,
     *                         IPRGCM,IPROMI,IPROMA,
     *                         NUAKNO,NUBKNO,KPROJE,
     *                         NATKNO,NBTKNO,ISOSTZ,
     *                  NPNKNO,NTZKNO,NPAKNO,IPAPRO,
     *           IFERME,IBETME,IIFERR,ITFERR,ISFERR,
     *           ISOSAD,ISOSMI,ISOSMA,EPSISO,ICSKIP,
     *                  IPAKER,IPAK3D,IPAALL,KFIKER,
     *                  NUASTA,NUASTO,NUGSTA,NUGSTO,
     *                  NATSTA,NATSTO,NGTSTA,NGTSTO,
     *                  NUBSTA,NUBSTO,NUTSTA,NUTSTO,
     *                         ICHFLI,IPAFLI,IREFLI,
     *                         ISPFLI,ISHFLI,IFLIPI,
     *                                NOITER,IREAWS,
     *                         ILIBAS,IN_FIX,IZ_FIX,
     *                                INNUMB,IZNUMB,
     *                                       IDESTA,
     *                  IMOVAX,ITILAX,ITISAX,NO_ORB,
     *                                IQUNIL,NILXYZ,
     *                         MREVER,IROTAT,IQPSTA,
     *                         IPAIRI,IPAHFB,JPABCS,
     *                  IONISH,ITWOBA,NUQEVE,IMFHFB,
     *                         ECUTOF,LIMQUA,LAMCUT,
     *                                       IPNMIX,
     *                                LIPKIN,LIPKIP,
     *                                LIPNON,LIPNOP,
     *                         IPNPRJ,NPPNPN,NPPNPP,
     *           I_SLOW,SLOWEV,SLOWOD,SLOWPA,SLOWLM,
     *                                IFEFIN,IFEFIP,
     *                                IF2FIN,IF2FIP,
     *                                IFERAN,IFERAP,
     *                                IDEFIN,IDEFIP,
     *                  INSIGN,IPSIGN,ISSIGN,IDSIGN,
     *                  INSIGP,IPSIGP,ISSIGP,IDSIGP,
     *                         INSIMN,IRSIMN,IDSIMN,
     *                         INSIMP,IRSIMP,IDSIMP,
     *                         INSIQN,IPSIQN,IDSIQN,
     *                         INSIQP,IPSIQP,IDSIQP,
     *                                INSIZN,IDSIZN,
     *                                INSIZP,IDSIZP,
     *                                IFIBLN,INIBLN,
     *                                IFIBLP,INIBLP,
     *                  ICOTYP,ICOUDI,ICOUEX,ICOULO,
     *                                IYUTYP,I_YUKA,
     *                                I_GOGA,IGOGPA,
     *                                I_REGA,IREGPA,
     *                                I_SEPA,ISEPPA,
     *                                I_COUA,ICOUPA,
     *                                N3LORD,N3SERD,
     *                         ICONTI,IPCONT,IOCONT,
     *                         ISCONT,ITCONT,IACONT,
     *                  IYCONT,IGCONT,IGPCON,IECONT,
     *                  ILCONT,IFCONT,IMCONT,IRCONT,
     *           IFSHEL,IF_RPA,IWRIQU,IWRIRM,IF_THO,
     *                                LDPNMX,SKYRME,
     *                                IFRAGM,MIN_QP,
     *                         ILIPON,ILIPOP,GAUSHI,
     *           NLSIGN,NLSIMN,NLSIQN,NLSIZN,MXALIN,
     *           NLSIGP,NLSIMP,NLSIQP,NLSIZP,MXALIP,
     *                                LASTAN,LASTAP,
     *                                       ITWCEN,
     *                                       IADBAT,
     *                                NEWGOG,NEWCOU,
     *                                IPOTHO,IVIPRI,
     *                                       IFRCNT)
C=======================================================================
      USE hfodd_sizes
      USE colcoord
C=======================================================================
      PARAMETER (NDMORD=3)
      PARAMETER (NDF2BC=5)
      PARAMETER (NDFANL=2)
      PARAMETER (NDFSTA=3)
C=======================================================================
C
      DIMENSION
     *          NUMPAR(0:NDISOS),
     *          NEGSIZ(0:NDISOS),
     *          NEGSIQ(0:NDISOS)
      DIMENSION
     *          NUPPAR(0:NDPARI,0:NDISOS)
      DIMENSION
     *          INSIZN(1:NDBLOC),IDSIZN(1:NDBLOC),
     *          INSIZP(1:NDBLOC),IDSIZP(1:NDBLOC)
      DIMENSION
     *          INSIQN(1:NDBLOC),IPSIQN(1:NDBLOC),IDSIQN(1:NDBLOC),
     *          INSIQP(1:NDBLOC),IPSIQP(1:NDBLOC),IDSIQP(1:NDBLOC)
C
      CHARACTER
     *          SKYRME*4
      CHARACTER
     *          ERRSTR*68,ERRALL*68
      CHARACTER
     *          FILLEF*68,FILRIG*68
      CHARACTER
     *          NIBLOL*15
C
      COMMON
     *       /ERRDAT/ ERRALL(1:NDERRO)
      COMMON
     *       /SIGNVA/ NVASIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMNVA/ NVASIM(         0:NDREVE,0:NDISOS)
      COMMON
     *       /SIQNVA/ NVASIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /MIGNVA/ NVAMIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /MIMNVA/ NVAMIM(0:NDREVE)
      COMMON
     *       /MIQNVA/ NVAMIQ(0:NDPARI)
      COMMON
     *       /N_FLIG/ NPFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFLIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIM/ NPFLIM(         0:NDREVE,0:NDISOS),
     *                NHFLIM(         0:NDREVE,0:NDISOS),
     *                NOFLIM(         0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIQ/ NPFLIQ(0:NDPARI,         0:NDISOS),
     *                NHFLIQ(0:NDPARI,         0:NDISOS),
     *                NOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /N_FLIZ/ NPFLIZ(                  0:NDISOS),
     *                NHFLIZ(                  0:NDISOS),
     *                NOFLIZ(                  0:NDISOS)
      COMMON
     *       /N_MLIG/ NPMLIG(0:NDPARI,0:NDREVE),
     *                NHMLIG(0:NDPARI,0:NDREVE),
     *                NOMLIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MLIM/ NPMLIM(0:NDREVE),
     *                NHMLIM(0:NDREVE),
     *                NOMLIM(0:NDREVE)
      COMMON
     *       /N_MLIQ/ NPMLIQ(0:NDPARI),
     *                NHMLIQ(0:NDPARI),
     *                NOMLIQ(0:NDPARI)
      COMMON
     *       /N_MLIZ/ NPMLIZ,
     *                NHMLIZ,
     *                NOMLIZ
      COMMON
     *       /N_FILG/ NPFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFILG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FILZ/ NPFILZ(                  0:NDISOS),
     *                NHFILZ(                  0:NDISOS),
     *                NOFILZ(                  0:NDISOS)
      COMMON
     *       /SIGOCC/ N_OCCU(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS),
     *                N_OCVA(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMOCC/ L_OCCU(1:NDSTAT,0:NDREVE,0:NDISOS),
     *                L_OCVA(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIQOCC/ K_OCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *                K_OCVA(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIZOCC/ M_OCCU(1:2*NDSTAT,0:NDISOS),
     *                M_OCVA(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /MIGOCC/ NMOCCU(1:2*NDSTAT,0:NDPARI,0:NDREVE),
     *                NMOCVA(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIMOCC/ LMOCCU(1:2*NDSTAT,0:NDREVE),
     *                LMOCVA(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /MIQOCC/ KMOCCU(1:4*NDSTAT,0:NDPARI),
     *                KMOCVA(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /MIZOCC/ MMOCCU(1:4*NDSTAT),
     *                MMOCVA(1:4*NDSTAT)
      COMMON
     *       /SIQALR/ LALSIQ(-NDALIB:NDALIB,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIZALR/ LALSIZ(-NDALIB:NDALIB,0:NDISOS)
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VCNSTR/ STIFFV(0:NDMULT,-NDMULT:NDMULT),
     *                VASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /GCNSTR/ STIFFG(0:NDMULT),
     *                GASKED(0:NDMULT),
     *                IFLAGG(0:NDMULT)
      COMMON
     *       /SCNSTR/ STIFFS(0:NDMULT,-NDMULT:NDMULT),
     *                SASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VACCNF/ IVACUM
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /OMEGAS/ OMEGAX,OMEGAY,OMEGAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /IANGLE/ ALPINI,BETINI,GAMINI
      COMMON
     *       /ICNSTR/ STIFFI(1:NDKART),
     *                ASKEDI(1:NDKART),
     *                IFLAGI(1:NDKART)
      COMMON
     *       /ICNTTR/ STIFTI(1:NDKART),
     *                ASKETI(1:NDKART),
     *                IFTAGI(1:NDKART)
      COMMON
     *       /TCNSTR/ STIFFT(1:NDKART),
     *                ASKEDT(1:NDKART),
     *                IFLAGT(1:NDKART)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /ACNSTR/ STIFFA,ASKEDA,IFLAGA
      COMMON
     *       /ISOFER/ FERISO(0:NDKART)
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /CBRSWI/ I_2CBR,I_3CBR
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /BROINI/ IBROYD,N_ITER
      COMMON
     *       /REGBIN/ REGBCC(NDREGA,NDFORC),IREREG
      COMMON
     *       /SEPBIN/ SEPVIC(NDSEPA,NDFORC),IVISEP
      COMMON
     *       /SEPVER/ SEPERR(NDSEPA,NDFORC),IERSEP
      COMMON
     *       /SEPFAC/ SEPFAC(NDSEPA,NDFORC),IFASEP
      COMMON
     *       /IKETRA/ IKEINV,IKEKAR
      COMMON
     *       /JPA2HF/ DEL2HF(0:NDISOS),IPA2HF(0:NDISOS)
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /T_FLAG/ IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL
      COMMON
     *       /SCALAPACK_INP/ NBLOCK,MBLOCK,NPGRID,MPGRID,KZHPEV
C SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL - SL
      COMMON
     *       /EDFINP/ IF_EDF
      COMMON
     *       /ALLAST/ LASTAL(0:NDISOS)
      COMMON
     *       /ALLPRI/ IPRALL
      COMMON
     *       /CUSIZN/ NCUSIZ(0:NDISOS)
      COMMON
     *       /CUSIQN/ NCUSIQ(0:NDISOS,0:NDPARI)
      COMMON
     *       /BLOCNI/ NIBLOC(       0:NDISOS),NIBLOM(NDBLOC,0:NDISOS),
     *                NIBLOE(NDBLOC,0:NDISOS),NIBLOL(NDBLOC,0:NDISOS)
      COMMON
     *       /POWNMU/ NMUPOW
      COMMON
     *       /KERNAM/ FILLEF(NDCONF),FILRIG(NDCONF),NUCONF,NAMKER
      COMMON
     *       /ALCONF/ INCONF(NDCONF),ILCONF,MICONF(NDCONF),MIXNUM
      COMMON
     *       /DIQ_GA/ DIQCOD,DIQCOE,DIQCOP,IDIQGA
      COMMON
     *       /AUTOBA/ IBASIS
      COMMON
     *       /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /FORANL/ MAGANL(NDFANL)
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /FRCONS/ FRGSTF(0:NDISOS,1:NDTWCE),
     *                FRGASK(0:NDISOS,1:NDTWCE),
     *                IFLFRG(0:NDISOS,1:NDTWCE),
     *                CLMFRA(0:NDISOS,1:NDTWCE),
     *                AVEFRA(0:NDISOS,1:NDTWCE)
      COMMON
     *       /ROTFRG/ ALFFRA(1:NDTWCE),BETFRA(1:NDTWCE),
     *                GAMFRA(1:NDTWCE),IROFRG(1:NDTWCE)
      COMMON
     *       /BROMAT/ NOIINP,MIXMAT
      COMMON
     *       /ADBRUN/ IABNTE,IABCOL,IABICH,IABMOD,IFAMON
C
C=======================================================================
C         THIS SUBROUTINE PERFORMS VARIOUS TESTS ON THE INPUT DATA,
C         CORRECTS THE DATA WHERE POSSIBLE, AND PRINTS THE WARNINGS
C         OR STOPS THE CODE WHEN NECESSARY
C=======================================================================
C
      MAXTER=10
      IERROR=0
C
C=======================================================================
C
      IF (IBROYD.GE.1.AND.N_ITER.GT.MAXTER) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF N_ITER = '',I3,
     *                            ''     '',      1X,20(1H/),/,
     *                 1X,20(1H/),'' SHOULD NOT EXCEED  MAXTER = '',I3,
     *                            ''  OR '',      1X,20(1H/),/,
     *                 1X,20(1H/),'' OTHERWISE INCREASE MAXTER IN'',
     *                            '' BROYDEN'',   1X,20(1H/),/)')
     *           N_ITER,MAXTER
C
          ERRSTR=' INCORRECT VALUE OF N_ITER IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IN_FIX.LT.0.OR. IZ_FIX.LT.0.OR.
     *   (IN_FIX.EQ.0.AND.IZ_FIX.EQ.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IN_FIX ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IZ_FIX ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              IN_FIX,IZ_FIX
C
          ERRSTR=' INCORRECT VALUE OF IN_FIX OR IZ_FIX IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INNUMB.LT.0.OR. IZNUMB.LT.0.OR.
     *   (INNUMB.EQ.0.AND.IZNUMB.EQ.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INNUMB ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IZNUMB ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              INNUMB,IZNUMB
C
          ERRSTR=' INCORRECT VALUE OF INNUMB OR IZNUMB IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ILIBAS.LT.0.OR.ILIBAS.GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ILIBAS ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *    ILIBAS
C
          ERRSTR=' INCORRECT VALUE OF ILIBAS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ILIBAS.NE.3.AND.INPOME.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ILIBAS ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *    ILIBAS
C
          ERRSTR=' ILIBAS=3 IF INPOME=0 FOR ITWCEN=2'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NDCOUP.NE.24.OR.NDCOUT.NE.30) THEN
C
          WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' INSTEAD OF 24 THERE IS NDCOUP='',I2,
     *                           '' OR'',       1X,20(1H/),/,
     *                1X,20(1H/),'' INSTEAD OF 30 THERE IS NDCOUT='',I2,
     *                           ''   '',       1X,20(1H/),/)')
     *              NDCOUP,NDCOUT
C
          ERRSTR=' INCORRECT VALUE OF NDCOUP OR NDCOUT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Sanity check: if UNEDF functionals are requested, the Lipkin
C      Nogami prescription must be activated
C=======================================================================
C
      IF ((SKYRME.EQ.'UNE0'.OR.SKYRME.EQ.'UNE1'.OR.SKYRME.EQ.'UNE2')
     *                    .AND.(IF_EDF.EQ.0.OR.ISTAND.EQ.0)) THEN
C
          WRITE(NFIPRI,'(/,1X,16(''/''),45X,16(''/''),/,1X,
     *                  16(''/''),''  ERROR: UNEDF FUNCTIONAL'',
     *                  '' REQUESTED: '',A4,''    '',16(''/''),/,1X,
     *                  16(''/''),''  RESET FLAGS ISTAND=1'',
     *                  '' AND IF_EDF=1          '',16(''/''),/,1X,
     *                  16(''/''),45X,16(''/''))') SKYRME
C
          ERRSTR='UNE0/UNE1/UNE2 PARAMS. NEED IF_EDF=1 AND ISTAND=1'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Sanity check: if UNEDF functionals are requested, the flag
C      IF_EDF must be set to 1
C=======================================================================
C
      IF ((SKYRME.EQ.'UNE0'.OR.SKYRME.EQ.'UNE1'.OR.SKYRME.EQ.'UNE2')
     *                    .AND.(LIPKIN.EQ.0.OR.LIPKIP.EQ.0)) THEN
C
          WRITE(NFIPRI,'(/,1X,16(''/''),45X,16(''/''),/,1X,
     *                  16(''/''),''  ERROR: UNEDF FUNCTIONAL'',
     *                  '' REQUESTED: '',A4,''    '',16(''/''),/,1X,
     *                  16(''/''),''  LIPKIN-NOGAMI PRESCRIPTION'',
     *                  '' MUST BE ACTIVE  '',16(''/''),/,1X,
     *                  16(''/''),''  RESET FLAGS LIPKIN=1'',
     *                  '' AND LIPKIP=1          '',16(''/''),/,1X,
     *                  16(''/''),45X,16(''/''))') SKYRME
C
          ERRSTR='UNE0/UNE1/UNE2 PARAMS. NEED LIPKIN=1 AND LIPKIP=1'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISTAND.EQ.0.AND.((KETA_J.NE.0.AND.KETA_J.NE.1).OR.
     *                     (KETA_W.NE.0.AND.KETA_W.NE.1
     *                                 .AND.KETA_W.NE.2).OR.
     *                     (KETACM.NE.0.AND.KETACM.NE.1.AND.
     *                      KETACM.NE.2.AND.KETACM.NE.3).OR.
     *                     (KETA_M.NE.0.AND.KETA_M.NE.1
     *                                 .AND.KETA_M.NE.2).OR.
     *                     (KETA_P.NE.1.AND.KETA_P.NE.2).OR.
     *                     (KETA_T.NE.0.AND.KETA_T.NE.1
     *                                 .AND.KETA_T.NE.2).OR.
     *                     (KETAPA.NE.0.AND.KETAPA.NE.1
     *                                 .AND.KETAPA.NE.2))) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),''  INCORRECT STANDARD-FORCE'',
     *                            '' SWITCHES'',       2X,20(1H/),/,
     *                 1X,20(1H/),''  ISTAND ='',I2,6X,
     *                            ''          '',2X,   7X,20(1H/),/,
     *                 1X,20(1H/),''  KETA_J ='',I2,6X,
     *                            ''  KETA_W ='',I2,   7X,20(1H/),/,
     *                 1X,20(1H/),''  KETACM ='',I2,6X,
     *                            ''  KETA_M ='',I2,   7X,20(1H/),/,
     *                 1X,20(1H/),''  KETA_P ='',I2,6X,
     *                            ''  KETA_T ='',I2,   7X,20(1H/),/,
     *                 1X,20(1H/),''  KETAPA ='',I2,6X,
     *                            ''          '',2X,   7X,20(1H/),/)')
     *
     *    ISTAND,KETA_J,KETA_W,KETACM,KETA_M,KETA_P,KETA_T,KETAPA
C
          ERRSTR='INCORRECT STANDARD-FORCE SWITCHES IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (KETA_R.NE.1.AND.KETA_R.NE.2.AND.KETA_R.NE.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),''  INCORRECT ROTATIONAL CORR.'',
     *                            '' SWITCH'',       2X,20(1H/),/,
     *                 1X,20(1H/),''  KETA_R ='',I2,25X,20(1H/),/)')
     *
     *    KETA_R
C
          ERRSTR='INCORRECT ROTATIONAL CORRECTION SWITCH IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C         SECURITIES BELOW WERE REMOVED IN VERSION (3.04B) ON 22/03/2021
C         BECAUSE THEY WERE NOT PLAYING ANY ROLE APART FROM ANNOYING THE
C         USER
C=======================================================================
C
C     IF (KETAJ2.EQ.1.AND.IPRGCM.EQ.0) THEN
C
C         WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),'' KETAJ2=1 REQUIRES IPRGCM>0,'',
C    *                            ''       '',         2X,20(1H/),/)')
C
C         ERRSTR=' KETAJ2=1 IS INCOMPATIBLE WITH IPRGCM=0 IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C
C     IF (KETAT2.EQ.1.AND.IPRGCM.EQ.0) THEN
C
C         WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),'' KETAT2=1 REQUIRES IPRGCM>0,'',
C    *                            ''       '',         2X,20(1H/),/)')
C
C         ERRSTR=' KETAT2=1 IS INCOMPATIBLE WITH IPRGCM=0 IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C
      IF (NAMKER.NE.1.AND.NAMKER.NE.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NAMKER ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *    NAMKER
C
          ERRSTR=' INCORRECT VALUE OF NAMKER IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NAMKER.NE.1.AND.ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NAMKER<>1 REQUIRES ISAKER<>1,'',
     *                            ''     '',          2X,20(1H/),/)')
C
          ERRSTR=' NAMKER<>1 IS INCOMPATIBLE WITH ISAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (KETAJ2.EQ.1.AND.IPRGCM.GE.1.AND.ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETAJ2=1 REQUIRES ISAKER<>1,'',
     *                            ''      '',          2X,20(1H/),/)')
C
          ERRSTR=' KETAJ2=1 IS INCOMPATIBLE WITH ISAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (KETAT2.EQ.1.AND.IPRGCM.GE.1.AND.ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETAT2=1 REQUIRES ISAKER<>1,'',
     *                            ''      '',          2X,20(1H/),/)')
C
          ERRSTR=' KETAT2=1 IS INCOMPATIBLE WITH ISAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NPNKNO.GT.1.AND.IPRGCM.GE.1.AND.ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NPNKNO>1 REQUIRES ISAKER<>1,'',
     *                            ''      '',          2X,20(1H/),/)')
C
          ERRSTR=' NPNKNO>1 IS INCOMPATIBLE WITH ISAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NTZKNO.GT.1.AND.IPRGCM.GE.1.AND.ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NTZKNO>1 REQUIRES ISAKER<>1,'',
     *                            ''      '',          2X,20(1H/),/)')
C
          ERRSTR=' NTZKNO>1 IS INCOMPATIBLE WITH ISAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NPAKNO.GT.1.AND.IPRGCM.GE.1.AND.ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NPAKNO>1 REQUIRES ISAKER<>1,'',
     *                            ''      '',          2X,20(1H/),/)')
C
          ERRSTR=' NPAKNO>1 IS INCOMPATIBLE WITH ISAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NMAORD.GT.0.AND.IPRGCM.GE.1.AND.ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMAORD>0 REQUIRES ISAKER<>1,'',
     *                            ''      '',          2X,20(1H/),/)')
C
          ERRSTR=' NMAORD>0 IS INCOMPATIBLE WITH ISAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NASORD.GE.0.AND.IPRGCM.GE.1.AND.ISAKER.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NASORD>-1 REQUIRES ISAKER<>1,'',
     *                            ''     '',          2X,20(1H/),/)')
C
          ERRSTR=' NASORD>-1 IS INCOMPATIBLE WITH ISAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (HBMINP.LT.20.OR.HBMINP.GT.21) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),''  UNUSUAL VALUE ENCOUNTERD'',
     *                            ''         '',       2X,20(1H/),/,
     *                 1X,20(1H/),''  HBMINP ='',F12.8,
     *                            ''          '',      5X,20(1H/),/)')
     *
     *    HBMINP
C
          ERRSTR=' UNUSUAL VALUE OF HBMINP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (THREEB.NE.0.0.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' THREEB<>0 REQUIRES IPNMIX=0,'',
     *                            '' STILL'',         2X,20(1H/),/)')
C
          ERRSTR=' THREEB<>0 IS INCOMPATIBLE WITH IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGRAIN.EQ.1.AND.IROTAT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGRAIN=1 REQUIRES IROTAT=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IGRAIN=1 IS INCOMPATIBLE WITH IROTAT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGRAIN.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGRAIN=1 REQUIRES IPNMIX=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IGRAIN=1 IS INCOMPATIBLE WITH IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGRAIN.EQ.1.AND.IPRGCM.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGRAIN=1 REQUIRES IPRGCM=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IGRAIN=1 IS INCOMPATIBLE WITH IPRGCM>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (FOURBD.NE.0.0.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' FOURBD<>0 REQUIRES IPNMIX=0,'',
     *                            '' STILL'',         2X,20(1H/),/)')
C
          ERRSTR=' FOURBD<>0 IS INCOMPATIBLE WITH IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETAPA.GE.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETAPA>0 REQUIRES IPNMIX=0,'',
     *                            '' STILL'',         3X,20(1H/),/)')
C
          ERRSTR=' KETAPA>0 IS INCOMPATIBLE WITH IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETA_T.GE.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETA_T>0 REQUIRES IPNMIX=0,'',
     *                            '' STILL '',         2X,20(1H/),/)')
C
          ERRSTR=' KETA_T>0 IS INCOMPATIBLE WITH IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETA_T.GE.1.AND.JETAPA.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETA_T>0 REQUIRES KETAPA=0,'',
     *                            '' FOR NOW'',        1X,20(1H/),/)')
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETAPA=1 REQUIRES KETA_T=0,'',
     *                            '' FOR NOW'',        1X,20(1H/),/)')
C
          ERRSTR=' KETA_T>0 IS INCOMPATIBLE WITH KETAPA=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETAPA.GE.1.AND.IFTEMP.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETAPA>0 REQUIRES IFTEMP=0,'',
     *                            '' STILL'',         3X,20(1H/),/)')
C
          ERRSTR=' KETAPA>0 IS INCOMPATIBLE WITH IFTEMP=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETAPA.GE.1.AND.NOZEPA.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETAPA>0 REQUIRES NOZEPA=0,'',
     *                            ''      '',         3X,20(1H/),/)')
C
          ERRSTR=' KETAPA>0 IS INCOMPATIBLE WITH NOZEPA=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.I_2CBR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' I_2CBR=1 REQUIRES IPRGCM=0,'',
     *                            '' STILL'',         3X,20(1H/),/)')
C
          ERRSTR=' I_2CBR=1 IS INCOMPATIBLE WITH IPRGCM>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.I_3CBR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' I_3CBR=1 REQUIRES IPRGCM=0,'',
     *                            '' STILL'',         3X,20(1H/),/)')
C
          ERRSTR=' I_3CBR=1 IS INCOMPATIBLE WITH IPRGCM>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (I_2CBR.EQ.1.AND.IPNMIX.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' I_2CBR=1 REQUIRES IPNMIX=1'',
     *                            ''        '',         2X,20(1H/),/)')
C
          ERRSTR=' I_2CBR=1 IS INCOMPATIBLE WITH IPNMIX=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (PRHOSN.LE.0.0D0.OR.POWERN.EQ.0.0D0.OR.
     *    PRHOSP.LE.0.0D0.OR.POWERP.EQ.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),''  INCORRECT  CONTACT-PAIRING'',
     *                            ''  FORCE'',       2X,20(1H/),/,
     *                 1X,20(1H/),''  NEUTRONS:'',    26X,20(1H/),/,
     *                 1X,20(1H/),''  PRHO_N='',F9.3,
     *                             '' PRHODN='',F9.3,  2X,20(1H/),/,
     *                 1X,20(1H/),''  PRHOSN='',F9.3,
     *                             '' POWERN='',F9.3,  2X,20(1H/),/,
     *                 1X,20(1H/),''  PROTONS: '',    26X,20(1H/),/,
     *                 1X,20(1H/),''  PRHO_P='',F9.3,
     *                             '' PRHODP='',F9.3,  2X,20(1H/),/,
     *                 1X,20(1H/),''  PRHOSP='',F9.3,
     *                             '' POWERP='',F9.3,  2X,20(1H/),/)')
     *
     *    PRHO_N,PRHODN,PRHOSN,POWERN,
     *    PRHO_P,PRHODP,PRHOSP,POWERP
C
          ERRSTR=' INCORRECT CONTACT-PAIRING FORCE IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIINV.LT.0.OR.INIINV.GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INIINV = '',I3,
     *                            ''   '',       2X,20(1H/),/)')
     *           INIINV
C
          ERRSTR=' INCORRECT VALUE OF INIINV IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIKAR.LT.0.OR.INIKAR.GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INIKAR = '',I3,
     *                            ''   '',       2X,20(1H/),/)')
     *           INIKAR
C
          ERRSTR=' INCORRECT VALUE OF INIKAR IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IKEINV.LT.0.OR.IKEINV.GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IKEINV = '',I3,
     *                            ''   '',       2X,20(1H/),/)')
     *           IKEINV
C
          ERRSTR=' INCORRECT VALUE OF IKEINV IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IKEKAR.LT.0.OR.IKEKAR.GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IKEKAR = '',I3,
     *                            ''   '',       2X,20(1H/),/)')
     *           IKEKAR
C
          ERRSTR=' INCORRECT VALUE OF IKEKAR IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIINV.GE.1.AND.(SLOWEV.NE.0.0D0.OR.SLOWOD.NE.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIINV>0 REQUIRES  ALL '',
     *                            '' SLOW-DOWN'',       3X,20(1H/),/,
     *                 1X,20(1H/),'' PARAMETERS EQUAL ZERO, WHILE'',
     *                            '' NOW:'',     3X,20(1H/),/,
     *                 1X,20(1H/),'' SLOWEV='',F9.3,
     *                            '' SLOWOD='',F9.3,  3X,20(1H/),/)')
     *
     *    SLOWEV,SLOWOD
C
          ERRSTR=' INCORRECT SLOW-DOWN PARAMS. FOR INIINV>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIKAR.GE.1.AND.(SLOWEV.NE.0.0D0.OR.SLOWOD.NE.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIKAR>0 REQUIRES  ALL '',
     *                            '' SLOW-DOWN'',       3X,20(1H/),/,
     *                 1X,20(1H/),'' PARAMETERS EQUAL ZERO, WHILE'',
     *                            '' NOW:'',     3X,20(1H/),/,
     *                 1X,20(1H/),'' SLOWEV='',F9.3,
     *                            '' SLOWOD='',F9.3,  3X,20(1H/),/)')
     *
     *    SLOWEV,SLOWOD
C
          ERRSTR=' INCORRECT SLOW-DOWN PARAMS. FOR INIKAR>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IADBAT.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IADBAT=1 REQUIRES IPNMIX=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IADBAT=1 REQUIRES IPNMIX=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IADBAT.EQ.1.AND.IAXIAP.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IADBAT=1 REQUIRES IAXIAP=0,'',
     *                            '' MISMATCH'',      1X,19(1H/),/)')
C
          ERRSTR=' IADBAT=1 REQUIRES IAXIAP=0  IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IADBAT.EQ.1.AND.IABCOL.EQ.2.AND.IPAIRI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IABCOL=2 REQUIRES IPAIRI=1,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IABCOL=2 REQUIRES IPAIRI=1, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.NE.1.AND.ITWCEN.NE.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ITWCEN = '',I3,
     *                            ''   '',       2X,20(1H/),/)')
     *           ITWCEN
C
          ERRSTR=' INCORRECT VALUE OF ITWCEN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IAXIAP.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES IAXIAP=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES IAXIAP=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.1.AND.IFRCNT.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=1 REQUIRES IFRCNT=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=1 REQUIRES IFRCNT=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICONTI.EQ.0.AND.IFRCNT.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFRCNT=1 REQUIRES ICONTI=1,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IFRCNT=1 REQUIRES ICONTI=1, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IBROYD.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES IBROYD=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES IBROYD=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.MIXMAT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES MIXMAT=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES MIXMAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IADBAT.EQ.1.AND.NEWCOU.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IADBAT=1 REQUIRES NEWCOU=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IADBAT=1 REQUIRES NEWCOU=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.(ICOUDI.GE.1.OR.ICOUEX.GE.1).AND.
     *                                    NEWCOU.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES NEWCOU=1,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES NEWCOU=1, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUMD.GT.0.AND.ICOUDI.LE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUMD>0 REQUIRES ICOUDI>0'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUMD>0 REQUIRES ICOUDI>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUMX.GT.0.AND.ICOUEX.LE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUMX>0 REQUIRES ICOUEX>0'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUMX>0 REQUIRES ICOUEX>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUMD.GT.0.AND.IPRGCM.LE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUMD>0 REQUIRES IPRGCM>0'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUMD>0 REQUIRES IPRGCM>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUMX.GT.0.AND.IPRGCM.LE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUMX>0 REQUIRES IPRGCM>0'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUMX>0 REQUIRES IPRGCM>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUMD.GT.0.AND.ILCONF.LE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUMD>0 REQUIRES ILCONF>0'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUMD>0 REQUIRES ILCONF>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUMX.GT.0.AND.ILCONF.LE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUMX>0 REQUIRES ILCONF>0'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUMX>0 REQUIRES ILCONF>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ICOUPA.GT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES ICOUPA=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES ICOUPA=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.I_GOGA.GT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES I_GOGA=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES I_GOGA=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ISEPPA.GT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES ISEPPA=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES ISEPPA=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IADBAT.EQ.1.AND.(ISIMPY.EQ.1.OR.ISIQTY.EQ.1))
     *                                                              THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IADBAT=1             '',
     *                            '' REQUIRES'',       5X,20(1H/),
     *                 1X,20(1H/),'' ISIMPY=0 AND ISIQTY=0'',
     *                            '' FOR NOW '',       5X,20(1H/),/)')
C
          ERRSTR='IADBAT=1 REQUIRES ISIMPY=ISIQTY=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ISWTWC.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES ISWTWC=1,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES ISWTWC=1, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.NDTWCE.NE.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES NDTWCE=2,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES NDTWCE=2, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.NDTWHE.NE.16) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES NDTWCE=2,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES NDTWHE=16, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.NDTWDD.NE.24) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES NDTWDD=24,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES NDTWDD=24, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IREAWS.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES IREAWS=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES IREAWS=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IF_THO.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES IF_THO=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES IF_THO=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IBASIS.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES IBASIS=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES IBASIS=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IPOTHO.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES IPOTHO=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES IPOTHO=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.INPOME.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES INPOME=1,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES INPOME=1, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IPNMIX.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES IPNMIX=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES IPNMIX=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES ISIMPY=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES ISIMPY=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ISIGNY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES ISIGNY=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES ISIGNY=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ISIMTX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES ISIMTX=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES ISIMTX=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ISIMTZ.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES ISIMTZ=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES ISIMTZ=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.JSIMTY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES JSIMTY=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES JSIMTY=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.ISIQTY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES ISIQTY=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES ISIQTY=0, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.KETA_R.EQ.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES KETA_R=1,3'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES JETACM=1 OR 3, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IPAHFB.GE.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES IPAHFB<2,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES IPAHFB<2, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2.AND.IPAHFB.EQ.1.AND.IMFHFB.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAHFB=1 REQUIRES IMFHFB=1,'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' IPAHFB=1 REQUIRES IMFHFB=1 FOR ITWCEN=2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ITWCEN.EQ.2.AND.JETACM.EQ.1).OR.
     *    (ITWCEN.EQ.2.AND.JETACM.EQ.2)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=2 REQUIRES JSIMTY=0,3'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' ITWCEN=2 REQUIRES JETACM=0 OR 3, FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      DO LTWCEN=1,ITWCEN
C
         IF (ITWCEN.NE.2.AND.IROFRG(LTWCEN).NE.0) THEN
C
             WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWCEN=1 REQUIRES IROFRG=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
             ERRSTR=' ITWCEN=1 REQUIRES IROFRG=0, FOR NOW IN TESDAT'
             CALL ERPUSH(ERRSTR,IERROR)
C
         END IF
C
      END DO
C
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         ICHECK=0
C
         DO LTWCEN=1,ITWCEN
C
            ICHECK=ICHECK+IFLFRG(ICHARG,LTWCEN)
C
            IF (IFLFRG(ICHARG,LTWCEN).LT.0.OR.
     *          IFLFRG(ICHARG,LTWCEN).GT.3) THEN
C
                WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' WRONG IFLRG, MUST BE 0 -> 3,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
                ERRSTR=' WRONG IFLRG, MUST BE 0 -> 3, FOR NOW IN TESDAT'
                CALL ERPUSH(ERRSTR,IERROR)
C
            END IF
C
            IF (ITWCEN.EQ.1.AND.ICHECK.GT.0) THEN
C
                WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFLFRG>0 REQUIRES ITWCEN=2''
     *                                             ,1X,20(1H/),/)')
C
                ERRSTR=' IFLFRG>0 REQUIRES ITWCEN=2 IN TESDAT'
                CALL ERPUSH(ERRSTR,IERROR)
C
            END IF
C
         END DO
C
      END DO
C
C=======================================================================
C
      IF (IFLFRG(0,1).GT.0.AND.IFLFRG(0,NDTWCE).GT.0.AND.
     *    ITWCEN.EQ.2) THEN
C
          IF (FRGASK(0,1)+FRGASK(0,NDTWCE).NE.REAL(INNUMB))
     *    STOP 'WRONG NEUTRON FRAGMENT DISTRIBUTION '
C
      END IF
C
      IF (IFLFRG(1,1).GT.0.AND.IFLFRG(1,NDTWCE).GT.0.AND.
     *    ITWCEN.EQ.2) THEN
C
          IF (FRGASK(1,1)+FRGASK(1,NDTWCE).NE.REAL(IZNUMB))
     *    STOP 'WRONG PROTON FRAGMENT DISTRIBUTION '
C
      END IF
C
C=======================================================================
C
      IF (ITWCEN.EQ.2) THEN
C
          IF (IFLFRG(0,1).EQ.0.AND.IFLFRG(0,NDTWCE).GT.0)
     *    STOP 'SINGLE FRAGMENT CONSTRAINT (NEUT) MUST BE IN MTWCEN=1'
          IF (IFLFRG(1,1).EQ.0.AND.IFLFRG(1,NDTWCE).GT.0)
     *    STOP 'SINGLE FRAGMENT CONSTRAINT (PROT) MUST BE IN MTWCEN=1'
C
      END IF
C
C=======================================================================
C
      IF (IVIPRI.LT.0.OR.IVIPRI.GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IVIPRI = '',I3,
     *                            ''   '',       2X,20(1H/),/)')
     *           IVIPRI
C
          ERRSTR=' INCORRECT VALUE OF IVIPRI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IVIPRI.GE.1.AND.IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IVIPRI>0 REQUIRES IROTAT=1 '',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' IVIPRI>0 REQUIRES IROTAT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IVIPRI.EQ.0.OR.IVIPRI.EQ.1).AND.NDVIOL.NE.32) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IVIPRI=0 OR 1 REQUIRES NDVIOL=32'',
     *                            ''   '',             1X,20(1H/),/)')
C
          ERRSTR=' IVIPRI=0 OR 1 REQUIRES NDVIOL=32 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IVIPRI.EQ.2.AND.NDVIOL.NE.56) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IVIPRI=2 REQUIRES NDVIOL=56'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' IVIPRI=2 REQUIRES NDVIOL=56 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (I_COUA.GE.1.AND.NEWCOU.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' I_COUA>0 REQUIRES NEWCOU=1,'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' I_COUA>0 REQUIRES NEWCOU=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
      IF (ICOUPA.GE.1.AND.NEWCOU.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUPA>0 REQUIRES NEWCOU=1,'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUPA>0 REQUIRES NEWCOU=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUPA.GE.1.AND.I_COUA.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUPA>0 REQUIRES I_COUA>0,'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUPA>0 REQUIRES I_COUA>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUPA.GE.1.AND.ITWCEN.EQ.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUPA>0 REQUIRES ITWCEN=1,'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ICOUPA>0 REQUIRES ITWCEN=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((I_COUA.EQ.2.OR.I_COUA.EQ.3).AND.ICOUDI.LE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUDI<2 IS INCOMPATIBLE WITH'',
     *                            '' I_COUA=2'',1X,19(1H/),/,
     *                 1X,20(1H/),'' OR I_COUA=3                  '',
     *                            ''         '',1X,19(1H/),/)')
C
          ERRSTR='ICOUDI<2 AND I_COUA=2 OR 3 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((I_COUA.EQ.2.OR.I_COUA.EQ.4).AND.ICOUEX.LE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUEX<2 IS INCOMPATIBLE WITH'',
     *                            '' I_COUA=2'',1X,19(1H/),/,
     *                 1X,20(1H/),'' OR I_COUA=4                  '',
     *                            ''         '',1X,19(1H/),/)')
C
          ERRSTR='ICOUEX<2 AND I_COUA=2 OR 4 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISCHIF.NE.0.AND.ITWCEN.EQ.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISCHIF>0 REQUIRES ITWCEN=1,'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' ISCHIF>0 REQUIRES ITWCEN=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIINV.GE.1.AND.IPAHFB.GE.1.AND.SLOWPA.NE.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIINV>0 REQUIRES  ALL '',
     *                            '' SLOW-DOWN'',       3X,20(1H/),/,
     *                 1X,20(1H/),'' PARAMETERS EQUAL ZERO, WHILE'',
     *                            '' NOW:'',     3X,20(1H/),/,
     *                 1X,20(1H/),'' SLOWPA='',F9.3,
     *                            ''        '',      12X,20(1H/),/)')
     *
     *    SLOWPA
C
          ERRSTR=' INCORRECT PAIRING SLOW-DOWN FOR INIINV>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIKAR.GE.1.AND.IPAHFB.GE.1.AND.SLOWPA.NE.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIKAR>0 REQUIRES  ALL '',
     *                            '' SLOW-DOWN'',       3X,20(1H/),/,
     *                 1X,20(1H/),'' PARAMETERS EQUAL ZERO, WHILE'',
     *                            '' NOW:'',     3X,20(1H/),/,
     *                 1X,20(1H/),'' SLOWPA='',F9.3,
     *                            ''        '',      12X,20(1H/),/)')
     *
     *    SLOWPA
C
          ERRSTR=' INCORRECT PAIRING SLOW-DOWN FOR INIKAR>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((LIPKIN.GE.1.OR.LIPKIP.GE.1).AND.
     *    (IPNMIX.EQ.1.OR.I_YUKA.GE.1.OR.I_GOGA.GE.1.OR.I_REGA.GE.1.OR.
     *     I_COUA.GE.1.OR.I_SEPA.GE.1.OR.ICOUDI.EQ.2.OR.ICOUEX.EQ.2.OR.
     *     JETACM.EQ.2.OR.KETA_R.EQ.2.OR.IFRAGM.EQ.1.OR.
     *     MAXVAL(IFSTPA).GE.2.OR.
     *     IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1.OR.ICOUPA.GE.1)
     *                                        .AND.SLOWLM.NE.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' THE LIPKIN METHOD USED TOGETHER'',
     *                            '' WITH'',          1X,20(1H/),/,
     *                 1X,20(1H/),'' PN MIX, FINITE-R, EX-COU, 2B'',
     *                            '' CORRECS'',          1X,20(1H/),/,
     *                 1X,20(1H/),'' REQUIRES  SLOWLM = 0.0,  WHEREAS'',
     *                            '' NOW'',           1X,20(1H/),/,
     *                 1X,20(1H/),'' SLOWLM ='',F9.3,19X,20(1H/),/)')
     *
     *    SLOWLM
C
          ERRSTR=' INCORRECT LIPKIN SLOW-DOWN PARAMETER IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIINV.GE.1.AND.NOITER.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIINV>0 REQUIRES NOITER=1 '',
     *                            ''       '',       2X,20(1H/),/)')
C
          ERRSTR=' MORE THAN 1 ITER. REQUESTED FOR INIINV>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIKAR.GE.1.AND.NOITER.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIKAR>0 REQUIRES NOITER=1 '',
     *                            ''       '',       2X,20(1H/),/)')
C
          ERRSTR=' MORE THAN 1 ITER. REQUESTED FOR INIKAR>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIKAR.EQ.1.AND.ISIGNY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIKAR=1 REQUIRES ISIGNY=0,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' INIKAR=1 IS INCOMPATIBLE WITH ISIGNY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIKAR.EQ.3.AND.ISIGNY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIKAR=3 REQUIRES ISIGNY=0,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' INIKAR=3 IS INCOMPATIBLE WITH ISIGNY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIINV.EQ.2.AND.IROTAT.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIINV=2 REQUIRES IROTAT=1,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' INIINV=1 IS INCOMPATIBLE WITH IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIINV.EQ.3.AND.IROTAT.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIINV=3 REQUIRES IROTAT=1,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' INIINV=3 IS INCOMPATIBLE WITH IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIINV.EQ.1.AND.ISIQTY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIINV=1 REQUIRES IPARTY=0,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' INIINV=2 IS INCOMPATIBLE WITH IPARTY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIINV.EQ.3.AND.ISIQTY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIINV=3 REQUIRES IPARTY=0,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' INIINV=3 IS INCOMPATIBLE WITH IPARTY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IKEINV.EQ.2.AND.IROTAT.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IKEINV=2 REQUIRES IROTAT=1,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' IKEINV=1 IS INCOMPATIBLE WITH IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IKEINV.EQ.3.AND.IROTAT.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IKEINV=3 REQUIRES IROTAT=1,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' IKEINV=3 IS INCOMPATIBLE WITH IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IKEINV.EQ.1.AND.ISIQTY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IKEINV=1 REQUIRES IPARTY=0,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' IKEINV=2 IS INCOMPATIBLE WITH IPARTY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IKEINV.EQ.3.AND.ISIQTY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IKEINV=3 REQUIRES IPARTY=0,'',
     *                            ''       '',         2X,20(1H/),/)')
C
          ERRSTR=' IKEINV=3 IS INCOMPATIBLE WITH IPARTY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IKEINV.NE.0.OR.IKEKAR.NE.0).AND.NUAKNO.NE.1.AND.IPRGCM.EQ.1)
     *                                                              THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IKEINV>0 OR IKEKAR>0'',
     *                            '' FOR NUAKNO>1 '',  2X,20(1H/),/,
     *                 1X,20(1H/),'' REQUIRES IPRGCM>1   '',
     *                            ''              '',   2X,20(1H/),/)')
C
          ERRSTR=' IKEINV>0 OR IKEKAR>0 INCOMP. WITH IPRGCM>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIROT.EQ.1.AND.(SLOWEV.NE.0.0D0.OR.SLOWOD.NE.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIROT=1 REQUIRES  ALL '',
     *                            '' SLOW-DOWN'',       3X,20(1H/),/,
     *                 1X,20(1H/),'' PARAMETERS EQUAL ZERO, WHILE'',
     *                            '' NOW:'',     3X,20(1H/),/,
     *                 1X,20(1H/),'' SLOWEV='',F9.3,
     *                            '' SLOWOD='',F9.3,  3X,20(1H/),/)')
     *
     *    SLOWEV,SLOWOD
C
          ERRSTR=' INCORRECT SLOW-DOWN PARAMS. FOR INIROT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIROT.EQ.1.AND.IPAHFB.GE.1.AND.SLOWPA.NE.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIROT=1 REQUIRES  ALL '',
     *                            '' SLOW-DOWN'',       3X,20(1H/),/,
     *                 1X,20(1H/),'' PARAMETERS EQUAL ZERO, WHILE'',
     *                            '' NOW:'',     3X,20(1H/),/,
     *                 1X,20(1H/),'' SLOWPA='',F9.3,
     *                            ''        '',      12X,20(1H/),/)')
     *
     *    SLOWPA
C
          ERRSTR=' INCORRECT PAIRING SLOW-DOWN FOR INIROT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIROT.EQ.1.AND.NOITER.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIROT=1 REQUIRES NOITER=1 '',
     *                            ''       '',       2X,20(1H/),/)')
C
          ERRSTR=' MORE THAN 1 ITER. REQUESTED FOR INIROT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIROT.EQ.1.AND.ISIGNY.EQ.1.AND.
     *   (ALPINI.NE.0.0D0.OR.GAMINI.NE.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIROT=1 REQUIRES ISIGNY=0,'',
     *                            '' UNLESS'',         2X,20(1H/),/,
     *                 1X,20(1H/),'' ALPINI AND GAMINI ARE EXACTLY'',
     *                            '' ZERO'',           2X,20(1H/),/)')
C
          ERRSTR=' INIROT=1 IS INCOMPATIBLE WITH ISIGNY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIROT.EQ.1.AND.ISIMPY.EQ.1.AND.
     *   (ALPINI.NE.0.0D0.OR.GAMINI.NE.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIROT=1 REQUIRES ISIMPY=0,'',
     *                            '' UNLESS'',         2X,20(1H/),/,
     *                 1X,20(1H/),'' ALPINI AND GAMINI ARE EXACTLY'',
     *                            '' ZERO'',           2X,20(1H/),/)')
C
          ERRSTR=' INIROT=1 IS INCOMPATIBLE WITH ISIMPY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIROT.EQ.1.AND.ISIMTX.EQ.1.AND.
     *   (ALPINI.NE.0.0D0.OR.GAMINI.NE.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIROT=1 REQUIRES ISIMTX=0,'',
     *                            '' UNLESS'',         2X,20(1H/),/,
     *                 1X,20(1H/),'' ALPINI AND GAMINI ARE EXACTLY'',
     *                            '' ZERO'',           2X,20(1H/),/)')
C
          ERRSTR=' INIROT=1 IS INCOMPATIBLE WITH ISIMTX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (INIROT.EQ.1.AND.JSIMTY.EQ.1.AND.
     *   (ALPINI.NE.0.0D0.OR.GAMINI.NE.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIROT=1 REQUIRES ISIMTY=0,'',
     *                            '' UNLESS'',         2X,20(1H/),/,
     *                 1X,20(1H/),'' ALPINI AND GAMINI ARE EXACTLY'',
     *                            '' ZERO'',           2X,20(1H/),/)')
C
          ERRSTR=' INIROT=1 IS INCOMPATIBLE WITH ISIMTY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.LT.0.OR.IPRGCM.GT.4.OR.IPRGCM.EQ.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IPRGCM = '',I3,
     *                            ''   '',       2X,20(1H/),/)')
     *           IPRGCM
C
          ERRSTR=' INCORRECT VALUE OF IPRGCM IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.EQ.4.AND.NATKNO.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM=4 REQUIRES NATKNO=1,'',
     *                            '' FOR NOW'',        1X,20(1H/),/)')
C
          ERRSTR=' IPRGCM=4 IS INCOMPATIBLE WITH NATKNO>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.I_COUA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0 REQUIRES I_COUA=0,'',
     *                            '' FOR NOW'',        1X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0 IS INCOMPATIBLE WITH I_COUA>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.ISCHIF.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISCHIF=1  (CALC. OF SCHIFF'',
     *                            '' MOMENTS)'',         1X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE  WITH  '',
     *                            '' PROJECTION.'',      1X,20(1H/),/,
     *                 1X,20(1H/),'' USE ISCHIF=2 TO PRINT R.M.E`S'',
     *                            '' OF THE'',           1X,20(1H/),/,
     *                 1X,20(1H/),'' PROJECTED STATES.           '',
     *                            ''        '',          1X,20(1H/),/)')
C
          ERRSTR=' ISCHIF=1 INCOMPATIBLE WITH PROJECTION IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NOSCIL.LT.0.OR.NOSCIL.GT.NDMAIN) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NOSCIL = '',I3,
     *                            ''   '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' SHOULD NOT EXCEED  NDMAIN = '',I3,
     *                            ''  OR'',      1X,20(1H/),/,
     *                 1X,20(1H/),'' OTHERWISE INCREASE NDMAIN TO'',
     *                            '' NOSCIL'',   1X,20(1H/),/)')
     *           NOSCIL,NDMAIN
C
          ERRSTR=' INCORRECT VALUE OF NOSCIL OR NDMAIN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C            ATTENTION: BEFORE VERSION (2.81B) THE TEST OF NOSCIL>36 WAS
C                       MISSING AND THE CODE  COULD  HAVE  THEN  BEHAVED
C                       ERRATICALLY. CALCULATIONS WITH  NOSCIL>36  AWAIT
C                       FUTURE DEBUGGING. THIS OMISSION WAS CORRECTED ON
C                       08/07/2017 IN VERSION (2.81B).
C=======================================================================
C
      IF (NOSCIL.GT.36) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' TOO LARGE VALUE OF NOSCIL = '',I3,
     *                            ''   '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' SHOULD NOT EXCEED  NOSCIL = '',I3,
     *                            ''    '',      1X,20(1H/),/,
     *                 1X,20(1H/),'' THE CODE IS NOT DEGUGGED THERE'',
     *                            '' YET '',  1X,20(1H/),/)')
     *           NOSCIL,36
C
          ERRSTR=' TOO LARGE VALUE OF NOSCIL IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUAKNO.GT.NDAKNO) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''NUAKNO.GT.NDAKNO:'',3X,20(1H/),/,
     *                 1X,20(1H/),7X,I3,   ''.GT.''  ,I3,7X,20(1H/),/)')
     *                 NUAKNO,NDAKNO
C
          ERRSTR=' NUAKNO.GT.NDAKNO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUBKNO.GT.NDBKNO) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''NUBKNO.GT.NDBKNO:'',3X,20(1H/),/,
     *                 1X,20(1H/),7X,I3,   ''.GT.''  ,I3,7X,20(1H/),/)')
     *                 NUBKNO,NDBKNO
C
          ERRSTR=' NUBKNO.GT.NDBKNO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NATKNO.GT.NDATKN) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''NATKNO.GT.NDATKN:'',3X,20(1H/),/,
     *                 1X,20(1H/),7X,I3,   ''.GT.''  ,I3,7X,20(1H/),/)')
     *                 NATKNO,NDATKN
C
          ERRSTR=' NATKNO.GT.NDATKN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NBTKNO.GT.NDBTKN) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''NBTKNO.GT.NDBTKN:'',3X,20(1H/),/,
     *                 1X,20(1H/),7X,I3,   ''.GT.''  ,I3,7X,20(1H/),/)')
     *                 NBTKNO,NDBTKN
C
          ERRSTR=' NBTKNO.GT.NDBTKN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NATKNO.GT.1.AND.NBTKNO.LE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NATKNO>1 REQUIRES NBTKNO>1,'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' NATKNO>1 REQUIRES NBTKNO>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C        ATTENTION: AFTER IMPLEMENTING THE PFAFFIAN METHOD TO  CALCULATE
C                   OVERLAPS BETWEEN PAIRED STATES, IT HAS BECOME  CLEAR
C                   THAT THE METHOD CANNOT PROPERLY WORK UNLESS (I)  THE
C                   NUMBER  OF  QUASIPARTICLES  IS  EVEN  AND  (II)  THE
C                   QUASIPARTICLE  SPACE  IS  COMPLETE.  THEREFORE,  THE
C                   SECURITY BELOW  WAS  IMPLEMENTED  ON  22/10/2020  IN
C                   VERSION  (3.00H)  AND  CORRECTED  ON  07/12/2021  IN
C                   VERSION  (3.08G) TO ALLOW FOR A CALCULATION  WITHOUT
C                   ENERGY CUTOFF NEVERTHELESS.
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.IPAHFB.GE.1.AND.IONISH.NE.1.AND.
     *   (ITWOBA.NE.1.OR.NUQEVE.NE.1).AND.ECUTOF.LE.9999.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0+IPAHFB>0+IONISH=0'',
     *                            '' REQUIRES'',     2X,20(1H/),/,
     *                 1X,20(1H/),'' ITWOBA=1 & NUQEVE=1 OR ECUTOF'',
     *                            ''>9999 '',        2X,20(1H/),/)')
C
          ERRSTR='IPRGCM>0+IPAHFB>0+IONISH=0 >> ITWOBA=NUQEVE=1/NO ECUT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.IPAHFB.GE.1.AND.IONISH.NE.1.AND.
     *    ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0+IPAHFB>0+IONISH=0'',
     *                            '' REQUIRES'',     2X,20(1H/),/,
     *                 1X,20(1H/),'' ISIMPY=0                  '',
     *                            ''         '',     2X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0+IPAHFB>0+IONISH=0 REQUIRES ISIMPY=0 TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.IPAHFB.GE.1.AND.IONISH.EQ.1.AND.
     *    ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0+IPAHFB>0+IONISH=1'',
     *                            '' REQUIRES'',     2X,20(1H/),/,
     *                 1X,20(1H/),'' ISIMPY=0, TEMPORARILY  (TO'',
     *                            '' BE DONE)'',     2X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0+IPAHFB>0+IONISH=0 REQUIRES ISIMPY=0 TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1.OR.
     *     IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQN)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQP)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIZN)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIZP)).EQ.1).AND.
     *     IPRGCM.GE.1.AND.IPAHFB.GE.1.AND.IONISH.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0+IPAHFB>0+BLOCKING'',
     *                            '' REQUIRES'',     2X,20(1H/),/,
     *                 1X,20(1H/),'' IONISH=0                  '',
     *                            ''         '',     2X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0+IPAHFB>0+BLOCKING REQUIRES IONISH=0 TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.IPNMIX.EQ.1.AND.NATKNO.LE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0&IPNMIX=1 REQUIRES'',
     *                            '' NATKNO>1'',       2X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0 AND IPNMIX=1 REQUIRES NATKNO>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.IPNMIX.EQ.1.AND.IPAHFB.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0&IPNMIX=1 REQUIRES'',
     *                            '' IPAHFB=0'',       2X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0 AND IPNMIX=1 REQUIRES IPAHFB=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C         THE TEST BELOW SEEMS TO HAVE NO USE AND HAS BEEN REMOVED
C         IN VERSION 2.91N ON 23/11/2019
C=======================================================================
C
C     IF (MOD(NDPROI,2).NE.0) THEN
C
C         WRITE(NFIPRI,'(/,1X,20(1H/),'' NDPROI NOT EVEN:'',
C    *                                         I3,2X,20(1H/),/)') NDPROI
C
C         ERRSTR='NDPROI IS NOT EVEN IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.IPROMA.GT.NDPROI.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''IPROMA.GT.NDPROI:'',3X,20(1H/),/,
     *                 1X,20(1H/),7X,I3,   ''.GT.''  ,I3,7X,20(1H/),/)')
     *                 IPROMA,NDPROI
C
          ERRSTR=' IPROMA.GT.NDPROI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.ISOSMA.GT.NDPROT.AND.NBTKNO.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''ISOSMA.GT.NDPROT:'',3X,20(1H/),/,
     *                 1X,20(1H/),7X,I3,   ''.GT.''  ,I3,7X,20(1H/),/)')
     *                 ISOSMA,NDPROT
C
          ERRSTR=' ISOSMA.GT.NDPROT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NDPROT.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *            1X,20(1H/),2X,''NDPROT<1 NOT ALLOWED'',2X,20(1H/),/)')
C
          ERRSTR=' NDPROT<1 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (QMUCUT.LT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *            1X,20(1H/),2X,''QMUCUT<0 NOT ALLOWED'',2X,20(1H/),/)')
C
          ERRSTR=' QMUCUT<0 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (QMACUT.LT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *            1X,20(1H/),2X,''QMACUT<0 NOT ALLOWED'',2X,20(1H/),/)')
C
          ERRSTR=' QMACUT<0 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (QASCUT.LT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *            1X,20(1H/),2X,''QASCUT<0 NOT ALLOWED'',2X,20(1H/),/)')
C
          ERRSTR=' QASCUT<0 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (QSICUT.LT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *            1X,20(1H/),2X,''QSICUT<0 NOT ALLOWED'',2X,20(1H/),/)')
C
          ERRSTR=' QSICUT<0 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND. NBTKNO.GT.1.AND.ICSKIP.EQ.0.
     *               .AND.(ICOUDI.NE.2.OR. ICOUEX.NE.2)) THEN
C
          WRITE(NFIPRI,'(/,1X,6(''/''),1X,
     *          ''REDIAGONALIZATION OF FULL HAMILTONIAN IN ISOSPIN '',
     *          ''PROJECTION /////'',/,'' ////// (ICSKIP=0) '',
     *          ''REQUIRES ICOUDI=2 AND ICOUEX=2 (EXACT COULOMB)'',
     *          ''   /////'',/,1X,6(''/''),61X,5(''/''),/,
     *          '' ////// CURRENT VALUES: ICSKIP='',I2,
     *          ''; ICOUDI='',I2,''; ICOUEX='',I2,13X,5(''/''))')
     *              ICSKIP,ICOUDI,ICOUEX
C
          ERRSTR=' INCORRECT COULOMB PARAMETERS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.IPROMA.GT.NDJMXD.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                1X,19(1H/),5X,''IPROMA/2 > NDJMAX '',5X,19(1H/),/,
     *                1X,19(1H/),1X,''INCREASE NDJMAX             '',1X,
     *                                                      19(1H/),/)')
C
          ERRSTR=' IPROMA/2>NDJMAX, INCREASE NDJMAX'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.ISOSMA.GT.NDJMXD.AND.
     *   (NBTKNO.GT.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                1X,19(1H/),5X,''ISOSMA/2 > NDJMAX '',5X,19(1H/),/,
     *                1X,19(1H/),1X,''INCREASE NDJMAX             '',1X,
     *                                                      19(1H/),/)')
C
          ERRSTR=' ISOSMA/2>NDJMAX, INCREASE NDJMAX'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.IPROMI.GT.IPROMA.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''IPROMI.GT.IPROMA:'',3X,20(1H/),/,
     *                 1X,20(1H/),7X,I3,   ''.GT.''  ,I3,7X,20(1H/),/)')
     *                 IPROMI,IPROMA
C
          ERRSTR=' IPROMI.GT.IPROMA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.ISOSMI.GT.ISOSMA.AND.
     *   (NBTKNO.GT.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''ISOSMI.GT.ISOSMA:'',3X,20(1H/),/,
     *                 1X,20(1H/),7X,I3,   ''.GT.''  ,I3,7X,20(1H/),/)')
     *                 ISOSMI,ISOSMA
C
          ERRSTR=' ISOSMI.GT.ISOSMA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS (2.21J) AND (2.99F), THE TEST BELOW
C                   PERTAINED TO IROTAT=1 AND NOT TO MREVER=1. THIS  HAS
C                   BEEN MODIFIED ON 28/08/2020 IN VERSION (2.99G). AS A
C                   RESULT, PROJECTIONS WITH IROTAT=0 AND ISIMPY=0  HAVE
C                   NOW BECOME ALLOWED.
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.MREVER.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0 REQUIRES MREVER=1,'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0 REQUIRES MREVER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.JPABCS.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0 REQUIRES IPABCS=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0 REQUIRES IPABCS=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IPAHFB.GE.1.AND.(ISIMPY.EQ.1.OR.ISIQTY.EQ.1))
     *                                                              THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 AND IPAHFB=1'',
     *                            '' REQUIRE '',       5X,20(1H/),
     *                 1X,20(1H/),'' ISIMPY=0 AND ISIQTY=0'',
     *                            '' FOR NOW '',       5X,20(1H/),/)')
C
          ERRSTR='IPNMIX=1&IPAHFB=1 REQUIRE ISIMPY=ISIQTY=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETAPA.GE.1.AND.(ISIMPY.EQ.1.OR.ISIQTY.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETAPA>0 (SKYRME PAIRING)'',
     *                            '' REQUIRES'',       1X,20(1H/),/,
     *                 1X,20(1H/),'' ISIMPY=0 AND ISIQTY=0'',
     *                            '' FOR NOW '',       5X,20(1H/),/)')
C
          ERRSTR='KETAPA>0 REQUIRES ISIMPY=ISIQTY=0 FOR NOW IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.JPABCS.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IPABCS=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IPABCS=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IN_FIX.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IN_FIX>0,'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IN_FIX>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IZ_FIX.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IZ_FIX>0,'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IZ_FIX>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IBROYD.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IBROYD=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IBROYD=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.I_YUKA.GT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES I_YUKA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES I_YUKA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.I_GOGA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES I_GOGA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES I_GOGA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IGOGPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IGOGPA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IGOGPA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.I_COUA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES I_COUA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES I_COUA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.ICOUPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES ICOUPA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES ICOUPA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.MAXVAL(I_FSTA).GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES I_FSTA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES I_FSTA(:)=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.MAXVAL(IFSTPA).GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IFSTPA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IFSTPA(:)=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IAXIAP).EQ.1.AND.ICONTI.EQ.1.AND.IFCONT.NE.1) THEN
C
          WRITE(NFIPRI,'(
     *                1H*,20(1H/),2X,''WARNING: TO SMOOTHLY CONTINUE'',
     *                               ''    '',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''CALCULATIONS PERFORMED WITH '',
     *                               ''     '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''AXIALIZATION (IAXIAP=1), REST'',
     *                               ''ART '',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''FROM FIELDS, NAMELY, USE IFCO'',
     *                               ''NT=1'',       2X,20(1H/),1H*,/)')
C
      END IF
C
C=======================================================================
C
      IF (IDIQGA.EQ.1.AND.I_REGA.LT.1.AND.(I_GOGA.LT.1.OR.NEWGOG.EQ.0))
     *                                                              THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IDIQGA=1 REQUIRES I_REGA>0 '',
     *                            '' OR     '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' I_GOGA>0 & NEWGOG=1        '',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR='IDIQGA=1 RQRS I_REGA>0 OR I_GOGA>0&NEWGOG=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IDIQGA.EQ.1.AND.(MAXVAL(I_FSTA).GE.1.OR.MAXVAL(IFSTPA).GE.1))
     *                                                              THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IDIQGA=1 REQUIRES I_FSTA(:)=0 '',
     *                            '' AND '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' IFSTPA(:)=0 FOR NOW        '',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR='IDIQGA=1 RQUIRES I_FSTA(:)=0 & IFSTPA(:)=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IDIQGA.EQ.1.AND.(DIQCOD.LE.0.0D0.OR.DIQCOD.GT.1.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IDIQGA=1 NEEDS 0<DIQCOD<=1,'',
     *                               (1PE8.1),       1X,20(1H/),/)')
     *    DIQCOD
C
          ERRSTR='IDIQGA=1 REQUIRES 0<DIQCOD<=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IDIQGA.EQ.1.AND.(DIQCOE.LE.0.0D0.OR.DIQCOE.GT.1.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IDIQGA=1 NEEDS 0<DIQCOE<=1,'',
     *                               (1PE8.1),       1X,20(1H/),/)')
     *    DIQCOE
C
          ERRSTR='IDIQGA=1 REQUIRES 0<DIQCOE<=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IDIQGA.EQ.1.AND.(DIQCOP.LE.0.0D0.OR.DIQCOP.GT.1.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IDIQGA=1 NEEDS 0<DIQCOP<=1,'',
     *                               (1PE8.1),       1X,20(1H/),/)')
     *    DIQCOP
C
          ERRSTR='IDIQGA=1 REQUIRES 0<DIQCOP<=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IDIQGA.EQ.1.AND.N3LORD.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IDIQGA=1 REQUIRES N3LORD=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IDIQGA=1 REQUIRES N3LORD=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.I_REGA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES I_REGA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES I_REGA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.MAXVAL(MAG2BC).GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES MAG2BC=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES MAXVAL(MAG2BC)=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.MAXVAL(MAGANL).GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES MAGANL=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES MAXVAL(MAGANL)=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IREGPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IREGPA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IREGPA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.I_SEPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES I_SEPA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES I_SEPA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.ISEPPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES ISEPPA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES ISEPPA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IFTEMP.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IFTEMP=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IFTEMP=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IF_RPA.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IF_RPA=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES IF_RPA=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.LDPNMX.LE.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES LDPNMX>2 '',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 REQUIRES LDPNMX > 2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IROTAT.EQ.0.AND.FERISO(2).NE.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 REQUIRES IROTAT=1'',
     *                            '' WHENEVER'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' NON-ZERO VALUE OF FERISO(2)'',
     *                            '' IS USED'',       2X,20(1H/),/)')
C
          ERRSTR=' IPNMIX=1 => IROTAT=1 FOR FERISO(2)<>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.(NUAKNO.LT.1.OR.NUBKNO.LT.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUAKNO ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUBKNO ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              NUAKNO,NUBKNO
C
          ERRSTR=' INCORRECT VALUE OF NUAKNO OR NUBKNO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1).AND.
     *   (IPROMI.LT.0.OR.IPROMA.LT.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IPROMI ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IPROMA ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              IPROMI,IPROMA
C
          ERRSTR=' INCORRECT VALUE OF IPROMI OR IPROMA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NPNKNO.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NPNKNO ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              NPNKNO
C
          ERRSTR=' INCORRECT VALUE OF NPNKNO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NTZKNO.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NTZKNO ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              NTZKNO
C
          ERRSTR=' INCORRECT VALUE OF NTZKNO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NPAKNO.LT.1.OR.NPAKNO.GT.2.OR.
     *   (IPAPRO.NE.-1.AND.IPAPRO.NE.+1))) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NPAKNO ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IPAPRO ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              NPAKNO,IPAPRO
C
          ERRSTR=' INCORRECT VALUE OF NPAKNO OR IPAPRO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NBTKNO.GT.1).AND.
     *   (ISOSMI.LT.0.OR.ISOSMA.LT.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ISOSMI ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ISOSMA ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              ISOSMI,ISOSMA
C
          ERRSTR=' INCORRECT VALUE OF ISOSMI OR ISOSMA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1).AND.
     *   (MOD(IN_FIX+IZ_FIX,2).NE.MOD(IPROMI,2).OR.
     *    MOD(IN_FIX+IZ_FIX,2).NE.MOD(IPROMA,2))) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF IPROMI='',I3,'' OR'',
     *                            '' IPROMA='',I3,       2X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH PARTICLE'',
     *                            '' NOS.'',             2X,20(1H/),/)')
     *              IPROMI,IPROMA
C
          ERRSTR=' IPROMI/IPROMA INCOMPATIBLE WITH PART.NOS. IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NBTKNO.GT.1).AND.
     *   (MOD(IN_FIX+IZ_FIX,2).NE.MOD(ISOSMI,2).OR.
     *    MOD(IN_FIX+IZ_FIX,2).NE.MOD(ISOSMA,2))) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF ISOSMI='',I3,'' OR'',
     *                            '' ISOSMA='',I3,       2X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH PARTICLE'',
     *                            '' NOS.'',             2X,20(1H/),/)')
     *              ISOSMI,ISOSMA
C
          ERRSTR=' ISOSMI/ISOSMA INCOMPATIBLE WITH PART.NOS. IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUAKNO.EQ.1.AND.NUBKNO.GT.1.AND.
     *    MOD(IN_FIX+IZ_FIX,2).NE.MOD(IABS(KPROJE),2)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF KPROJE='',I3,
     *                                                  16X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH PARTICLE'',
     *                            '' NOS.'',             1X,20(1H/),/)')
     *              KPROJE
C
          ERRSTR=' KPROJE IS INCOMPATIBLE WITH PARTICLE NOS. IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUBKNO.GT.1.AND.IAXIAP.EQ.-1) THEN
C
          WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' IAXIAP=-1 (AXIALIZATION OF DENS.)'',
     *                                                  2X,20(1H/),/,
     *                1X,20(1H/),'' IS INCOMPAT. WITH ANG. MOM.'',
     *                           '' PROJ.'',            2X,20(1H/),/)')
C
          ERRSTR=' IAXIAP=-1 INCOMPATIBLE WITH AMP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUAKNO.EQ.1.AND.NUBKNO.GT.1.AND.
     *    ABS(KPROJE).GT.IPROMA) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF KPROJE='',I3,
     *                                                16X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH IPROMA='',I3,
     *                            ''   '',             2X,20(1H/),/)')
     *              KPROJE,IPROMA
C
          ERRSTR=' KPROJE IS INCOMPATIBLE WITH IPROMA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NATKNO.EQ.1.AND.NBTKNO.GT.1.AND.
     *    IN_FIX-IZ_FIX.NE.ISOSTZ) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF KSOSTZ='',I3,
     *                            '' IN 1D ISO.PROJ'',      20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH PARTICLE'',
     *                            '' NOS.'',             2X,20(1H/),/,
     *                 1X,20(1H/),'' IN_FIX='',I3,'' IZ_FIX='',I3,
     *                                                  14X,20(1H/),/)')
     *              ISOSTZ,IN_FIX,IZ_FIX
C
          ERRSTR=' KSOSTZ IS INCOMPATIBLE WITH PARTICLE NOS. IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NBTKNO.EQ.1.AND.ISOSAD.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF ISOSAD='',I3,
     *                                                16X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH NBTKNO='',I3,
     *                            ''   '',             2X,20(1H/),/)')
     *              ISOSAD,NBTKNO
C
          ERRSTR=' ISOSAD IS INCOMPATIBLE WITH NBTKNO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFERME.LT.-1.OR.IFERME.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IFERME ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              IFERME
C
          ERRSTR=' INCORRECT VALUE OF IFERME IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFERME.NE.0.AND.(IFERME.NE.IBETME.OR.
     *                 IIFERR.NE.0.OR.ITFERR.NE.2.OR.ISFERR.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFERME INCONSISTENT WITH IBETME'',
     *                            ''   '',       2X,20(1H/),/)')
C
          ERRSTR=' IFERME IS INCOMPATIBLE WITH IBETME IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IBETME.LT.-1.OR.IBETME.GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IBETME ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *              IBETME
C
          ERRSTR=' INCORRECT VALUE OF IBETME IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IBETME.NE.0.AND.NBTKNO.EQ.1.AND.ISOSMI.NE.ITFERR) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF ISOSMI='',I3,
     *                            '' (FOR NBTKNO=1)'', 1X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH ITFERR='',I3,
     *                            ''   '',             2X,20(1H/),/)')
     *              ISOSMI,ITFERR
C
          ERRSTR=' FOR NBTKNO=1, ISOSMI INCOMPAT. WITH ITFERR IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.LT.1.AND.IBETME.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF IBETME='',I3,
     *                            ''               '', 1X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH IPRGCM='',I3,
     *                            ''   '',             2X,20(1H/),/)')
     *              IBETME,IPRGCM
C
          ERRSTR=' IBETME<>0 INCOMPATIBLE WITH IPRGCM=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NBTKNO.GT.1.AND.ABS(ISOSTZ).GT.ISOSMA) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF KSOSTZ='',I3,
     *                                                16X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH ISOSMA='',I3,
     *                            ''   '',             2X,20(1H/),/)')
     *              ISOSTZ,ISOSMA
C
          ERRSTR=' KSOSTZ IS INCOMPATIBLE WITH ISOSMA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUAKNO.GT.1.AND.
     *   (ISIMPY.EQ.1.OR.ISIGNY.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NUAKNO>1  (3D ANG. MOM.'',
     *                            '' PROJECTION)'',      1X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE  WITH  ISIMPY=1 '',
     *                            ''   '',               1X,20(1H/),/,
     *                 1X,20(1H/),''             NOR  WITH  ISIGNY=1 '',
     *                            ''   '',               1X,20(1H/),/)')
C
          ERRSTR=' NUAKNO>1 INCOMPATIBLE WITH ISIMPY/ISIGNY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C            ATTENTION: BEFORE VERSION (2.66B), THE TWO TESTS BELOW WERE
C                       MISSING AND THUS THE ANGULAR MOMENTUM PROJECTION
C                       WAS POSSIBLE FOR CONSERVED "ISIMT_"  SYMMETRIES,
C                       WHICH WAS GIVING BAD INCONSISTENT RESULTS.
C                       THIS BUG WAS CORRECTED ON 30/07/2013 IN  VERSION
C                       (2.66B).
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUAKNO.GT.1.AND.
     *   (ISIMTX.EQ.1.OR.JSIMTY.EQ.1.OR.ISIMTZ.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NUAKNO>1  (3D ANG. MOM.'',
     *                            '' PROJECTION)'',      1X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE  WITH  ISIMTX=1,'',
     *                            ''   '',               1X,20(1H/),/,
     *                 1X,20(1H/),'' ISIMTY=1,  NOR   WITH  ISIMTZ=1 '',
     *                            ''   '',               1X,20(1H/),/)')
C
          ERRSTR=' NUAKNO>1 INCOMP. W. ISIMTX/ISIMTY/ISIMTZ=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NUAKNO.EQ.1.AND.NUBKNO.GT.1.AND.
     *   (ISIMTX.EQ.1.OR.ISIMTZ.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NUAKNO=1 AND NUBKNO>1'',
     *                            '' (1D ANG.M.P.)'',    1X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE  WITH  ISIMTX=1,'',
     *                            ''   '',               1X,20(1H/),/,
     *                 1X,20(1H/),''             NOR  WITH  ISIMTZ=1 '',
     *                            ''   '',               1X,20(1H/),/)')
C
          ERRSTR=' NUAKNO=1&NUBKNO>1 INCOMP. ISIMTX/ISIMTZ=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C            THE TESTS BELOW WERE COMMENTED OUT ON 10.04.2017 IN (2.79C)
C            AFTER THE CALCULATION OF KERNELS BETWEEN ALL  K-PROJECTIONS
C            WAS IMPLEMENTED IN PROANG FOR AXIAL PROJECTION.
C=======================================================================
C
C     IF (IPRGCM.GE.1.AND.NUAKNO.EQ.1.AND.IRMPRI.EQ.1) THEN
C
C         WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),'' FOR IPRGCM>0, IRMPRI=1 NOT'',
C    *                            '' ALLOWED'',          2X,20(1H/),/,
C    *                 1X,20(1H/),'' UNLESS NUAKNO>1 (3D PROJ.)'',
C    *                                                  10X,20(1H/),/)')
C
C         ERRSTR=' IPRGCM>0 AND IRMPRI=1/NUAKNO=1 IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C
C     IF (IPRGCM.GE.1.AND.NUAKNO.EQ.1.AND.IKEPRI.EQ.1) THEN
C
C         WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),'' FOR IPRGCM>0, IKEPRI=1 NOT'',
C    *                            '' ALLOWED'',          2X,20(1H/),/,
C    *                 1X,20(1H/),'' UNLESS NUAKNO>1 (3D PROJ.)'',
C    *                                                  10X,20(1H/),/)')
C
C         ERRSTR=' IPRGCM>0 AND IKEPRI=1/NUAKNO=1 IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C
      IF (IPAKER.EQ.1.AND.(NUASTA.LT.1.OR.NUASTO.GT.NUAKNO.OR.
     *                                    NUASTA.GT.NUASTO.OR.
     *                     NUGSTA.LT.1.OR.NUGSTO.GT.NUAKNO.OR.
     *                                    NUGSTA.GT.NUGSTO)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUASTA ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUASTO ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUGSTA ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUGSTO ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *
     *              NUASTA,NUASTO,NUGSTA,NUGSTO
C
          ERRSTR=' VALUES OF NUASTA/NUASTO/NUGSTA/NUGSTO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAK3D.EQ.1.AND.(NATSTA.LT.1.OR.NATSTO.GT.NATKNO.OR.
     *                                    NATSTA.GT.NATSTO.OR.
     *                     NGTSTA.LT.1.OR.NGTSTO.GT.NATKNO.OR.
     *                                    NGTSTA.GT.NGTSTO)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NATSTA ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NATSTO ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NGTSTA ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NGTSTO ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *
     *              NATSTA,NATSTO,NGTSTA,NGTSTO
C
          ERRSTR=' VALUES OF NATSTA/NATSTO/NGTSTA/NGTSTO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAKER.EQ.1.AND.IPRGCM.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAKER=1 REQUIRES IPRGCM>0'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IPAKER=1 REQUIRES IPRGCM>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAK3D.EQ.1.AND.IPAKER.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAK3D=1 REQUIRES IPAKER=1'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IPAK3D=1 REQUIRES IPAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAK3D.EQ.1.AND.ISAKER.NE.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAK3D=1 REQUIRES ISAKER=2'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IPAK3D=1 REQUIRES ISAKER=2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAALL.EQ.1.AND.IPAKER.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAALL=1 REQUIRES IPAKER=1'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IPAALL=1 REQUIRES IPAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAALL.EQ.1.AND.(NUBSTA.LT.1.OR.NUBSTO.GT.NUBKNO.OR.
     *                                    NUBSTA.GT.NUBSTO.OR.
     *                     NUTSTA.LT.1.OR.NUTSTO.GT.NBTKNO.OR.
     *                                    NUTSTA.GT.NUTSTO)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUBSTA ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUBSTO ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUTSTA ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NUTSTO ='',I4,
     *                            ''   '',       2X,20(1H/),/)')
     *
     *              NUBSTA,NUBSTO,NUTSTA,NUTSTO
C
          ERRSTR=' VALUES OF NUBSTA/NUBSTO/NUTSTA/NUTSTO IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISAKER.GE.1.AND.IPRGCM.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISAKER>0 REQUIRES IPRGCM>0'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' ISAKER>0 REQUIRES IPRGCM>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAKER.NE.0.AND.(ISAKER.LT.1.OR.ISAKER.GT.2)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAKER<>0 REQUIRES 0<ISAKER<3'',
     *                            ''     '',       2X,20(1H/),/)')
C
          ERRSTR=' IPAKER<>1 REQUIRES 0<ISAKER<3 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPARAL.NE.0.AND.IPARAL.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ONLY IPARAL=0 OR 1 ALLOWED,'',
     *                            '' NOW:'',I3,     2X,20(1H/),/)')
     *    IPARAL
C
          ERRSTR=' IPARAL OTHER THAN 0 OR 1 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPARAL.EQ.1.AND.IPAKER.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPARAL=1 ALLOWED ONLY FOR '',
     *                            '' IPAKER=1'',       2X,20(1H/),/)')
C
          ERRSTR=' IPARAL=1 ALLOWED ONLY FOR IPAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPARAT.NE.0.AND.IPARAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ONLY IPARAT=0 OR 1 ALLOWED,'',
     *                            '' NOW:'',I3,     2X,20(1H/),/)')
     *    IPARAT
C
          ERRSTR=' IPARAT OTHER THAN 0 OR 1 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPARAT.EQ.1.AND.IPAKER.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPARAT=1 ALLOWED ONLY FOR '',
     *                            '' IPAKER=1'',       2X,20(1H/),/)')
C
          ERRSTR=' IPARAT=1 ALLOWED ONLY FOR IPAKER=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (KFIKER.GE.1.AND.ISAKER.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KFIKER>0 ALLOWED ONLY FOR '',
     *                            '' ISAKER>0'',       2X,20(1H/),/)')
C
          ERRSTR=' KFIKER>0 ALLOWED ONLY FOR ISAKER>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (KFIKER.LT.1.AND.ISAKER.EQ.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KFIKER=0 NOT ALLOWED FOR '',
     *                            '' ISAKER=2'',       3X,20(1H/),/)')
C
          ERRSTR=' KFIKER=0 NOT ALLOWED FOR ISAKER=2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISAKER.EQ.1.AND.(KFIKER.LT.0.OR.KFIKER.GT.999)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ONLY 0=<KFIKER=<999 ALLOWED,'',
     *                            '' NOW:'',I6,     2X,20(1H/),/)')
     *    KFIKER
C
          ERRSTR=' KFIKER<0 OR KFIKER>999 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISAKER.EQ.2.AND.(KFIKER.LT.0.OR.KFIKER.GT.99999)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ONLY 0=<KFIKER=<99999 ALLOWED,'',
     *                            '' NOW:'',I8,     2X,20(1H/),/)')
     *    KFIKER
C
          ERRSTR=' KFIKER<0 OR KFIKER>99999 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.(INIROT.GE.1.OR.
     *                     INIINV.GE.1.OR.
     *                     INIKAR.GE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0 REQUIRES INIROT=0'',
     *                            ''         '',      1X,20(1H/),/,
     *                 1X,20(1H/),'' AND INIINV=0  AND INIKAR=0'',
     *                            ''         '',      1X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0 REQUIRES INIROT=INIINV=INIKAR=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFCONT.EQ.1.AND.(INIROT.GE.1.OR.
     *                     INIINV.GE.1.OR.
     *                     INIKAR.GE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFCONT=1 REQUIRES INIROT=0'',
     *                            ''         '',      2X,20(1H/),/,
     *                 1X,20(1H/),'' AND INIINV=0  AND INIKAR=0'',
     *                            ''         '',       2X,20(1H/),/)')
C
          ERRSTR=' IFCONT=1 REQUIRES INIROT=INIINV=INIKAR=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ILCONT.LT.0.OR.ILCONT.GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ILCONT='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    ILCONT
C
          ERRSTR=' INCORRECT VALUE OF ILCONT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ILCONT.EQ.1.AND.(INIROT.GE.1.OR.
     *                     INIINV.GE.1.OR.
     *                     INIKAR.GE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ILCONT=1 REQUIRES INIROT=0'',
     *                            ''         '',      2X,20(1H/),/,
     *                 1X,20(1H/),'' AND INIINV=0  AND INIKAR=0'',
     *                            ''         '',       2X,20(1H/),/)')
C
          ERRSTR=' ILCONT=1 REQUIRES INIROT=INIINV=INIKAR=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IWRIOL.EQ.1.AND.(INIROT.GE.1.OR.
     *                     INIINV.GE.1.OR.
     *                     INIKAR.GE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NONE OF INIROT>0, INIINV>0,'',
     *                            '' INIKAR>0'',      1X,20(1H/),/,
     *                 1X,20(1H/),'' IS COMPATIBLE WITH IWRIOL=1'',
     *                            ''         '',      1X,20(1H/),/)')
C
          ERRSTR=' INIROT/INIINV/INIKAR>0 REQUIRES IWRIOL=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.ISYMDE.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0 REQUIRES ISYMDE=0'',
     *                            ''         '',      1X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0 REQUIRES ISYMDE=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GT.1.AND.
     *   (IABS(IFRWAV).LT.1.OR.IABS(IFRWAV).GT.999)) THEN
C
          WRITE(NFIPRI,'(/,
     *             1X,20(1H/),'' IPRGCM>1 REQUIRES 0<ABS(IFRWAV)<1000'',
     *                                                   2X,20(1H/),/)')
C
          ERRSTR=' INCORRECT IFRWAV FOR IPRGCM>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NAMKER.NE.1.AND.IFRWAV.GT.NUCONF) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NAMKER<>1 REQUIRES'',
     *                            '' IFRWAV<=NUCONF '',2X,20(1H/),/)')
C
          ERRSTR=' FOR NAMKER<>1, IFRWAV>NUCONF IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NAMKER.NE.1.AND.ITOWAV.GT.NUCONF) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NAMKER<>1 REQUIRES'',
     *                            '' ITOWAV<=NUCONF '',2X,20(1H/),/)')
C
          ERRSTR=' FOR NAMKER<>1, ITOWAV>NUCONF IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NAMKER.NE.1.AND.ILCONF.GT.NUCONF) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NAMKER<>1 REQUIRES'',
     *                            '' ILCONF<=NUCONF '',2X,20(1H/),/)')
C
          ERRSTR=' FOR NAMKER<>1, ILCONF>NUCONF IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NAMKER.NE.1.AND.
     *   (MINVAL(INCONF).LT.0.OR.MAXVAL(INCONF).GT.NUCONF)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE(S) OF INCONF'',
     *                            '' <0 OR >NUCONF  '',2X,20(1H/),/)')
C
          ERRSTR=' VALUE(S) OF INCONF <0 OR >NUCONF IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GT.1.AND.(ITOWAV.LT.1.OR.ITOWAV.GT.999)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>1 REQUIRES 0<ITOWAV<1000'',
     *                            ''   '',       2X,20(1H/),/)')
C
          ERRSTR=' INCORRECT ITOWAV FOR IPRGCM>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.ISAKER.GE.1.AND.
     *   (ITOWAV.LT.1.OR.ITOWAV.GT.999)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0 AND ISAKER>0 REQUIRES '',
     *                            ''   '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' 0<ITOWAV<1000                  '',
     *                            ''   '',       2X,20(1H/),/)')
C
          ERRSTR=' INCORRECT ITOWAV FOR IPRGCM>0, ISAKER>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IWRWAV.EQ.1.AND.(ITOWAV.LT.1.OR.ITOWAV.GT.999)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IWRWAV=1 REQUIRES 0<ITOWAV<1000'',
     *                            ''   '',       2X,20(1H/),/)')
C
          ERRSTR=' INCORRECT ITOWAV FOR IWRWAV=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1).AND.
     *   (MOD(IN_FIX+IZ_FIX,2).NE.MOD(ISLPRI,2).OR.
     *    MOD(IN_FIX+IZ_FIX,2).NE.MOD(ISUPRI,2))) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF ISLPRI='',I3,'' OR'',
     *                            '' ISUPRI='',I3,       2X,20(1H/),/,
     *                 1X,20(1H/),'' IS INCOMPATIBLE WITH PARTICLE'',
     *                            '' NOS.'',             2X,20(1H/),/)')
     *              ISLPRI,ISUPRI
C
          ERRSTR=' ISLPRI/ISUPRI INCOMPATIBLE WITH PART.NOS. IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1).AND.
     *    IENPRI.LT.0.OR.IENPRI.GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IENPRI ='',I2,
     *                            ''   '',       4X,20(1H/),/)')
     *
     *                 IENPRI
C
          ERRSTR=' INCORRECT VALUE OF IENPRI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1).AND.
     *    ISRPRI.LT.0.OR.ISRPRI.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ISRPRI ='',I2,
     *                            ''   '',       4X,20(1H/),/)')
     *
     *                 ISRPRI
C
          ERRSTR=' INCORRECT VALUE OF ISRPRI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1).AND.
     *    IMIPRI.LT.0.OR.IMIPRI.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IMIPRI ='',I2,
     *                            ''   '',       4X,20(1H/),/)')
     *
     *                 IMIPRI
C
          ERRSTR=' INCORRECT VALUE OF IMIPRI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1).AND.
     *    IKEPRI.LT.0.OR.IKEPRI.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IKEPRI ='',I2,
     *                            ''   '',       4X,20(1H/),/)')
     *
     *                 IKEPRI
C
          ERRSTR=' INCORRECT VALUE OF IKEPRI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.
     *   (NUAKNO.GT.1.OR.NUBKNO.GT.1).AND.
     *    IRMPRI.LT.0.OR.IRMPRI.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IRMPRI ='',I2,
     *                            ''   '',       4X,20(1H/),/)')
     *
     *                 IRMPRI
C
          ERRSTR=' INCORRECT VALUE OF IRMPRI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IELPRI.LT.0.OR.IELPRI.GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IELPRI ='',I2,
     *                            ''   '',       4X,20(1H/),/)')
     *
     *                 IELPRI
C
          ERRSTR=' INCORRECT VALUE OF IELPRI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GT.1.AND.IWRWAV.EQ.1.AND.
     *    NUAKNO.GT.1.AND.IRMPRI.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' FOR IPRGCM>1, IWRWAV=1 NOT'',
     *                            '' ALLOWED'',          2X,20(1H/),/,
     *                 1X,20(1H/),'' WHEN NUAKNO>1 AND IRMPRI=1'',
     *                                                  10X,20(1H/),/)')
C
          ERRSTR=' IWRWAV=1 AND IPRGCM>1/NUAKNO>1/IRMPRI=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GT.1.AND.IRMPRI.EQ.1.AND.
     *    IELPRI.LT.2.AND.IPRALL.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' FOR IPRGCM>1, IRMPRI=1 NOT'',
     *                            '' ALLOWED'',          2X,20(1H/),/,
     *                 1X,20(1H/),'' UNLESS IELPRI=2 OR 3, OR'',
     *                            '' IPRALL=1'',         5X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>1 AND IRMPRI=1/IELPRI<>2,3;IPRALL=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GT.1.AND.IABS(IFRWAV).GT.ITOWAV) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>1 REQUIRES ABS(IFRWAV)'',
     *                            ''<=ITOWAV'',       1X,20(1H/),/)')
C
          ERRSTR=' ABS(IFRWAV).GT.ITOWAV FOR IPRGCM>1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ILIPON.LT.0.OR.ILIPOP.LT.0.OR.
     *    ILIPON.GT.6.OR.ILIPOP.GT.6.OR.
     *    MOD(ILIPON,2).EQ.1.OR.
     *    MOD(ILIPOP,2).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ILIPON ='',I4,
     *                            '' OR'',       2X,20(1H/),/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ILIPOP ='',I4,
     *                            '' OR'',       2X,20(1H/),/)')
     *
     *                 ILIPON,ILIPOP
C
          ERRSTR=' INCORRECT VALUES OF ILIPON/ILIPOP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (GAUSHI.LT.0.0D0.OR.GAUSHI.GT.8.0D0*ATAN(1.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF GAUSHI='',F8.5,
     *                                           2X,20(1H/),/)')
     *                 GAUSHI
C
          ERRSTR=' INCORRECT VALUE OF GAUSHI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
C=======================================================================
C
      IF ((ILIPON.GE.2.OR.ILIPOP.GE.2).AND.ISIMPY.NE.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE LIPKIN VAPNP METHOD IS'',
     *                                '' NOT YET  '',1X,20(1H/),/,
     *                     1X,20(1H/),'' IMPLEMENTED FOR ISIMPY=0  '',
     *                                ''          '',1X,20(1H/),/)')
C
          ERRSTR=' LIPKIN VAPNP AND ISIMPY=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ILIPON.GE.1.OR.ILIPOP.GE.1).AND.I_COUA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE LIPKIN VAPNP METHOD IS'',
     *                                '' NOT YET  '',1X,20(1H/),/,
     *                     1X,20(1H/),'' IMPLEMENTED FOR I_COUA>0  '',
     *                                ''          '',1X,20(1H/),/)')
C
          ERRSTR=' LIPKIN VAPNP AND I_COUA>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ILIPON.GE.2.AND.LIPKIN.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE LIPKIN VAPNP METHOD'',
     *                                '' INCOMPATIBLE'',1X,20(1H/),/,
     *                     1X,20(1H/),'' WITH LIPKIN-NOGAMI METHOD'',
     *                                '' (NEUTRONS) '',1X,20(1H/),/)')
C
          ERRSTR=' LIPKIN VAPNP INCOMPATIBLE WITH NEUTRON L-N IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ILIPOP.GE.2.AND.LIPKIP.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE LIPKIN VAPNP METHOD'',
     *                                '' INCOMPATIBLE'',1X,20(1H/),/,
     *                     1X,20(1H/),'' WITH LIPKIN-NOGAMI METHOD'',
     *                                '' (PROTONS)  '',1X,20(1H/),/)')
C
          ERRSTR=' LIPKIN VAPNP INCOMPATIBLE WITH PROTON L-N IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      DO LAMBDA=1,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IABS(IFLAGQ(LAMBDA,MIU)).EQ.1) THEN
C
                IF (LAMBDA.GT.NMUCON) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I1,'' IS'',       1X,13(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' NMUCON='',I1,22X,
     *                                                     1X,13(1H/),/
     *
     *                                                )') LAMBDA,NMUCON
C
                    WRITE(ERRSTR,'('' NMUCON AND MULTIPOLE '',
     *                             ''MOMENTS (IFLAGQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.LT.0.AND.ISIMPY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIMPY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' ISIMPY=1 AND MULTIPOLE '',
     *                             ''MOMENTS (IFLAGQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.NE.0.AND.IABS(IAXIAP).GT.0) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' |IAXIAP|>0,'',19X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'(''|IAXIAP|>0 AND MULTIPOLE '',
     *                             ''MOMENTS (IFLAGQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MOD(LAMBDA,2).NE.0.AND.ISIQTY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IPARTY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' ISIQTY=1 AND MULTIPOLE '',
     *                             ''MOMENTS (IFLAGQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      DO LAMBDA=1,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IABS(IFLAGV(LAMBDA,MIU)).EQ.1) THEN
C
                IF (LAMBDA.GT.NMUCON) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I1,'' IS'',       1X,13(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' NMUCON='',I1,22X,
     *                                                     1X,13(1H/),/
     *
     *                                                )') LAMBDA,NMUCON
C
                    WRITE(ERRSTR,'('' NMUCON AND ISOV MULT '',
     *                             ''MOMENTS (IFLAGV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.LT.0.AND.ISIMPY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIMPY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' ISIMPY=1 AND ISOV MULT '',
     *                             ''MOMENTS (IFLAGV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.NE.0.AND.IABS(IAXIAP).GT.0) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' |IAXIAP|>0,'',19X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'(''|IAXIAP|>0 AND ISOV MULT '',
     *                             ''MOMENTS (IFLAGV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MOD(LAMBDA,2).NE.0.AND.ISIQTY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IPARTY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' ISIQTY=1 AND ISOV MULT '',
     *                             ''MOMENTS (IFLAGV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (IF_RPA.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IF_RPA=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' IF_RPA=1 AND ISOV MULT '',
     *                             ''MOMENTS (IFLAGV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (IBROYD.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IBROYD=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' IBROYD=1 AND ISOV MULT '',
     *                             ''MOMENTS (IFLAGV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      ISLALQ=0
C
      DO LAMBDA=1,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALQ(LAMBDA,MIU).EQ.1) THEN
C
                ISLALQ=1
C
                IF (IFLAGQ(LAMBDA,MIU).NE.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IFLAGQ<>1,'',20X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' LINEAR CONSTRAINT AND MULTIPOLE'',
     *                             ''MOMENT (IFLAGQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (LAMBDA.GT.NMUCON) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I1,'' IS'',       1X,13(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' NMUCON='',I1,20X,
     *                                                     1X,13(1H/),/
     *
     *                                                )') LAMBDA,NMUCON
C
                    WRITE(ERRSTR,'('' LINEAR CONSTRAINT AND MULTIPOLE'',
     *                             ''ORDER (NMUCON) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.LT.0.AND.ISIMPY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIMPY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' SYMMETRIES AND LINEAR '',
     *                             ''CONSTRAINTS (IFLALQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MOD(LAMBDA,2).NE.0.AND.ISIQTY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IPARTY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' SYMMETRIES AND LINEAR '',
     *                             ''CONSTRAINTS (IFLALQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      DO LAMBDA=1,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALV(LAMBDA,MIU).EQ.1) THEN
C
                ISLALQ=1
C
                IF (IFLAGV(LAMBDA,MIU).NE.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IFLAGV<>1,'',20X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' LINEAR CONSTRAINT AND ISOV MULT'',
     *                             ''MOMENT (IFLAGV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (LAMBDA.GT.NMUCON) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I1,'' IS'',       1X,13(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' NMUCON='',I1,20X,
     *                                                     1X,13(1H/),/
     *
     *                                                )') LAMBDA,NMUCON
C
                    WRITE(ERRSTR,'('' LINEAR CONSTRAINT AND ISOV MULT'',
     *                             ''ORDER (NMUCON) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.LT.0.AND.ISIMPY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIMPY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' SYMMETRIES AND LINEAR '',
     *                             ''CONSTRAINTS (IFLALV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MOD(LAMBDA,2).NE.0.AND.ISIQTY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR ISOV MULT'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IPARTY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' SYMMETRIES AND LINEAR '',
     *                             ''CONSTRAINTS (IFLALV) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLAGS(LAMBDA,MIU).GT.0) THEN
C
                IF (LAMBDA.GT.NSICON) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE SURFACE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I1,'' IS'',       1X,13(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' NSICON='',I1,11X,
     *                                                     1X,13(1H/),/
     *
     *                                                )') LAMBDA,NSICON
C
                    WRITE(ERRSTR,'('' SURFACE MOMENTS AND MULTIPOLE'',
     *                             ''ORDER (NSICON) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.LT.0.AND.ISIMPY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE SURFACE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''            '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIMPY=1,'',11X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' SURFACE MOMENTS AND ISIMPY '',
     *                             ''IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.NE.0.AND.IABS(IAXIAP).GT.0) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' ERROR: THE SURFACE  '',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' |IAXIAP|>0,'',19X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'(''|IAXIAP|>0 AND SURFACE '',
     *                             ''MOMENTS (IFLAGS) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MOD(LAMBDA,2).NE.0.AND.ISIQTY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE SURFACE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''            '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IPARTY=1,'',11X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' SURFACE MOMENTS AND ISIQTY '',
     *                             ''IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C             TESTING CONSISTENCY OF LINEAR CONSTRAINTS
C=======================================================================
C
CC      In this version, the RPA matrix has not been adapted to the
CC      finite-temperature formalism: IF_RPA=1 is incompatible with
CC      IFTEMP=1
CC
C      IF (IF_RPA.EQ.1.AND.IFTEMP.EQ.1) THEN
CC
C          WRITE(NFIPRI,'(/,1X,23(''/''),
C     *         '' IF_RPA = 1 REQUIRES IFTEMP=0 '',1X,23(''/''),/)')
CC
C          ERRSTR='IF_RPA=1 VS. IFTEMP=1 IN TESDAT'
CC
C      END IF
C
C      Multi constraints using the approximation of the RPA matrix are
C      only available in static (omega=0), simplex-conversing HFB case
C
      IF ((IF_RPA.EQ.1.AND.IPAHFB.LT.1).OR.
     *    (IF_RPA.EQ.1.AND.ISIMPY.NE.1).OR.
     *    (IF_RPA.EQ.1.AND.IROTAT.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,1X,10(''/''),
     *          '' IF_RPA = 1 REQUIRES IPAHFB>0 AND ISIMPY = 1 '',
     *          ''AND IROTAT = 0'',1X,9(''/''),/)')
C
          ERRSTR='IF_RPA=1 VS. IPAHFB/ISIMPY/IROTAT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IF_RPA.EQ.1.AND.IWRIQU.NE.-1) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' IF_RPA=1 INCOMPATIBLE WITH IWRIQU>-1'',
     *          1X,20(1H/),/)')
C
          ERRSTR=' IF_RPA=1 IS INCOMPATIBLE WITH IWRIQU>-1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      Values of the constraints are set under the keyword MULTCONSTR
C      and require IFLAGQ flags to be 1 to be activated. For the RPA
C      method of linear constraint to work, all corresponding IFLALQ
C      flags must also be set to -1.
C
      IF (IF_RPA.EQ.1) THEN
C
          NMESSG=0
          NSWITC=0
          NACTIV=0
C
          DO LAMBDA=1,NDMULT
             DO MIU=0,LAMBDA
C
                IF (IFLAGQ(LAMBDA,MIU).EQ. 1) NMESSG=NMESSG+1
                IF (IFLALQ(LAMBDA,MIU).EQ.-1) NSWITC=NSWITC+1
C
             END DO
          END DO
C
          IF (NMESSG.GT.0.AND.NSWITC.NE.NMESSG) THEN
C
              DO LAMBDA=1,NDMULT
                 DO MIU=0,LAMBDA
C
                    IF (IFLAGQ(LAMBDA,MIU).EQ. 1.AND.
     *                  IFLALQ(LAMBDA,MIU).NE.-1) THEN
C
                        NACTIV=NACTIV+1
                        IFLALQ(LAMBDA,MIU)=-1
C
                    END IF
C
                 END DO
              END DO
C
              WRITE(NFIPRI,'(
     *             '' ////////////////////////////////////////'',
     *             ''//////////////////////////////////////'',/,
     *             '' ////       ERROR: IF_RPA = 1 REQUIRES '',
     *             '' ACTIVE * LINEAR * CONSTRAINTS     /////'',/,
     *             '' ////                                    '',
     *             ''                                 /////'',/,
     *             '' ////               '',I2,
     *             '' LINEAR CONSTRAINTS '',
     *             ''MUST BE ACTIVATED               /////'',/,
     *             '' ////////////////////////////////////////'',
     *             ''//////////////////////////////////////'')')
     *               NACTIV
C
              WRITE(ERRSTR,'('' RPA METHOD AND LINEAR CONSTRAINTS '',
     *                       ''(IFLALQ) IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C      Some inconsistencies between the multipolarity of the
C      constraint and the assumed symmetries will stop the
C      program
C
      DO LAMBDA=1,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            IF (ABS(IFLALQ(LAMBDA,MIU)).EQ.1) THEN
C
                ISLALQ=1
C
                IF (IFLAGQ(LAMBDA,MIU).NE.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IFLAGQ=0'',22X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' THE LIN. MULTIPOLE CONSTRAINTS'',
     *                             '' VS. IFLAGQ IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (LAMBDA.GT.NMUCON) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I1,'' IS'',       1X,13(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' NMUCON='',I1,20X,
     *                                                     1X,13(1H/),/
     *
     *                                                )') LAMBDA,NMUCON
C
                    WRITE(ERRSTR,'('' RPA METHOD AND MOMENTS '',
     *                             ''(NMUCON) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.LT.0.AND.ISIMPY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIMPY=1.'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' LINEAR MULTIPOLE AND ISIMPY '',
     *                             ''(IFLALQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.NE.0.AND.IABS(IAXIAP).GT.0) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' |IAXIAP|>0,'',19X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'(''|IAXIAP|>0 AND LIN. MULT '',
     *                             ''MOMENTS (IFLALQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MOD(LAMBDA,2).NE.0.AND.ISIQTY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIQTY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' LINEAR MULTIPOLE AND ISIQTY '',
     *                             ''(IFLALQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MOD(LAMBDA,2).NE.0.AND.ISIMTZ.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR MULTIPOLE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIMTZ=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' LINEAR MULTIPOLE AND ISIMTZ '',
     *                             ''(IFLALQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      ISLALS=0
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            IF (IFLALS(LAMBDA,MIU).NE.0) THEN
C
                ISLALS=1
C
                IF (LAMBDA.GT.NSICON) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR SURFACE  '',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I1,'' IS'',       1X,13(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' NSICON='',I1,20X,
     *                                                     1X,13(1H/),/
     *
     *                                                )') LAMBDA,NSICON
C
                    WRITE(ERRSTR,'('' LINEAR SURFACE CONSTRAINT AND'',
     *                             ''NSICON IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                IF (MIU.LT.0.AND.ISIMPY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR SURFACE  '',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' ISIMPY=1,'',21X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
                    WRITE(ERRSTR,'('' LINEAR SURFACE CONSTRAINTS AND '',
     *                             ''ISIMPY IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                IF (MIU.NE.0.AND.IABS(IAXIAP).GT.0) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR SURFACE  '',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                     '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' |IAXIAP|>0,'',19X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'(''|IAXIAP|>0 AND LIN. SURF '',
     *                             ''MOMENTS (IFLALQ) IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
                END IF
C
                IF (MOD(LAMBDA,2).NE.0.AND.ISIQTY.EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,
     *                           1X,13(1H/),'' THE LINEAR SURFACE'',
     *                                      '' CONSTRAINT FOR LAMBDA='',
     *                                   I2,''   '',       1X,12(1H/),/,
     *                           1X,13(1H/),''                   '',
     *                                      ''               AND MIU='',
     *                                   I2,'' IS'',       1X,12(1H/),/,
     *                           1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                      '' IPARTY=1,'',18X,
     *                                                     1X,12(1H/),/
     *
     *                                                )') LAMBDA,MIU
C
                    WRITE(ERRSTR,'('' LINEAR SURFACE CONSTRAINTS AND '',
     *                             ''ISIQTY IN TESDAT'')')
                    CALL ERPUSH(ERRSTR,IERROR)
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      IF (IACONT.EQ.1.AND.ISLALQ.EQ.0.AND.ISLALS.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' IACONT=1 IS INCOMPATIBLE WITH'',
     *                            '' NO AUG.LAG'',1X,19(1H/),/)')
C
          ERRSTR='IACONT=1 VS. NO AUG.LAG INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C         THE TESTS BELOW ARE NOT REALLY NEEDED BY THE CODE.  THEY
C         ARE INTRODUCED HERE ONLY BECAUSE THE INFORMATION PRINTED
C         BY "INFPRI" HAS A SPECIFIC STRUCTURE. IT  REQUIRES  THAT
C         ALL FLAGS "IFLAGS" AND "IFLALS" HAVE THE SAME VALUES.
C=======================================================================
C
      DO LAMBDA=1,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            JFLAGS=0
C
            IF (IFLAGS(LAMBDA,MIU).GT.0) THEN
C
               IF (JFLAGS.EQ.0) THEN
                   JFLAGS=IFLAGS(LAMBDA,MIU)
               ELSE
                   IF (JFLAGS.NE.IFLAGS(LAMBDA,MIU)) THEN
                       WRITE(ERRSTR,'('' ALL VALUES OF IFLAGS MUST '',
     *                                ''BE EQUAL IN TESDAT'')')
                       CALL ERPUSH(ERRSTR,IERROR)
                   END IF
               END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            JFLALS=0
C
            IF (IFLALS(LAMBDA,MIU).NE.0) THEN
C
               IF (JFLALS.EQ.0) THEN
                   JFLALS=IFLALS(LAMBDA,MIU)
               ELSE
                   IF (JFLALS.NE.IFLALS(LAMBDA,MIU)) THEN
                       WRITE(ERRSTR,'('' ALL VALUES OF IFLALS MUST '',
     *                                ''BE EQUAL IN TESDAT'')')
                       CALL ERPUSH(ERRSTR,IERROR)
                   END IF
               END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      IF (IFLAGI(1).EQ.0.AND.IFLALI(1).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *              1X,13(1H/),'' ERROR: THE X AUGMENTED'',
     *                         '' CONSTRAINT ON SPIN IS  '',
     *                                        6X,12(1H/),/,
     *              1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                         '' IFLAGI(1)=0'',22X,
     *                                        1X,12(1H/),/
     *                                   )')
C
          ERRSTR='IFLAGI(1) AND IFLALI(1) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IFLAGI(2).EQ.0.AND.IFLALI(2).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *              1X,13(1H/),'' THE Y AUGMENTED'',
     *                         '' CONSTRAINT ON SPIN IS'',
     *                                        1X,12(1H/),/,
     *              1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                         '' IFLAGI(2)=0'',8X,
     *                                        1X,12(1H/),/
     *                                   )')
C
          ERRSTR='IFLAGI(2) AND IFLALI(2) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IFLAGI(3).EQ.0.AND.IFLALI(3).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *              1X,13(1H/),'' THE Z AUGMENTED'',
     *                         '' CONSTRAINT ON SPIN IS'',
     *                                        1X,12(1H/),/,
     *              1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                         '' IFLAGI(3)=0'',8X,
     *                                        1X,12(1H/),/
     *                                   )')
C
          ERRSTR='IFLAGI(3) AND IFLALI(3) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFLAGT(1).EQ.0.AND.IFLALT(1).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *              1X,13(1H/),'' ERROR: THE X AUGMENTED'',
     *                         '' CONSTRAINT ON ISOSPIN IS'',
     *                                        5X,12(1H/),/,
     *              1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                         '' IFLAGT(1)=0'',22X,
     *                                        1X,12(1H/),/
     *                                   )')
C
          ERRSTR='IFLAGT(1) AND IFLALT(1) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IFLAGT(2).EQ.0.AND.IFLALT(2).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *              1X,13(1H/),'' ERROR: THE Y AUGMENTED'',
     *                         '' CONSTRAINT ON ISOSPIN IS'',
     *                                        5X,12(1H/),/,
     *              1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                         '' IFLAGT(2)=0'',22X,
     *                                        1X,12(1H/),/
     *                                   )')
C
          ERRSTR='IFLAGT(2) AND IFLALT(2) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IFLAGT(3).EQ.0.AND.IFLALT(3).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *              1X,13(1H/),'' ERROR: THE Z AUGMENTED'',
     *                         '' CONSTRAINT ON ISOSPIN IS'',
     *                                        5X,12(1H/),/,
     *              1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                         '' IFLAGT(3)=0'',22X,
     *                                        1X,12(1H/),/
     *                                   )')
C
          ERRSTR='IFLAGT(3) AND IFLALT(3) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      DO LAMBDA=1,NDMULT
C
         IF (IFLAGG(LAMBDA).EQ.1) THEN
C
             IF (LAMBDA.GT.NMUCON) THEN
C
                 WRITE(NFIPRI,'(/,
     *                        1X,13(1H/),'' ERROR: THE  SCALAR  '',
     *                                   '' CONSTRAINT FOR LAMBDA='',
     *                                I1,'' IS  '',1X,13(1H/),/,
     *                        1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                   '' NMUCON='',I1,22X,
     *                        1X,13(1H/),/)') LAMBDA,NMUCON
C
                 WRITE(ERRSTR,'('' SCALAR CONSTRAINT AND NMUCON '',
     *                          ''IN TESDAT'')')
                 CALL ERPUSH(ERRSTR,IERROR)
C
             END IF
C
             IF (MOD(LAMBDA,2).NE.0.AND.ISIQTY.EQ.1) THEN
C
                 WRITE(NFIPRI,'(/,
     *                        1X,13(1H/),'' ERROR: THE  SCALAR  '',
     *                                   '' CONSTRAINT FOR LAMBDA='',
     *                                I2,'' IS  '',1X,12(1H/),/,
     *                        1X,13(1H/),'' INCOMPATIBLE WITH'',
     *                                   '' ISIQTY=1,'',22X,
     *                        1X,12(1H/),/)') LAMBDA
C
                 WRITE(ERRSTR,'('' SCALAR CONSTRAINT AND ISIQTY '',
     *                          ''IN TESDAT'')')
                 CALL ERPUSH(ERRSTR,IERROR)
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C
      IF (NMUCON.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMUCON='',I1,'' > NDMULT='',I1,
     *                                     1X,20(1H/),/)') NMUCON,NDMULT
C
          ERRSTR='NMUCON.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NMUCOU.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMUCOU='',I1,'' > NDMULT='',I1,
     *                                     1X,20(1H/),/)') NMUCOU,NDMULT
C
          ERRSTR='NMUCOU.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NMUPRI.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMUPRI='',I1,'' > NDMULT='',I1,
     *                                     1X,20(1H/),/)') NMUPRI,NDMULT
C
          ERRSTR='NMUPRI.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRIBE.EQ.1.AND.NEXBET.GT.NMUPRI) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NEXBET='',I1,'' > NMUPRI='',I1,
     *                                     1X,20(1H/),/)') NEXBET,NMUPRI
C
          ERRSTR='NEXBET.GT.NMUPRI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IWRIBA.GE.0.AND.IPRIBE.NE.1.AND.IPRIBL.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IWRIBA>=0 RQURES IPRIBE=1 OR '',
     *                            ''IPRIBL=1'',       1X,20(1H/),/)')
C
          ERRSTR='IWRIBA>=0 REQUIRES IPRIBE=1 OR IPRIBL=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NILXYZ.LT.1.OR.NILXYZ.GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NILXYZ='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NILXYZ
C
          ERRSTR=' INCORRECT VALUE OF NILXYZ IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IQUNIL.LT.0.OR.IQUNIL.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IQUNIL='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IQUNIL
C
          ERRSTR=' INCORRECT VALUE OF IQUNIL IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NSICON.GT.NDMULT-2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' NSICON='',I1,'' > NDMULT-2='',I1,
     *                                  1X,19(1H/),/)') NSICON,NDMULT-2
C
          ERRSTR='NSICON.GT.NDMULT-2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NSIPRI.GT.NDMULT-2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' NSIPRI='',I1,'' > NDMULT-2='',I1,
     *                                  1X,19(1H/),/)') NSIPRI,NDMULT-2
C
          ERRSTR='NSIPRI.GT.NDMULT-2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NSICON.GT.NDMULT-4.AND.IDOPLM.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' NSICON='',I1,'' > NDMULT-4='',I1,
     *                                  1X,19(1H/),/)') NSICON,NDMULT-4
C
          ERRSTR='NSICON.GT.NDMULT-4 AND IDOPLM=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NSIPRI.GT.NDMULT-4.AND.IDOPLM.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' NSIPRI='',I1,'' > NDMULT-4='',I1,
     *                                  1X,19(1H/),/)') NSIPRI,NDMULT-4
C
          ERRSTR='NSIPRI.GT.NDMULT-4 AND IDOPLM=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NMACON.GT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,18(1H/),'' NMACON='',I2,'' > 0  WHILE'',3X,
     *                                  2X,18(1H/),/,
     *                 1X,18(1H/),'' CONSTRAINTS ON MAGNETIC'',
     *                                  2X,18(1H/),/,
     *                 1X,18(1H/),'' MOMENTS NOT IMPLEMENTED'',
     *                                  2X,18(1H/),/)') NMACON
C
          ERRSTR='NMACON.GT.0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NASCON.GT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,18(1H/),'' NASCON='',I2,'' > 0  WHILE'',3X,
     *                                  2X,18(1H/),/,
     *                 1X,18(1H/),'' CONSTRAINTS ON SPIN-ASY'',
     *                                  2X,18(1H/),/,
     *                 1X,18(1H/),'' MOMENTS NOT IMPLEMENTED'',
     *                                  2X,18(1H/),/)') NASCON
C
          ERRSTR='NASCON.GT.0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C         THE WARNING BELOW WAS REMOVED ON 27/02/2023 IN VERSION 3.17C
C=======================================================================
C
C     IF (NMAPRI.GT.0.AND.ISIQTY.NE.1) THEN
C         WRITE(NFIPRI,'(/,
C    *                 1X,18(1H/),'' NMAPRI='',I2,''>0 AND  PARITY'',
C    *                                  2X,18(1H/),/,
C    *                 1X,18(1H/),'' IS NOT CONSERVED. SINCE'',
C    *                                  2X,18(1H/),/,
C    *                 1X,18(1H/),'' MAGNETIC MOMENTS IN THE'',
C    *                                  2X,18(1H/),/,
C    *                 1X,18(1H/),'' C--O--M REFERENCE FRAME'',
C    *                                  2X,18(1H/),/,
C    *                 1X,18(1H/),'' ARE NOT YET IMPLEMENTED'',
C    *                                  2X,18(1H/),/,
C    *                 1X,18(1H/),'' ONLY LAB VALUES WILL BE'',
C    *                                  2X,18(1H/),/,
C    *                 1X,18(1H/),'' PRINTED ON  THE  OUTPUT'',
C    *                                  2X,18(1H/),/)') NMAPRI
C     END IF
C
C=======================================================================
C
      IF (NMAPRI+1.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMAPRI+1='',I2,''>NDMULT='',I2,
     *                                   2X,20(1H/),/)') NMAPRI+1,NDMULT
C
          ERRSTR='NMAPRI+1.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(MAG2BC).GE.1.AND.MAX(NMACON,NMAPRI).NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' MAX(MAG2BC)>0 REQUIRE'',
     *                                   2X,20(1H/),/,
     *                 1X,20(1H/),'' MAX(NMACON,NMAPRI)=1 '',
     *                                   2X,20(1H/),/)')
C
          ERRSTR='MAX(MAG2BC)>0 REQUIRES MAX(NMACON,NMAPRI)=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(MAGANL).GE.1.AND.NASORD.LT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' MAX(MAGANL)>0 REQUIRE'',
     *                                   2X,20(1H/),/,
     *                 1X,20(1H/),'' NASORD>-1            '',
     *                                   2X,20(1H/),/)')
C
          ERRSTR='MAX(MAGANL)>0 REQUIRES NASORD>-1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MINVAL(MAG2BC).LT.0.OR.MAXVAL(MAG2BC).GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' MAG2BC<0 OR MAG2BC>1 '',
     *                                   2X,20(1H/),/,
     *                 1X,20(1H/),'' IS NOT ALLOWED       '',
     *                                   2X,20(1H/),/)')
C
          ERRSTR=' MAG2BC<0 OR MAG2BC>1 IS NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MINVAL(MAGANL).LT.0.OR.MAXVAL(MAGANL).GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' MAGANL<0 OR MAGANL>1 '',
     *                                   2X,20(1H/),/,
     *                 1X,20(1H/),'' IS NOT ALLOWED       '',
     *                                   2X,20(1H/),/)')
C
          ERRSTR=' MAGANL<0 OR MAGANL>1 IS NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(MAG2BC).GE.1.AND.NMAORD.GT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' MAX(MAG2BC)>0 REQUIRE'',
     *                                   2X,20(1H/),/,
     *                 1X,20(1H/),'' NMAORD=0             '',
     *                                   2X,20(1H/),/)')
C
          ERRSTR='MAX(MAG2BC)>0 REQUIRES NMAORD=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NASPRI+1.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NASPRI+1='',I2,''>NDMULT='',I2,
     *                                   2X,20(1H/),/)') NASPRI+1,NDMULT
C
          ERRSTR='NASPRI+1.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NMACON+1.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMACON+1='',I2,''>NDMULT='',I2,
     *                                   2X,20(1H/),/)') NMACON+1,NDMULT
C
          ERRSTR='NMACON+1.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NASCON+1.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NASCON+1='',I2,''>NDMULT='',I2,
     *                                   2X,20(1H/),/)') NASCON+1,NDMULT
C
          ERRSTR='NASCON+1.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NMUPOW.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMUPOW='',I2,''>NDMULT='',I2,
     *                                   2X,20(1H/),/)') NMUPOW,NDMULT
C
          ERRSTR='NMUPOW.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NMAORD.GT.NDMORD) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMAORD='',I2,''>NDMORD='',I2,
     *                                     2X,20(1H/),/)') NMAORD,NDMORD
C
          ERRSTR='NMAORD.GT.NDMORD IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NASORD.GT.NDMORD) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NASORD='',I2,''>NDMORD='',I2,
     *                                     2X,20(1H/),/)') NASORD,NDMORD
C
          ERRSTR='NASORD.GT.NDMORD IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NASORD.LT.-1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NASORD='',I2,'' < -1   '',2X,
     *                                     2X,20(1H/),/)') NASORD
C
          ERRSTR='NASORD < -1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NRAORD.GT.NDMORD) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NRAORD='',I2,''>NDMORD='',I2,
     *                                     2X,20(1H/),/)') NRAORD,NDMORD
C
          ERRSTR='NRAORD.GT.NDMORD IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NDMULR.GT.NDMULT) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NDMULR='',I2,''>NDMULT='',I2,
     *                                     2X,20(1H/),/)') NDMULR,NDMULT
C
          ERRSTR='NDMULR.GT.NDMULT IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NMURED.GT.NDMULR) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMURED='',I2,''>NDMULR='',I2,
     *                                     2X,20(1H/),/)') NMURED,NDMULR
C
          ERRSTR='NMURED.GT.NDMULR IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NMARED.GT.NDMULR) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMARED='',I2,''>NDMULR='',I2,
     *                                     2X,20(1H/),/)') NMARED,NDMULR
C
          ERRSTR='NMARED.GT.NDMULR IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NASRED.GT.NDMULR) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NASRED='',I2,''>NDMULR='',I2,
     *                                     2X,20(1H/),/)') NASRED,NDMULR
C
          ERRSTR='NASRED.GT.NDMULR IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NMARED.GT.NMURED) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NMARED='',I2,''>NMURED='',I2,
     *                                     2X,20(1H/),/)') NMARED,NMURED
C
          ERRSTR='NMARED.GT.NMURED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NASRED.GT.NMURED) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NASRED='',I2,''>NMURED='',I2,
     *                                     2X,20(1H/),/)') NASRED,NMURED
C
          ERRSTR='NASRED.GT.NMURED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C        ATTENTION: THE TEST BELOW, INTRODUCED  IN  VERSION  3.20P,  WAS
C                   STOPPING THE CODE FOR THE DEFAULT VALUES OF NASRED=1
C                   (INTRODUCED  IN  VERSION  3.17G)    AND    NASORD=-1
C                   (INTRODUCED  IN  VERSION  3.18T).  THIS   HAS   BEEN
C                   RECTIFIED ON 27/10/2023 IN VERSION 3.20S BY CHANGING
C                   THE DEFAULT VALUE TO NASRED=0. AS A RESULT, THE CODE
C                   NOW DOES NOT CALCULATE OR PRINT THE  KERNELS/REDUCED
C                   MOMENTS UNLESS NASRED>0 IS  EXPLICITLY  SET  IN  THE
C                   INPUT DATA FILE.
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NASRED.GE.1.AND.NASORD.LE.-1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NASRED='',I2,''&NASORD<0 '',
     *                                     2X,20(1H/),/)') NASRED
C
          ERRSTR='NASRED>0 & NASORD<0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NSIRED.GT.NDMULR) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NSIRED='',I2,''>NDMULR='',I2,
     *                                     2X,20(1H/),/)') NSIRED,NDMULR
C
          ERRSTR='NSIRED.GT.NDMULR IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.NSIRED.GT.NMURED) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NSIRED='',I2,''>NMURED='',I2,
     *                                     2X,20(1H/),/)') NSIRED,NMURED
C
          ERRSTR='NSIRED.GT.NMURED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.LDPNMX.LE.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0 REQUIRES LDPNMX>2 '',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' IPRGCM>0 REQUIRES LDPNMX >2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IROTAT.NE.1.AND.ABS(OMEGAY).GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IROTAT=0 ENCOUNTERED & OMEGAY='',
     *                                       F6.3,1X,20(1H/),/)') OMEGAY
C
          ERRSTR='IROTAT/OMEGAY INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IRENMA.GE.1.AND.(I_YUKA.GE.1
     *                 .OR.I_GOGA.GE.1.OR.IGOGPA.GE.1
     *                 .OR.I_REGA.GE.1.OR.IREGPA.GE.1
     *                 .OR.I_SEPA.GE.1.OR.ISEPPA.GE.1
     *                 .OR.MAXVAL(I_FSTA).GE.1.OR.MAXVAL(IFSTPA).GE.1
     *                 .OR.I_COUA.GE.1.OR.ICOUPA.GE.1)) THEN
C
          WRITE(NFIPRI,'(/,1X,17(''/''),'' IRENMA>0 CANNOT YET BE'',
     *                 '' USED WITH    '',1X,16(''/''),/,
     *                        17(''/''),'' I_YUKA, I_GOGA, IGOGPA'',
     *                 '' > 0, OR      '',1X,16(''/''),/,
     *                        17(''/''),'' I_REGA, IREGPA, I_SEPA'',
     *                 '', ISEPPA OR   '',1X,16(''/''),/,
     *                        17(''/''),'' I_FSTA(:), IFSTPA(:), '',
     *                 '', > 0 OR      '',1X,16(''/''),/,
     *                        17(''/''),'' I_COUA, ICOUPA > 0    '',
     *                 ''              '',1X,16(''/''),/)')
C
          ERRSTR=' IRENMA>0 AND FINITE-RANGE FORCES IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IRENIN.GE.1.AND.(I_YUKA.GE.1
     *                 .OR.I_GOGA.GE.1.OR.IGOGPA.GE.1
     *                 .OR.I_REGA.GE.1.OR.IREGPA.GE.1
     *                 .OR.MAXVAL(I_FSTA).GE.1.OR.MAXVAL(IFSTPA).GE.1
     *                 .OR.I_SEPA.GE.1.OR.ISEPPA.GE.1)) THEN
C
          WRITE(NFIPRI,'(/,1X,17(''/''),'' IRENIN>0 CANNOT YET BE'',
     *                 '' USED WITH    '',1X,16(''/''),/,
     *                        17(''/''),'' I_YUKA, I_GOGA, IGOGPA'',
     *                 '' > 0, OR      '',1X,16(''/''),/,
     *                        17(''/''),'' I_REGA, IREGPA, I_SEPA'',
     *                 '', ISEPPA OR   '',1X,16(''/''),/,
     *                        17(''/''),'' I_FSTA(:), IFSTPA(:), '',
     *                 '', > 0 OR      '',1X,16(''/''),/,
     *                        17(''/''),'' I_COUA, ICOUPA > 0    '',
     *                 ''              '',1X,16(''/''),/)')
C
          ERRSTR=' IRENIN>0 AND FINITE-RANGE FORCES IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IRENMA.EQ.1.AND.IRENIN.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' IRENIN=1 CANNOT YET BE'',
     *                                '' USED        '',2X,20(1H/),/,
     *                     1X,20(1H/),'' TOGETHER WITH IRENMA=1    '',
     *                                ''         '',2X,20(1H/),/)')
C
          ERRSTR=' IRENIN=1 AND IRENMA=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.1.AND.(IRENMA.EQ.1.OR.IRENIN.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' IRENMA/IRENIN=1 CANNOT YET'',
     *                                '' BE USED '',2X,20(1H/),/,
     *                     1X,20(1H/),'' TOGETHER WITH IPRGCM>0    '',
     *                                ''         '',2X,20(1H/),/)')
C
          ERRSTR=' IRENIN=1 OR IRENMA=1 WITH IPRGCM>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFERAN.EQ.1.AND.(ISIMPY.NE.1.OR.ISIQTY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' IFERAN=1 CANNOT YET BE'',
     *                                '' USED        '',2X,20(1H/),/,
     *                     1X,20(1H/),'' UNLESS ISIMPY=1 AND'',
     *                                '' ISIQTY=1'',9X,20(1H/),/)')
C
          ERRSTR=' IFERAN=1 AND ISIMPY=0 OR ISIQTY=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFERAP.EQ.1.AND.(ISIMPY.NE.1.OR.ISIQTY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' IFERAP=1 CANNOT YET BE'',
     *                                '' USED        '',2X,20(1H/),/,
     *                     1X,20(1H/),'' UNLESS ISIMPY=1 AND'',
     *                                '' ISIQTY=1'',9X,20(1H/),/)')
          ERRSTR=' IFERAP=1 AND ISIMPY=0 OR ISIQTY=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFERAN.EQ.1.AND.IFEFIN.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFERAN=1 IS INCOMPATIBLE WITH'',
     *                            '' IFEFIN=1'',1X,19(1H/),/)')
C
          ERRSTR='IFERAN=1 VS. IFEFIN=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFERAP.EQ.1.AND.IFEFIP.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFERAP=1 IS INCOMPATIBLE WITH'',
     *                            '' IFEFIP=1'',1X,19(1H/),/)')
C
          ERRSTR='IFERAP=1 VS. IFEFIP=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JPABCS.NE.0.AND.JPABCS.NE.1.AND.
     *    JPABCS.NE.2.AND.JPABCS.NE.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' VALUE OF IPABCS='',I2,
     *                            '' IS NOT SUPPORTED'',3X,20(1H/),/,
     *                 1X,20(1H/),'' USE ONLY IPABCS='',
     *                            '' 0,1,2, OR 3     '',5X,20(1H/),/)')
     *          JPABCS
C
          ERRSTR=' UNSUPPORTED VALUE OF IPABCS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAIRI.EQ.1.AND.IPAHFB.LT.1.AND.JPABCS.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAIRI=1 REQUIRES EITHER'',
     *                            '' IPAHFB>0'',4X,20(1H/),/,
     *                 1X,20(1H/),'' OR IPABCS>0             '',
     *                            ''         '',4X,20(1H/),/)')
C
          ERRSTR='IPAIRI/IPAHFB/IPABCS INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAIRI.EQ.1.AND.IPAHFB.GE.1.AND.JPABCS.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPABCS>0 IS INCOMPATIBLE WITH'',
     *                            '' IPAHFB>0'',1X,19(1H/),/)')
C
          ERRSTR='IPABCS>0 VS. IPAHFB>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IWRIQU.NE.-1.AND.ISIMPY.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IWRIQU>-1 REQUIRES ISIMPY=1,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IWRIQU>-1 REQUIRES ISIMPY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IWRIQU.NE.-1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IWRIQU>-1 REQUIRES IPNMIX=0,'',
     *                            '' FOR NOW'',       1X,20(1H/),/)')
C
          ERRSTR=' IWRIQU>-1 REQUIRES IPNMIX=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IWRIQU.NE.-1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IWRIQU>-1 REQUIRES IPAHFB>0,'',
     *                            ''        '',       1X,20(1H/),/)')
C
          ERRSTR=' IWRIQU>-1 REQUIRES IPAHFB>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IWRIRM.EQ.1.AND.IPRGCM.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IWRIRM=1 REQUIRES IPRGCM>0,'',
     *                            ''         '',      1X,20(1H/),/)')
C
          ERRSTR=' IWRIRM=1 REQUIRES IPRGCM>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGOGPA.GE.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGOGPA>0 REQUIRES IPAHFB>0,'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IGOGPA>0 REQUIRES IPAHFB>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IREGPA.GE.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IREGPA>0 REQUIRES IPAHFB>0,'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IREGPA>0 REQUIRES IPAHFB>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISEPPA.GE.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISEPPA>0 REQUIRES IPAHFB>0,'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' ISEPPA>0 REQUIRES IPAHFB>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUPA.GE.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICOUPA>0 REQUIRES IPAHFB>0,'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' ICOUPA>0 REQUIRES IPAHFB>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IFSTPA).GE.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFSTPA(:)>0 REQUIRES IPAHFB>0,'',
     *                            ''     '',       2X,20(1H/),/)')
C
          ERRSTR=' IFSTPA(:)>0 REQUIRES IPAHFB>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGOGPA.GE.1.AND.ISIMPY.NE.1.AND.NEWGOG.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGOGPA>0 REQUIRES ISIMPY=1 OR IT'',
     *                            ''  '',       2X,20(1H/),/,
     *                 1X,20(1H/),''          REQUIRES NEWGOG=1      '',
     *                            ''  '',       2X,20(1H/),/)')
C
          ERRSTR=' IGOGPA>0 REQUIRES ISIMPY=1 OR NEWGOG=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (I_GOGA.GE.1.AND.IPAHFB.GE.1.AND.NOZEPA.EQ.0) THEN
C
          WRITE(NFIPRI,'(
     *                1H*,20(1H/),2X,''WARNING: FOR THE GOGNY FORCE '',
     *                               ''USED'',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''ALONG WITH THE HFB PAIRING, '',
     *                               ''     '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''THE ZERO-RANGE PAIRING FORCE '',
     *                               ''MAY '',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''CONTRIBUTE TO PAIRING CORRELA'',
     *                               ''TION'',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''UNLESS ITS STRENGTH  IS SET '',
     *                               ''TO 0 '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''OR THE SWITCH NOZEPA IS SET '',
     *                               ''TO 1 '',      2X,20(1H/),1H*,/)')
C
      END IF
C
C=======================================================================
C
      IF (I_REGA.GE.1.AND.IPAHFB.GE.1.AND.NOZEPA.EQ.0) THEN
C
          WRITE(NFIPRI,'(
     *                1H*,20(1H/),2X,''WARNING: FOR THE REGUL FORCE '',
     *                               ''USED'',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''ALONG WITH THE HFB PAIRING, '',
     *                               ''     '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''THE ZERO-RANGE PAIRING FORCE '',
     *                               ''MAY '',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''CONTRIBUTE TO PAIRING CORRELA'',
     *                               ''TION'',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''UNLESS ITS STRENGTH  IS SET '',
     *                               ''TO 0 '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''OR THE SWITCH NOZEPA IS SET '',
     *                               ''TO 1 '',      2X,20(1H/),1H*,/)')
C
      END IF
C
C=======================================================================
C
      IF (I_SEPA.GE.1.AND.IPAHFB.GE.1.AND.NOZEPA.EQ.0) THEN
C
          WRITE(NFIPRI,'(
     *                1H*,20(1H/),2X,''WARNING: FOR THE SEPAR FORCE '',
     *                               ''USED'',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''ALONG WITH THE HFB PAIRING, '',
     *                               ''     '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''THE ZERO-RANGE PAIRING FORCE '',
     *                               ''MAY '',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''CONTRIBUTE TO PAIRING CORRELA'',
     *                               ''TION'',       2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''UNLESS ITS STRENGTH  IS SET '',
     *                               ''TO 0 '',      2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''OR THE SWITCH NOZEPA IS SET '',
     *                               ''TO 1 '',      2X,20(1H/),1H*,/)')
C
      END IF
C
C=======================================================================
C
      IF (IQPSTA.EQ.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IQPSTA=1 REQUIRES IPAHFB>0,'',
     *                            ''        '',       2X,20(1H/),/)')
C
          ERRSTR=' IQPSTA=1 REQUIRES IPAHFB>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IQPSTA.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IQPSTA=1 REQUIRES IPNMIX=0,'',
     *                            '' FOR NOW'',       2X,20(1H/),/)')
C
          ERRSTR=' IQPSTA=1 REQUIRES IPNMIX=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IPAIRI.EQ.1.AND.IPAHFB.LT.1).AND.ABS(OMEGAY).GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAIRI=1 AND                    '',
     *                                            5X,20(1H/),/,
     *                 1X,20(1H/),'' IPAHFB=0 ENCOUNTERED & OMEGAY='',
     *                                       F6.3,1X,20(1H/),/)') OMEGAY
C
          ERRSTR='IPAIRI/IPAHFB/OMEGAY INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IROTAT.NE.1.AND.ABS(OMISOY).GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IROTAT=0 ENCOUNTERED & OMISOY='',
     *                                       F6.3,1X,20(1H/),/)') OMISOY
C
          ERRSTR='IROTAT/OMISOY INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IPAIRI.EQ.1.AND.IPAHFB.LT.1).AND.ABS(OMISOY).GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAIRI=1 AND                    '',
     *                                            5X,20(1H/),/,
     *                 1X,20(1H/),'' IPAHFB=0 ENCOUNTERED & OMISOY='',
     *                                       F6.3,1X,20(1H/),/)') OMISOY
C
          ERRSTR='IPAIRI/IPAHFB/OMISOY INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMTX.EQ.1.AND.ABS(OMEGAX).GT.0.0D0) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTX=1 ENCOUNTERED & OMEGAX='',
     *                                       F6.3,1X,20(1H/),/)') OMEGAX
          ERRSTR='ISIMTX/OMEGAX INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
C=======================================================================
C
      IF (ISIMTX.EQ.1.AND.ABS(OMISOX).GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTX=1 ENCOUNTERED & OMISOX='',
     *                                       F6.3,1X,20(1H/),/)') OMISOX
C
          ERRSTR='ISIMTX/OMISOX INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMTX.EQ.1.AND.IFLAGI(1).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTX=1 ENCOUNTERED FOR '',
     *                            '' IFLAGI(1)='',
     *                                      I1,1X,20(1H/),/)') IFLAGI(1)
C
          ERRSTR='ISIMTX/IFLAGI(1) INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMTX.EQ.1.AND.IFTAGI(1).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTX=1 ENCOUNTERED FOR '',
     *                            '' IFTAGI(1)='',
     *                                      I1,1X,20(1H/),/)') IFTAGI(1)
C
          ERRSTR='ISIMTX/IFTAGI(1) INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JSIMTY.EQ.1.AND.ABS(OMEGAY).GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTY=1 ENCOUNTERED & OMEGAY='',
     *                                       F6.3,1X,20(1H/),/)') OMEGAY
C
          ERRSTR='ISIMTY/OMEGAY INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JSIMTY.EQ.1.AND.ABS(OMISOY).GT.0.0D0) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTY=1 ENCOUNTERED & OMISOY='',
     *                                       F6.3,1X,20(1H/),/)') OMISOY
C
          ERRSTR='ISIMTY/OMISOY INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JSIMTY.EQ.1.AND.IFLAGI(2).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTY=1 ENCOUNTERED FOR '',
     *                            '' IFLAGI(2)='',
     *                                      I1,1X,20(1H/),/)') IFLAGI(2)
C
          ERRSTR='ISIMTY/IFLAGI(2) INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JSIMTY.EQ.1.AND.IFTAGI(2).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTY=1 ENCOUNTERED FOR '',
     *                            '' IFTAGI(2)='',
     *                                      I1,1X,20(1H/),/)') IFTAGI(2)
C
          ERRSTR='ISIMTY/IFTAGI(2) INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMTZ.EQ.1.AND.ABS(OMEGAZ).GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTZ=1 ENCOUNTERED & OMEGAZ='',
     *                                       F6.3,1X,20(1H/),/)') OMEGAZ
C
          ERRSTR='ISIMTZ/OMEGAZ INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMTZ.EQ.1.AND.ABS(OMISOZ).GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTZ=1 ENCOUNTERED & OMISOZ='',
     *                                       F6.3,1X,20(1H/),/)') OMISOZ
C
          ERRSTR='ISIMTZ/OMISOZ INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMTZ.EQ.1.AND.IFLAGI(3).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTZ=1 ENCOUNTERED FOR '',
     *                            '' IFLAGI(3)='',
     *                                      I1,1X,20(1H/),/)') IFLAGI(3)
C
          ERRSTR='ISIMTZ/IFLAGI(3) INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMTZ.EQ.1.AND.IFTAGI(3).EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMTZ=1 ENCOUNTERED FOR '',
     *                            '' IFTAGI(3)='',
     *                                      I1,1X,20(1H/),/)') IFTAGI(3)
C
          ERRSTR='ISIMTZ/IFTAGI(3) INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NOITER.LT.0.OR.NOITER.GT.NDITER) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NOITER = '',I3,
     *                            ''   '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' SHOULD NOT EXCEED  NDITER = '',I3,
     *                            ''  OR'',      1X,20(1H/),/,
     *                 1X,20(1H/),'' OTHERWISE INCREASE NDITER TO'',
     *                            '' NOITER'',   1X,20(1H/),/)')
     *           NOITER,NDITER
C
          ERRSTR=' INCORRECT VALUE OF NOITER OR NDITER IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NOITER.LE.0.AND.ICONTI.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICONTI=1 ENCOUNTERED FOR NOITER='',
     *                                         I4,1X,20(1H/),/)') NOITER
C
          ERRSTR='NON-POSITIVE NOITER AND ICONTI=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C         RESTRICTION BELOW HAS BEEN REMOVED IN 2.05K ON 11/12/03 WITH
C         THE ASSMPTION THAT THE CODE AS IS WILL FUNCTION PROPERLY.
C=======================================================================
C
C     IF ((ISIGNY.EQ.1.AND.(ISIMTX.NE.1 .OR.ISIMTZ.NE.1)).OR.
C    *    (ISIGNY.NE.1.AND.(ISIMTX.EQ.1.AND.ISIMTZ.EQ.1))) THEN
C          WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),                   ''  ISIGNY='',I1,
C    *                            '' ENCOUNTERED FOR'','' ISIMTX='',I1,
C    *                                                   3X,20(1H/),/,
C    *                 1X,20(1H/),                    ''         '',1X,
C    *                            ''                '','' ISIMTZ='',I1,
C    *                                                   3X,20(1H/),/)')
C    *
C    *    ISIGNY,ISIMTX,ISIMTZ
C         ERRSTR='ISIGNY/ISIMTX/ISIMTZ/ INCONSISTENCY IN TESDAT'
C     END IF
C
C=======================================================================
C         RESTRICTION BELOW HAS BEEN REMOVED IN 2.05J ON 10/12/03 WITH
C         THE ASSMPTION THAT THE CODE AS IS WILL FUNCTION PROPERLY.
C=======================================================================
C
C     IF (ISIMPY.NE.1.AND.ISIGNY.EQ.1)
C    *                                                              THEN
C          WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),                   ''  ISIMPY='',I1,
C    *                            '' ENCOUNTERED FOR'','' ISIGNY='',I1,
C    *                                                   3X,20(1H/),/)')
C    *
C    *    ISIMPY,ISIGNY
C         ERRSTR='ISIMPY VS. ISIGNY INCONSISTENCY IN TESDAT'
C     END IF
C
C=======================================================================
C
      IF ((ISIMPY.EQ.1.AND.IROTAT.EQ.1.AND.JSIMTY.EQ.1).OR.
     *    (ISIMPY.NE.1.AND.IROTAT.NE.1.AND.JSIMTY.EQ.1).OR.
     *    (ISIMPY.EQ.1.AND.IROTAT.NE.1.AND.JSIMTY.NE.1)) THEN
C
           WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),                   ''  ISIMPY='',I1,
     *                            '' ENCOUNTERED FOR'','' ISIMTY='',I1,
     *                                                   3X,20(1H/),/,
     *                 1X,20(1H/),                    ''         '',1X,
     *                            ''                '','' IROTAT='',I1,
     *                                                   3X,20(1H/),/,
     *                 1X,20(1H/),                    ''  THESE SY'',
     *                            ''MMETRIES ARE NOT'',''  ALLOWED'',
     *                                                   3X,20(1H/),/)')
     *
     *    ISIMPY,JSIMTY,IROTAT
C
          ERRSTR='ISIMPY/ISIMTY/IROTAT/ INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ISIGNY.NE.1.AND.ISIMTX.EQ.1.AND.ISIMTZ.EQ.1).OR.
     *    (ISIGNY.EQ.1.AND.ISIMTX.NE.1.AND.ISIMTZ.EQ.1).OR.
     *    (ISIGNY.EQ.1.AND.ISIMTX.EQ.1.AND.ISIMTZ.NE.1)) THEN
C
           WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),                   ''  ISIGNY='',I1,
     *                            '' ENCOUNTERED FOR'','' ISIMTX='',I1,
     *                                                   3X,20(1H/),/,
     *                 1X,20(1H/),                    ''         '',1X,
     *                            ''                '','' ISIMTZ='',I1,
     *                                                   3X,20(1H/),/,
     *                 1X,20(1H/),                    ''  THESE SY'',
     *                            ''MMETRIES ARE NOT'',''  ALLOWED'',
     *                                                   3X,20(1H/),/)')
     *
     *    ISIGNY,ISIMTX,ISIMTZ
C
          ERRSTR='ISIGNY/ISIMTX/ISIMTZ INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ISIMPY.NE.1.AND.ISIGNY.EQ.1.AND.ISIQTY.EQ.1).OR.
     *    (ISIMPY.EQ.1.AND.ISIGNY.NE.1.AND.ISIQTY.EQ.1).OR.
     *    (ISIMPY.EQ.1.AND.ISIGNY.EQ.1.AND.ISIQTY.NE.1)) THEN
C
           WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),                   ''  IPARTY='',I1,
     *                            '' ENCOUNTERED FOR'','' ISIMPY='',I1,
     *                                                   3X,20(1H/),/,
     *                 1X,20(1H/),                    ''         '',1X,
     *                            ''                '','' ISIGNY='',I1,
     *                                                   3X,20(1H/),/,
     *                 1X,20(1H/),                    ''  THESE SY'',
     *                            ''MMETRIES ARE NOT'',''  ALLOWED'',
     *                                                   3X,20(1H/),/)')
     *
     *    ISIQTY,ISIMPY,ISIGNY
C
          ERRSTR='IPARTY VS. ISIMPY/ISIGNY INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Control tests for BCS pairing
C=======================================================================
C
      IF (JPABCS.NE.0.AND.IPAIRI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPABCS>0 IS INCOMPATIBLE WITH'',
     *                            '' IPAIRI=0'',1X,19(1H/),/)')
C
          ERRSTR='IPABCS>0 VS. IPAIRI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (JPABCS.NE.0.AND.IROTAT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IROTAT=1 IS INCOMPATIBLE WITH'',
     *                            '' THE BCS'',1X,20(1H/),/,
     *                 1X,20(1H/),'' PAIRING, I.E., WITH IPABCS>0'',
     *                                        10X,20(1H/),/)')
C
          ERRSTR='IROTAT=1 VS. IPABCS>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (JPABCS.NE.0.AND.ISIMPY.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISIMPY=0 IS INCOMPATIBLE WITH'',
     *                            '' THE BCS'',  1X,20(1H/),/,
     *                 1X,20(1H/),'' PAIRING, I.E. WITH IPABCS>0'',
     *                            '' (FOR NOW)'',1X,20(1H/),/)')
C
          ERRSTR='ISIMPY=0 VS. IPABCS>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (JPABCS.EQ.3.AND.IDESTA.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPABCS=3 REQUIRES IDESTA=1'',
     *                            '' BECAUSE   '',1X,20(1H/),/,
     *                 1X,20(1H/),'' PAIRING M.E. ARE NOT YET STORED'',
     *                                         7X,20(1H/),/)')
C
          ERRSTR='IPABCS=3 VS. PAIRING MATRIX ELEMENTS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IPAHFB.GE.1.AND.IPAIRI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' IPAHFB>0 IS INCOMPATIBLE WITH'',
     *                            '' IPAIRI=0'',1X,19(1H/),/)')
C
          ERRSTR='IPAHFB>0 VS. IPAIRI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Control tests for Lipkin-Nogami prescription
C=======================================================================
C
      IF (LIPKIN.EQ.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' LIPKIN=1 IS INCOMPATIBLE WITH'',
     *                            '' IPAHFB=0'',1X,19(1H/),/)')
C
          ERRSTR='LIPKIN=1 VS. IPAHFB=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (LIPKIP.EQ.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' LIPKIP=1 IS INCOMPATIBLE WITH'',
     *                            '' IPAHFB=0'',1X,19(1H/),/)')
C
          ERRSTR='LIPKIP=1 VS. IPAHFB=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF ((LIPKIN.EQ.1.OR.LIPKIP.EQ.1).AND.IFTEMP.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,11(1H/),'' LIPKIN=1 AND/OR LIPKIP=1 '',
     *                            ''IS INCOMPATIBLE WITH'',
     *                            '' IFTEMP=1'',1X,11(1H/),/)')
C
          ERRSTR='LIPKIN-NOGAMI VS. IFTEMP=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Control tests for particle-number projection
C=======================================================================
C
      IF (IPNPRJ.EQ.1) THEN
         IF (NPPNPN.LE.0.OR.NPPNPP.LE.0) THEN
             WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' IPNPRJ=1 REQUIRES NPPNPN>0 AND NPPNPP>0'',
     *                              1X,19(1H/),/)')
             ERRSTR='IPNPRJ=1 REQUIRES NPPNPN>0 AND NPPNPP>0 IN TESDAT'
             CALL ERPUSH(ERRSTR,IERROR)
         END IF
         IF (IPAHFB.LT.1.OR.ISIMPY.NE.1.OR.IROTAT.NE.0) THEN
             WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' IPNPRJ=1 REQUIRES IPAHFB=ISIMPY=1,'',
     *                     '' IROTAT=0'',1X,19(1H/),/)')
            ERRSTR='IPNPRJ=1 VS. IPAHFB, ISIMPY, OR IROTAT IN TESDAT'
            CALL ERPUSH(ERRSTR,IERROR)
         END IF
      END IF
C
      IF (IPNPRJ.EQ.1.AND.IFTEMP.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *               1X,20(1H/),''      IPNPRJ=1 REQUIRES IFTEMP=0'',
     *               6X,20(1H/),/)')
C
          ERRSTR=' IPNPRJ=1 IS INCOMPATIBLE WITH IFTEMP=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IPNPRJ.EQ.1.AND.MREVER.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *               1X,20(1H/),''      IPNPRJ=1 REQUIRES MREVER=1'',
     *               6X,20(1H/),/)')
C
          ERRSTR=' IPNPRJ=1 IS INCOMPATIBLE WITH MREVER=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Control tests for finite temperature
C=======================================================================
C
      IF (IFTEMP.EQ.1.AND.(IROTAT.EQ.1.OR.ISIMPY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,14(1H/),'' IFTEMP=1 IS INCOMPATIBLE WITH'',
     *                 '' IROTAT=1 OR ISIMPY=1'',1X,13(1H/),/)')
C
          ERRSTR='IFTEMP=1 VS. IROTAT=1 OR ISIMPY=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IFTEMP.EQ.1.AND.IPAIRI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *               1X,20(1H/),''      IFTEMP=1 REQUIRES IPAIRI=1'',
     *               6X,20(1H/),/)')
C
          ERRSTR=' IFTEMP=1 IS INCOMPATIBLE WITH IPAIRI=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IFTEMP.EQ.1.AND.IWRIQU.NE.-1) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' IFTEMP=1 INCOMPATIBLE WITH IWRIQU>-1'',
     *          1X,20(1H/),/)')
C
          ERRSTR=' IFTEMP=1 IS INCOMPATIBLE WITH IWRIQU>-1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IFTEMP.EQ.1.AND.IWRIRM.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' IFTEMP=1 INCOMPATIBLE WITH IWRIRM=1'',
     *          1X,20(1H/),/)')
C
          ERRSTR=' IFTEMP=1 IS INCOMPATIBLE WITH IWRIRM=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IFTEMP.EQ.1.AND.
     *   (SKYRME.EQ.'UNE0'.OR.SKYRME.EQ.'UNE1'.OR.SKYRME.EQ.'UNE2'))
     *THEN
C
          WRITE(NFIPRI,'(/,1X,15(''/''),48X,15(''/''),/,1X,
     *                  15(''/''),''   ERROR: UNEDF FUNCTIONAL'',
     *                  '' REQUESTED: '',A4,''      '',15(''/''),/,1X,
     *                  15(''/''),''   LIPKIN-NOGAMI PRESCRIPTION'',
     *                  '' MUST BE ACTIVE    '',15(''/''),/,1X,
     *                  15(''/''),''   IT IS INCOMPATIBLE WITH'',
     *                  '' IFTEMP=1             '',15(''/''),/,1X,
     *                  15(''/''),48X,15(''/''))') SKYRME
C
          ERRSTR=' IFTEMP=1 IS INCOMPATIBLE WITH UNEDF EDFs IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWOBA.EQ.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWOBA=1 IS INCOMPATIBLE WITH'',
     *                            '' IPAHFB=0'',1X,19(1H/),/)')
C
          ERRSTR='TWO-BASIS AND IPAHFB=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWOBA.EQ.1.AND.IPAHFB.EQ.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWOBA=1 IS INCOMPATIBLE WITH'',
     *                            '' IPAHFB=2'',1X,19(1H/),/)')
C
          ERRSTR='TWO-BASIS AND IPAHFB=2 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.EQ.1.AND.IPAHFB.EQ.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPNMIX=1 IS INCOMPATIBLE WITH'',
     *                            '' IPAHFB=2'',1X,19(1H/),/)')
C
          ERRSTR='PROT-NEU MIXING AND IPAHFB=2 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ISIMPY.EQ.1.OR.ISIQTY.EQ.1).AND.MAXVAL(NCUSIZ).NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NCUSIZ(:)>0 REQUIRES ISIMP'',
     *                            ''Y=ISIQTY = 0'',1X,19(1H/),/)')
C
          ERRSTR='NCUSIZ(:)>0 REQUIRES ISIMPY=ISIQTY=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.0.AND.
     *    ITWOBA.NE.1.AND.MAXVAL(NCUSIZ).NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWOBA=0 INCOMPATIBLE WITH'',
     *                            '' NCUSIZ(:)>0'',1X,19(1H/),/)')
C
          ERRSTR='FOR NCUSIZ(:)>0, TWO-BASIS METHOD REQUIRED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.0.AND.
     *    LIMQUA.EQ.1.AND.MAXVAL(NCUSIZ).NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' LIMQUA=1 INCOMPATIBLE WITH'',
     *                            '' NCUSIZ(:)>0'',1X,19(1H/),/)')
C
          ERRSTR='FOR NCUSIZ(:)>0, LIMQUA=0 REQUIRED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.0.AND.
     *    LAMCUT.EQ.1.AND.MAXVAL(NCUSIZ).NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' LAMCUT=1 INCOMPATIBLE WITH'',
     *                            '' NCUSIZ(:)>0'',1X,19(1H/),/)')
C
          ERRSTR='FOR NCUSIZ(:)>0, LAMCUT=0 REQUIRED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.0.AND.
     *   (MOD(NCUSIZ(0),2).EQ.1.OR.MOD(NCUSIZ(1),2).EQ.1).AND.
     *    NUQEVE.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NUQEVE=1 INCOMPATIBLE WITH'',
     *                            '' ODD NCUSIZ '',1X,19(1H/),/)')
C
          ERRSTR=' NUQEVE=1 INCOMPATIBLE WITH ODD NCUSIZ IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.0.AND.
     *   (NCUSIZ(0).LT.0.OR.NCUSIZ(1).LT.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' WRONG NCUSIZ(0)<0 OR'',
     *                            '' NCUSIZ(1)<0'',7X,19(1H/),/)')
C
          ERRSTR=' WRONG NCUSIZ(0)<0 OR NCUSIZ(1)<0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ISIMPY.EQ.1.OR.ISIQTY.EQ.0).AND.MAXVAL(NCUSIQ).NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NCUSIQ(:)>0 REQUIRES ISIMP'',
     *                            ''Y=0/ISIQTY=1'',1X,19(1H/),/)')
C
          ERRSTR='NCUSIQ(:)>0 REQUIRES ISIMPY=0 AND ISIQTY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.
     *    ITWOBA.NE.1.AND.MAXVAL(NCUSIQ).NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITWOBA=0 INCOMPATIBLE W/'',
     *                            '' NCUSIQ(:,:)>0'',1X,19(1H/),/)')
C
          ERRSTR='FOR NCUSIQ(:,:)>0,TWO-BASIS METHOD REQUIRED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.
     *    LIMQUA.EQ.1.AND.MAXVAL(NCUSIQ).NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' LIMQUA=1 INCOMPATIBLE W/'',
     *                            '' NCUSIQ(:,:)>0'',1X,19(1H/),/)')
C
          ERRSTR='FOR NCUSIQ(:,:)>0, LIMQUA=0 REQUIRED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.
     *    LAMCUT.EQ.1.AND.MAXVAL(NCUSIQ).NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' LAMCUT=1 INCOMPATIBLE W/'',
     *                            '' NCUSIQ(:,:)>0'',1X,19(1H/),/)')
C
          ERRSTR='FOR NCUSIQ(:,:)>0, LAMCUT=0 REQUIRED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.
     *   (MOD(NCUSIQ(0,0),2).EQ.1.OR.MOD(NCUSIQ(0,1),2).EQ.1.OR.
     *    MOD(NCUSIQ(1,0),2).EQ.1.OR.MOD(NCUSIQ(1,1),2).EQ.1).AND.
     *    NUQEVE.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NUQEVE=1 INCOMPATIBLE WITH'',
     *                            '' ODD NCUSIQ '',1X,19(1H/),/)')
C
          ERRSTR=' NUQEVE=1 INCOMPATIBLE WITH ODD NCUSIQ IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.
     *   (NCUSIQ(0,0).LT.0.OR.NCUSIQ(0,1).LT.0.OR.
     *    NCUSIQ(1,0).LT.0.OR.NCUSIQ(1,1).LT.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' WRONG NCUSIQ(0,:)<0 OR'',
     *                            '' NCUSIQ(1,:)<0'',3X,19(1H/),/)')
C
          ERRSTR=' WRONG NCUSIQ(0,:)<0 OR NCUSIQ(1,:)<0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.
     *   (NCUSIQ(0,0).GT.0.OR.NCUSIQ(0,1).GT.0).AND.
     *   (NCUSIQ(0,0).EQ.0.OR.NCUSIQ(0,1).EQ.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NCUSIQ(0,0)/NCUSIQ(0,1)'',
     *                            '' INCOMPATIBLE'',3X,19(1H/),/)')
C
          ERRSTR=' NCUSIQ(0,0)/NCUSIQ(0;1) INCOMPATIBILITY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.
     *   (NCUSIQ(1,0).GT.0.OR.NCUSIQ(1,1).GT.0).AND.
     *   (NCUSIQ(1,0).EQ.0.OR.NCUSIQ(1,1).EQ.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NCUSIQ(1,0)/NCUSIQ(1,1)'',
     *                            '' INCOMPATIBLE'',3X,19(1H/),/)')
C
          ERRSTR=' NCUSIQ(1,0)/NCUSIQ(1;1) INCOMPATIBILITY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.2.AND.ITWOBA.EQ.1.AND.
     *    ISIMPY.EQ.0.AND.ISIQTY.EQ.0.AND.MAXVAL(NCUSIZ).EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>1&ITWOBA=1 REQUIRES'',
     *                            '' NCUSIZ>0'',4X,19(1H/),/)')
C
          ERRSTR=' IPRGCM>1&ITWOBA=1 REQUIRES NCUSIZ>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPRGCM.GE.2.AND.ITWOBA.EQ.1.AND.
     *    ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.MAXVAL(NCUSIQ).EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>1&ITWOBA=1 REQUIRES'',
     *                            '' NCUSIQ>0'',4X,19(1H/),/)')
C
          ERRSTR=' IPRGCM>1&ITWOBA=1 REQUIRES NCUSIQ>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPCONT.EQ.1.AND.(IPAHFB.LT.1.OR.ICONTI.EQ.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPCONT=1 IS INCOMPATIBLE WITH '',
     *                                                  8X,20(1H/),/,
     *                 1X,20(1H/),'' EITHER OF IPAHFB=0 OR ICONTI=0'',
     *                                                  8X,20(1H/),/)')
C
          ERRSTR='IPCONT=1 VS. (IPAHFB=0 OR ICONTI=0) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IROTAT.NE.1.AND.IPAIRI.NE.1.AND.(MOD(IN_FIX,2).EQ.1.OR.
     *                                     MOD(IZ_FIX,2).EQ.1)) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IROTAT=IPAIRI=0 IS NOT'',
     *                            '' COMPATIBLE   '',    1X,20(1H/),/
     *                 1X,20(1H/),'' WITH ODD PARTICLE NUMBERS'',
     *                            '' IN_FIX='',I3,       1X,20(1H/),/
     *                 1X,20(1H/),''                          '',
     *                            '' IZ_FIX='',I3,       1X,20(1H/),/)')
     *                               IN_FIX,IZ_FIX
C
          ERRSTR='IROTAT=IPAIRI=0 AND AN ODD SYSTEM IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUDI.LT.0.OR.ICOUDI.GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ICOUDI='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    ICOUDI
C
          ERRSTR=' INCORRECT VALUE OF ICOUDI IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUEX.LT.0.OR.ICOUEX.GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ICOUEX='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    ICOUEX
C
          ERRSTR=' INCORRECT VALUE OF ICOUEX IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ICOTYP.EQ.0.OR.ICOTYP.EQ.-1.OR.ICOTYP.LT.-7).AND.
     *    (ICOUDI.EQ.2.OR.ICOUEX.EQ.2)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ICOTYP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    ICOTYP
C
          ERRSTR=' INCORRECT VALUE OF ICOTYP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (I_YUKA.LT.0.OR.I_YUKA.GT.4) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF I_YUKA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    I_YUKA
C
          ERRSTR=' INCORRECT VALUE OF I_YUKA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IYUTYP.LT.1.OR.IYUTYP.GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IYUTYP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IYUTYP
C
          ERRSTR=' INCORRECT VALUE OF IYUTYP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IYCONT.EQ.1.AND.I_YUKA.LT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IYCONT=1 IS INCOMPATIBLE W/'',
     *                            '' I_YUKA<2'',1X,20(1H/),/)')
C
          ERRSTR='IYCONT=1 VS. I_YUKA<2 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGCONT.EQ.1.AND.I_GOGA.LT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGCONT=1 IS INCOMPATIBLE W/'',
     *                            '' I_GOGA<2'',1X,20(1H/),/)')
C
          ERRSTR='IGCONT=1 VS. I_GOGA<2 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGPCON.EQ.1.AND.IGOGPA.LT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGPCON=1 IS INCOMPATIBLE W/'',
     *                            '' IGOGPA<2'',1X,20(1H/),/)')
C
          ERRSTR='IGPCON=1 VS. IGOGPA<2 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IECONT.EQ.1.AND.I_REGA.LT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IECONT=1 IS INCOMPATIBLE W/'',
     *                            '' I_REGA<2'',1X,20(1H/),/)')
C
          ERRSTR='IECONT=1 VS. I_REGA<2 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICONTI.EQ.1.AND.IECONT.NE.1.AND.IFCONT.NE.1.AND.I_REGA.GE.1)
     *                                                              THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICONTI=1 WITH I_REGA>0 REQUIRES'',
     *                            ''     '',1X,20(1H/),/,
     *                 1X,20(1H/),'' IECONT=1 OR IFCONT=1           '',
     *                            ''     '',1X,20(1H/),/)')
C
          ERRSTR='ICONTI=1&I_REGA>0 RQRS IECONT=1 OR IFCONT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICONTI.EQ.1.AND.IGCONT.NE.1.AND.IFCONT.NE.1.AND.I_GOGA.GE.1)
     *                                                              THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICONTI=1 WITH I_GOGA>0 REQUIRES'',
     *                            ''     '',1X,20(1H/),/,
     *                 1X,20(1H/),'' IGCONT=1 OR IFCONT=1           '',
     *                            ''     '',1X,20(1H/),/)')
C
          ERRSTR='ICONTI=1&I_GOGA>0 RQRS IGCONT=1 OR IFCONT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICONTI.EQ.1.AND.IPCONT.EQ.1.AND.IFCONT.NE.1.AND.IREGPA.GE.1)
     *                                                              THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICONTI=1 WITH IPCONT=1&IREGPA>0'',
     *                            ''     '',1X,20(1H/),/,
     *                 1X,20(1H/),'' REQUIRES IFCONT=1              '',
     *                            ''     '',1X,20(1H/),/)')
C
          ERRSTR='ICONTI=1&IPCONT=1&IREGPA>0 RQUIRES IFCONT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICONTI.EQ.1.AND.IPCONT.EQ.1.AND.IFCONT.NE.1.AND.IGOGPA.GE.1)
     *                                                              THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ICONTI=1 WITH IPCONT=1&IGOGPA>0'',
     *                            ''     '',1X,20(1H/),/,
     *                 1X,20(1H/),'' REQUIRES IFCONT=1              '',
     *                            ''     '',1X,20(1H/),/)')
C
          ERRSTR='ICONTI=1&IPCONT=1&IGOGPA>0 RQUIRES IFCONT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (I_GOGA.LT.0.OR.I_GOGA.GT.4) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF I_GOGA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    I_GOGA
C
          ERRSTR=' INCORRECT VALUE OF I_GOGA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGOGPA.LT.0.OR.IGOGPA.GT.3) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IGOGPA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IGOGPA
C
          ERRSTR=' INCORRECT VALUE OF IGOGPA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (I_COUA.LT.0.OR.I_COUA.GT.4) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF I_COUA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    I_COUA
C
          ERRSTR=' INCORRECT VALUE OF I_COUA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ICOUPA.LT.0.OR.ICOUPA.GT.2) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ICOUPA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    ICOUPA
C
          ERRSTR=' INCORRECT VALUE OF ICOUPA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IREGPA.LT.0.OR.IREGPA.GT.2) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IREGPA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IREGPA
C
          ERRSTR=' INCORRECT VALUE OF IREGPA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISEPPA.NE.0.AND.ISEPPA.NE.2) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ISEPPA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    ISEPPA
C
          ERRSTR=' INCORRECT VALUE OF ISEPPA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MINVAL(I_FSTA).LT.0.OR.MAXVAL(I_FSTA).GT.4) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUES OF I_FSTA='',3I3,
     *                                                   1X,20(1H/),/)')
     *    I_FSTA
C
          ERRSTR=' INCORRECT VALUES OF I_FSTA(:) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MINVAL(IFSTPA).LT.0.OR.MAXVAL(IFSTPA).GT.2) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUES OF IFSTPA='',3I3,
     *                                                   1X,20(1H/),/)')
     *    IFSTPA
C
          ERRSTR=' INCORRECT VALUES OF IFSTPA(:) IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      THE TEST BELOW WAS REMOVED ON 27/02/2019 IN VERSION 2.88I,
C      BECAUSE IT APPEARS TO BE NOT NEEDED
C=======================================================================
C      THE TEST BELOW WAS PUT BACK ON 26/09/2022 IN VERSION 3.14I,
C      WHEN IMPLEMENTING THE NEW GOGNY CALCULATIONS
C=======================================================================
C
      IF (I_GOGA.GE.1.AND.I_REGA.GE.1.AND.NEWGOG.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' FOR THE NEW IMPLENTATION OF'',
     *                            '' GOGNY     '',1X,19(1H/),
     *                 1X,20(1H/),'' I_GOGA>0 IS INCOMPATIBLE WITH'',
     *                            '' I_REGA>0'',  1X,19(1H/),/)')
C
          ERRSTR='I_GOGA>0, I_REGA>0 & NEWGOG=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Control tests for Broyden method
C=======================================================================
C
      IF (IBROYD.GE.1.AND.I_YUKA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' I_YUKA>0'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. I_YUKA>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.I_GOGA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' I_GOGA>0'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. I_GOGA>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.IGOGPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' IGOGPA>0'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. IGOGPA>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.I_REGA.GE.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' I_REGA>0'',1X,19(1H/),/)')
C
          ERRSTR=' IBROYD=1 VS. I_REGA>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.I_SEPA.GE.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' I_SEPA>0'',1X,19(1H/),/)')
C
          ERRSTR=' IBROYD=1 VS. I_SEPA>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.IREGPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' IREGPA>0'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. IREGPA>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.ISEPPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' ISEPPA>0'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. ISEPPA>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.ICOUPA.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' ICOUPA>0'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. ICOUPA>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.MAXVAL(I_FSTA).GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' I_FSTA>0'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. I_FSTA(:)>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IBROYD.GE.1.AND.MAXVAL(IFSTPA).GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' IFSTPA>0'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. IFSTPA(:)>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IBROYD.GE.1.AND.I_SLOW.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' I_SLOW=1'',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 VS. I_SLOW=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGOGPA.GE.1.AND.I_GOGA.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGOGPA>0 IS INCOMPATIBLE WITH'',
     *                            '' I_GOGA=0'',1X,19(1H/),/)')
C
          ERRSTR='IGOGPA>0 VS. I_GOGA=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGOGPA.GE.1.AND.IPRGCM.GT.0.AND.NEWGOG.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGOGPA>0 WITH NEWGOG=0 IS '',
     *                            ''         '',1X,19(1H/),/,
     *                 1X,20(1H/),'' INCOMPATIBLE WITH IPRGCM>0'',
     *                            ''         '',1X,19(1H/),/)')
C
          ERRSTR='IGOGPA>0 VS. IPRGCM>0 AND NEWGOG=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGOGPA.GE.1.AND.IABS(IAXIAP).GT.0.AND.NEWGOG.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGOGPA>0 WITH NEWGOG=0 IS '',
     *                            ''         '',1X,19(1H/),/,
     *                 1X,20(1H/),'' INCOMPATIBLE WITH |IAXIAP|>0'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='IGOGPA>0 VS. |IAXIAP|>0 AND NEWGOG=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IAXIAP).GT.0.AND.
     *   (ABS(OMEGAX).GT.0.0D0.OR.ABS(OMEGAY).GT.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' |OMEGAX|>0 OR |OMEGAY|>0 IS'',
     *                            ''        '',1X,19(1H/),/,
     *                 1X,20(1H/),'' INCOMPATIBLE WITH |IAXIAP|>0'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR=' |OMEGAX|>0 OR |OMEGAY|>0 VS. |IAXIAP|>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IAXIAP).GT.0.AND.
     *   (ABS(OMISOX).GT.0.0D0.OR.ABS(OMISOY).GT.0.0D0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' |OMISOX|>0 OR |OMISOY|>0 IS'',
     *                            ''        '',1X,19(1H/),/,
     *                 1X,20(1H/),'' INCOMPATIBLE WITH |IAXIAP|>0'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR=' |OMISOX|>0 OR |OMISOY|>0 VS. |IAXIAP|>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IREGPA.GE.1.AND.I_REGA.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IREGPA>0 IS INCOMPATIBLE WITH'',
     *                            '' I_REGA=0'',1X,19(1H/),/)')
C
          ERRSTR='IREGPA>0 VS. I_REGA=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (I_REGA.LT.0.OR.I_REGA.GT.4) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF I_REGA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    I_REGA
C
          ERRSTR=' INCORRECT VALUE OF I_REGA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (N3LORD.LT.-2.OR.N3LORD.GT.3) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF N3LORD='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    N3LORD
C
          ERRSTR=' INCORRECT VALUE OF N3LORD IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C       THE TEST BELOW HAS BEEN REMOVED IN VERSION (3.03R) ON 07/03/2021
C       AFTER  THE  CALCULATION  OF  THE  SEPARABLE  P-H  ENERGIES   WAS
C       OVERJUMPED IN "SEPENE".
C=======================================================================
C
C     IF (ISEPPA.GE.1.AND.I_SEPA.LT.1) THEN
C
C         WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),'' ISEPPA>0 IS INCOMPATIBLE WITH'',
C    *                            '' I_SEPA=0'',1X,19(1H/),/)')
C
C         ERRSTR='ISEPPA>0 VS. I_SEPA=0 INCONSISTENCY IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C
      IF (I_SEPA.LT.0.OR.I_SEPA.GT.4) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF I_SEPA='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    I_SEPA
C
          ERRSTR=' INCORRECT VALUE OF I_SEPA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (N3SERD.NE.0) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF N3SERD='',I2,
     *                            '' FOR NOW'',1X,20(1H/),/)')
     *    N3SERD
C
          ERRSTR=' INCORRECT VALUE OF N3SERD IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IREREG.GT.NDREGA) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IREREG='',I3,'' EXCEEDS'',
     *                            '' NDREGA='',I3,5X,20(1H/),/)')
     *    IREREG,NDREGA
C
          ERRSTR=' IREREG EXCEEDS NDREGA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NDGOGA.GT.NDREGA) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NDGOGA='',I3,'' EXCEEDS'',
     *                            '' NDREGA='',I3,5X,20(1H/),/)')
     *    IREREG,NDREGA
C
          ERRSTR=' NDGOGA EXCEEDS NDREGA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IREREG.LT.0.OR.(N3LORD.GE.0.AND.IREREG.GT.4)
     *               .OR.(N3LORD.LT.0.AND.IREREG.GT.10)) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IREREG='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IREREG
C
          ERRSTR=' INCORRECT VALUE OF IREREG IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IREREG.GT.0.AND.N3LORD.GE.0.AND.NDREGA.LT.N3LORD+1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' N3LORD>0 REQUIRES'',
     *                            '' NDREGA=>N3LORD+1'',1X,19(1H/),/)')
C
          ERRSTR=' N3LORD>0 VS. NDREGA<N3LORD+1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      NUREGA=((IABS(N3LORD)+1)*(IABS(N3LORD)+2))/2
      IF (IREREG.GT.0.AND.N3LORD.LT.0.AND.NDREGA.LT.NUREGA) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' N3LORD<0 REQUIRES'',
     *                            '' NDREGA=>3, 6, 10'',1X,19(1H/),/
     *                 1X,20(1H/),'' FOR N3LORD=-1, -2,'',
     *                            '' -3 RESPECTIVELY'',1X,19(1H/),/)')
C
          ERRSTR=' N3LORD<0 REQUIRES NDREGA=>3, 6, 10 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (N3LORD.GE.0) THEN
          NUREGA=IABS(N3LORD)+1
      ELSE
          NUREGA=((IABS(N3LORD)+1)*(IABS(N3LORD)+2))/2
      END IF
C
      IF (IREREG.GT.0.AND.IREREG.NE.NUREGA) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IREREG='',I2,'' INCOMPATIBLE'',
     *                            '' WITH N3LORD='',I2,1X,20(1H/),/)')
     *    IREREG,N3LORD
C
          ERRSTR=' IREREG INCOMPATIBLE WITH N3LORD IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IVISEP.GT.NDSEPA) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IVISEP='',I3,'' EXCEEDS'',
     *                            '' NDSEPA='',I3,5X,20(1H/),/)')
     *    IVISEP,NDSEPA
C
          ERRSTR=' IVISEP EXCEEDS NDSEPA IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IVISEP.LT.0.OR.IVISEP.GT.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IVISEP='',I2,
     *                            '' FOR NOW'',1X,20(1H/),/)')
     *    IVISEP
C
          ERRSTR=' INCORRECT VALUE OF IVISEP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      NUSEPA=((IABS(N3SERD)+1)*(IABS(N3SERD)+2))/2
C
      IF (IVISEP.GT.0.AND.NDSEPA.LT.NUSEPA) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' N3SERD<=0 REQUIRES'',
     *                            '' NDSEPA=>1,3,6,10'',1X,19(1H/),/
     *                 1X,20(1H/),'' FOR N3SERD=0,-1,-2,-3 '',
     *                            '' RESPECTIVELY'',1X,19(1H/),/)')
C
          ERRSTR=' N3SERD<=0 REQUIRES NDSEPA=>1,3,6,10 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      NUSEPA=((IABS(N3SERD)+1)*(IABS(N3SERD)+2))/2
C
      IF (IVISEP.GT.0.AND.IVISEP.NE.NUSEPA) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IVISEP='',I2,'' INCOMPATIBLE'',
     *                            '' WITH N3SERD='',I2,1X,20(1H/),/)')
     *    IVISEP,N3SERD
C
          ERRSTR=' IVISEP INCOMPATIBLE WITH N3SERD IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IVISEP.NE.0.AND.(IERSEP.NE.0     .OR.IFASEP.NE.0     )
     *               .AND.(IERSEP.NE.IVISEP.OR.IFASEP.NE.IVISEP)) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IVISEP='',I2,'' IS NOT EQUAL TO '',
     *                            '' IERSEP='',I2,1X,20(1H/),/,
     *                 1X,20(1H/),'' IVISEP='',I2,'' IS NOT EQUAL TO '',
     *                            '' IFASEP='',I2,1X,20(1H/),/)')
     *    IVISEP,IERSEP,IVISEP,IFASEP
C
          ERRSTR=' IVISEP<>IERSEP<>IFASEP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ILCONT.GE.1.AND.(LIPKIN.NE.1.AND.LIPKIP.NE.1)) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ILCONT>0 INCOMPATIBLE WITH'',
     *                            '' NO LIPKIN '',1X,20(1H/),/)')
C
          ERRSTR=' ILCONT>0 VS. NO LIPKIN INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETACM.EQ.2.AND.IROTAT.NE.1.AND.ITWOLI.EQ.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' JETACM=2 REQUIRES IROTAT=1'',
     *                            '' BECAUSE   '',  1X,20(1H/),/,
     *                 1X,20(1H/),'' THE ROTATIONAL CORRECTION MAY'',
     *                            '' GIVE   '',     1X,20(1H/),/,
     *                 1X,20(1H/),'' TIME-ODD MEAN FIELDS. TO'',
     *                            '' PROCEED     '',1X,20(1H/),/,
     *                 1X,20(1H/),'' ANYHOW, YOU MAY USE ITWOLI=0'',
     *                            '' OR -1   '',    1X,20(1H/),/)')
C
          ERRSTR=' JETACM=2 REQUIRES IROTAT=1 OR ITWOLI=0/-1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETACM.EQ.2.AND.ISIMPY.EQ.1.AND.ITWOLI.EQ.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' JETACM=2 REQUIRES ISIMPY=0'',
     *                            '' BECAUSE   '',  1X,20(1H/),/,
     *                 1X,20(1H/),'' THE ROTATIONAL CORRECTION MAY'',
     *                            '' GIVE   '',     1X,20(1H/),/,
     *                 1X,20(1H/),'' SIMPLEX-ODD MEAN FIELDS. TO'',
     *                            '' PROCEED  '',   1X,20(1H/),/,
     *                 1X,20(1H/),'' ANYHOW, YOU MAY USE ITWOLI=0'',
     *                            '' OR -1   '',    1X,20(1H/),/)')
C
          ERRSTR=' JETACM=2 REQUIRES ISIMPY=0 OR ITWOLI=0/-1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETACM.EQ.2.AND.ISIQTY.EQ.1.AND.ITWOLI.EQ.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' JETACM=2 REQUIRES ISIQTY=0'',
     *                            '' BECAUSE   '',  1X,20(1H/),/,
     *                 1X,20(1H/),'' THE ROTATIONAL CORRECTION MAY'',
     *                            '' GIVE   '',     1X,20(1H/),/,
     *                 1X,20(1H/),'' PARITY-ODD MEAN FIELDS. TO'',
     *                            '' PROCEED   '',  1X,20(1H/),/,
     *                 1X,20(1H/),'' ANYHOW, YOU MAY USE ITWOLI=0'',
     *                            '' OR -1   '',    1X,20(1H/),/)')
C
          ERRSTR=' JETACM=2 REQUIRES ISIMPY=0 OR ITWOLI=0/-1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JETACM.EQ.2.AND.IPAIRI.GE.1.AND.IPAHFB.LT.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' JETACM=2 REQUIRES HFB PAIRING'',
     *                            '' WHEN   '',  1X,20(1H/),/,
     *                 1X,20(1H/),'' PAIRING IS SWITCHD ON        '',
     *                            ''        '',     1X,20(1H/),/)')
C
          ERRSTR=' JETACM=2 REQUIRES IPAHFB>0 FOR IPAIRI>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IMCONT.EQ.1.AND.JETACM.NE.2) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' IMCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' NO CM CORR'',1X,19(1H/),/)')
C
          ERRSTR=' IMCONT=1 VS. NO CM CORR INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (KETA_R.EQ.2.AND.IROTAT.NE.1.AND.ITWOLI.EQ.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETA_R=2 REQUIRES IROTAT=1'',
     *                            '' BECAUSE   '',  1X,20(1H/),/,
     *                 1X,20(1H/),'' THE ROTATIONAL CORRECTION MAY'',
     *                            '' GIVE   '',     1X,20(1H/),/,
     *                 1X,20(1H/),'' TIME-ODD MEAN FIELDS. TO'',
     *                            '' PROCEED     '',1X,20(1H/),/,
     *                 1X,20(1H/),'' ANYHOW, YOU MAY USE ITWOLI=0'',
     *                            '' OR -1   '',    1X,20(1H/),/)')
C
          ERRSTR=' KETA_R=2 REQUIRES IROTAT=1 OR ITWOLI=0/-1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (KETA_R.EQ.2.AND.ISIMPY.EQ.1.AND.ITWOLI.EQ.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' KETA_R=2 REQUIRES ISIMPY=0'',
     *                            '' BECAUSE   '',  1X,20(1H/),/,
     *                 1X,20(1H/),'' THE ROTATIONAL CORRECTION MAY'',
     *                            '' GIVE   '',     1X,20(1H/),/,
     *                 1X,20(1H/),'' SIMPLEX-ODD MEAN FIELDS. TO'',
     *                            '' PROCEED  '',   1X,20(1H/),/,
     *                 1X,20(1H/),'' ANYHOW, YOU MAY USE ITWOLI=0'',
     *                            '' OR -1   '',    1X,20(1H/),/)')
C
          ERRSTR=' KETA_R=2 REQUIRES ISIMPY=0 OR ITWOLI=0/-1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IRCONT.EQ.1.AND.KETA_R.NE.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' IRCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' NO RM CORR'',1X,19(1H/),/)')
C
          ERRSTR=' IRCONT=1 VS. NO ROT. CORR. INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IF2FIN.EQ.1.AND.LIPKIN.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' FIXED NEUTRON LAMBDA2 CAN ONLY'',
     *                            '' BE USED'',    1X,19(1H/),/,
     *                 1X,19(1H/),'' TOGETHER WITH LIPKIN = 1  '',
     *                            ''            '',1X,19(1H/),/)')
C
          ERRSTR=' FIXED NEUTRON LAMBDA2 ONLY FOR LIPKIN=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IF2FIP.EQ.1.AND.LIPKIP.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' FIXED PROTON  LAMBDA2 CAN ONLY'',
     *                            '' BE USED'',    1X,19(1H/),/,
     *                 1X,19(1H/),'' TOGETHER WITH LIPKIP = 1  '',
     *                            ''            '',1X,19(1H/),/)')
C
          ERRSTR=' FIXED PROTON LAMBDA2 ONLY FOR LIPKIP=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (LIPNON.EQ.1.AND.LIPKIN.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' NO BLOCKED NEUTRON ORBITAL'',
     *                            '' IN LIPK-NOG'',    1X,19(1H/),/,
     *                 1X,19(1H/),'' POSSIBLE ONLY WITH LIPKIN = 1'',
     *                            ''         '',1X,19(1H/),/)')
C
          ERRSTR=' NO BLOCKED NEUTRON IN LN ONLY FOR LIPKIN=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (LIPNOP.EQ.1.AND.LIPKIP.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,19(1H/),'' NO BLOCKED PROTON  ORBITAL'',
     *                            '' IN LIPK-NOG'',    1X,19(1H/),/,
     *                 1X,19(1H/),'' POSSIBLE ONLY WITH LIPKIP = 1'',
     *                            ''         '',1X,19(1H/),/)')
C
          ERRSTR=' NO BLOCKED PROTON  IN LN ONLY FOR LIPKIP=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C     SUMMING UP THE PARTICLE NUMBERS IN THE VACUUM CONFIGURATIONS
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         NUMPAR(ICHARG)=0
C
         IF (ISIMPY.EQ.1) THEN
C
             IF (ISIGNY.EQ.1) THEN
C
C=======================================================================
C                SIGNATURE/PARITY CASE
C=======================================================================
C                FOR IROTAT=0, THE BLOCKS WITH ISIGNA=1  ARE  IGNORED,
C                              AND THE OCCUPATION NUMBERS AT ISIGNA=0
C                              ARE DOUBLED
C=======================================================================
C
                 DO IPARIT=0,NDPARI
C
                    DO IREVER=0,IROTAT
C
                       NUMPAR(ICHARG)=
     *                 NUMPAR(ICHARG)+NVASIG(IPARIT,IREVER,ICHARG)
     *                               *(2-IROTAT)
C
                    END DO
C
                 END DO
C
             ELSE
C
C=======================================================================
C                SIMPLEX CASE
C=======================================================================
C                FOR IROTAT=0, THE BLOCK  WITH ISIMPY=1   IS  IGNORED,
C                              AND THE OCCUPATION NUMBERS AT ISIMPL=0
C                              ARE DOUBLED
C=======================================================================
C
                 DO IREVER=0,IROTAT
C
                    NUMPAR(ICHARG)=
     *              NUMPAR(ICHARG)+NVASIM(IREVER,ICHARG)
     *                            *(2-IROTAT)
C
                 END DO
C
             END IF
C
         ELSE
C
             IF (ISIQTY.EQ.1) THEN
C
C=======================================================================
C                PARITY CASE
C=======================================================================
C
                 DO IPARIT=0,NDPARI
C
                    NUMPAR(ICHARG)=
     *              NUMPAR(ICHARG)+NVASIQ(IPARIT,ICHARG)
C
                 END DO
C
                 DO NUBLOC=1,NIBLOC(ICHARG)
C
                    IF (IABS(NIBLOM(NUBLOC,ICHARG)).EQ.1.AND.
     *                  IABS(NIBLOE(NUBLOC,ICHARG)).EQ.1)
     *
     *                  NUMPAR(ICHARG)=NUMPAR(ICHARG)
     *                         +NIBLOE(NUBLOC,ICHARG)
                 END DO
C
             ELSE
C
C=======================================================================
C            NO-SYMMETRY CASE
C=======================================================================
C
                 IF (ICHARG.EQ.0) NUMPAR(ICHARG)=IN_FIX
                 IF (ICHARG.EQ.1) NUMPAR(ICHARG)=IZ_FIX
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C     CHECKING THE PARTICLE NUMBERS
C=======================================================================
C     FOR THE SINGLE-PARTICLE BLOCKING, DEVELOPED SO  FAR  ONLY  IN  THE
C     PARITY OR NO-SYMMETRY CASE, THE TEST BELOW IS DISABLED BECAUSE  WE
C     CANNOT PREDICT WHETHER A PARTICLE OR A HOLE STATE WILL BE BLOCKED.
C=======================================================================
C
      IF (IPAIRI.NE.1.AND.IPNMIX.NE.1.AND.
     *   (MAXVAL(IABS(IDSIQN)).LE.1.AND.MAXVAL(IABS(IDSIZN)).LE.1.AND.
     *                                           NUMPAR(0).NE.IN_FIX.OR.
     *    MAXVAL(IABS(IDSIQP)).LE.1.AND.MAXVAL(IABS(IDSIZP)).LE.1.AND.
     *                                           NUMPAR(1).NE.IZ_FIX)
     *                                            .AND.IVACUM.NE.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),''   INCOMPATIBLE PARTICLE '',
     *                            '' NUMBERS:   '',      1X,20(1H/),/
     *                 1X,20(1H/),''              (REQUESTED)'',
     *                            '' (VACUUM)   '',      1X,20(1H/),/
     *                 1X,20(1H/),''   NEUTRONS:      '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/
     *                 1X,20(1H/),''    PROTONS:      '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/)')
     *    IN_FIX,NUMPAR(0),
     *    IZ_FIX,NUMPAR(1)
          ERRSTR='INCOMPATIBLE PARTICLE NUMBERS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
C=======================================================================
C     SUMMING UP THE PARTICLE NUMBERS IN THE ALIGNMENT BLOCKS
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (ICHARG.EQ.0) MXALIX=MXALIN
         IF (ICHARG.EQ.1) MXALIX=MXALIP
C
         IF (ISIMPY.EQ.1) THEN
C
             IF (ISIGNY.EQ.1) THEN
C
C=======================================================================
C                SIGNATURE/PARITY CASE
C                NOT IMPLEMENTED YET
C=======================================================================
C
             ELSE
C
C=======================================================================
C                SIMPLEX CASE
C                NOT IMPLEMENTED YET
C=======================================================================
C
             END IF
C
         ELSE
C
             IF (ISIQTY.EQ.1) THEN
C
C=======================================================================
C                PARITY CASE
C=======================================================================
C
                 NEGSIQ(ICHARG)=0
C
                 DO IPARIT=0,NDPARI
C
                    NUPPAR(IPARIT,ICHARG)=0
C
                    DO I_ALIB=-MXALIX,MXALIX,2
C
                       IF (LASTAL(ICHARG).EQ.0) THEN
C
                           NUPPAR(IPARIT,ICHARG)=NUPPAR(IPARIT,ICHARG)
     *                              +IABS(LALSIQ(I_ALIB,IPARIT,ICHARG))
                       ELSE
C
                           IF (LALSIQ(I_ALIB,IPARIT,ICHARG).NE.0)
     *                     NUPPAR(IPARIT,ICHARG)=NUPPAR(IPARIT,ICHARG)+1
C
                           IF (LALSIQ(I_ALIB,IPARIT,ICHARG).LT.0)
     *                     NEGSIQ(ICHARG)=1
C
                       END IF
C
                    END DO
C
                 END DO
C
             ELSE
C
C=======================================================================
C            NO-SYMMETRY CASE
C=======================================================================
C
                 NUMPAR(ICHARG)=0
                 NEGSIZ(ICHARG)=0
C
                 DO I_ALIB=-MXALIX,MXALIX,2
C
                    IF (LASTAL(ICHARG).EQ.0) THEN
C
                        NUMPAR(ICHARG)=NUMPAR(ICHARG)+
     *                                       IABS(LALSIZ(I_ALIB,ICHARG))
                    ELSE
C
                        IF (LALSIZ(I_ALIB,ICHARG).NE.0)
     *                  NUMPAR(ICHARG)=NUMPAR(ICHARG)+1
C
                        IF (LALSIZ(I_ALIB,ICHARG).LT.0)
     *                  NEGSIZ(ICHARG)=1
C
                    END IF
C
                 END DO
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C                CHECKING THE PARTICLE NUMBERS
C=======================================================================
C
      IF (IPAIRI.NE.1.AND.IPNMIX.NE.1.AND.
     *    ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.
     *    NLSIZN.GE.1.AND.NUMPAR(0).NE.IN_FIX.AND.IVACUM.NE.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCOMPATIBLE PARTICLE NUMBERS IN'',
     *                            '' THE'',      1X,20(1H/),/
     *                 1X,20(1H/),'' NO-SYMMETRY ALIGNMENT BLOCKS:   '',
     *                            ''    '',      1X,20(1H/),/
     *                 1X,20(1H/),''              (REQUESTED)'',
     *                            '' (ALIGNMENT)'',      1X,20(1H/),/
     *                 1X,20(1H/),''   NEUTRONS:      '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/)')
     *    IN_FIX,NUMPAR(0)
          ERRSTR='INCOMPATIBLE NO-SYMMETRY ALIG NEUT NUMBERS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
      IF (IPAIRI.NE.1.AND.IPNMIX.NE.1.AND.
     *    ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.
     *    NLSIZP.GE.1.AND.NUMPAR(1).NE.IZ_FIX.AND.IVACUM.NE.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCOMPATIBLE PARTICLE NUMBERS IN'',
     *                            '' THE'',      1X,20(1H/),/
     *                 1X,20(1H/),'' NO-SYMMETRY ALIGNMENT BLOCKS:   '',
     *                            ''    '',      1X,20(1H/),/
     *                 1X,20(1H/),''              (REQUESTED)'',
     *                            '' (ALIGNMENT)'',      1X,20(1H/),/
     *                 1X,20(1H/),''    PROTONS:      '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/)')
     *    IZ_FIX,NUMPAR(1)
          ERRSTR='INCOMPATIBLE NO-SYMMETRY ALIG PROT NUMBERS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
      IF (IPAIRI.NE.1.AND.IPNMIX.NE.1.AND.
     *    ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.
     *    NLSIQN.GE.1.AND.(NUPPAR(0,0).NE.NVASIQ(0,0).OR.
     *                     NUPPAR(1,0).NE.NVASIQ(1,0))
     *               .AND.IVACUM.NE.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCOMPATIBLE PARTICLE NUMBERS IN'',
     *                            '' THE'',      1X,20(1H/),/
     *                 1X,20(1H/),'' PARITY ALIGNMENT BLOCKS:        '',
     *                            ''    '',      1X,20(1H/),/
     *                 1X,20(1H/),''              (REQUESTED)'',
     *                            '' (ALIGNMENT)'',      1X,20(1H/),/
     *                 1X,20(1H/),''   NEUTRONS +     '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/
     *                 1X,20(1H/),''   NEUTRONS -     '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/)')
     *    NVASIQ(0,0),NUPPAR(0,0),
     *    NVASIQ(1,0),NUPPAR(1,0)
          ERRSTR='INCOMPATIBLE PARITY ALIGNMENT NEUT. NUMBERS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
      IF (IPAIRI.NE.1.AND.IPNMIX.NE.1.AND.
     *    ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.
     *    NLSIQP.GE.1.AND.(NUPPAR(0,1).NE.NVASIQ(0,1).OR.
     *                     NUPPAR(1,1).NE.NVASIQ(1,1))
     *               .AND.IVACUM.NE.1) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCOMPATIBLE PARTICLE NUMBERS IN'',
     *                            '' THE'',      1X,20(1H/),/
     *                 1X,20(1H/),'' PARITY ALIGNMENT BLOCKS:        '',
     *                            ''    '',      1X,20(1H/),/
     *                 1X,20(1H/),''              (REQUESTED)'',
     *                            '' (ALIGNMENT)'',      1X,20(1H/),/
     *                 1X,20(1H/),''    PROTONS +     '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/
     *                 1X,20(1H/),''    PROTONS -     '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/)')
     *    NVASIQ(0,1),NUPPAR(0,1),
     *    NVASIQ(1,1),NUPPAR(1,1)
          ERRSTR='INCOMPATIBLE PARITY ALIGNMENT PROT. NUMBERS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
C=======================================================================
C                CHECKING THE LAST-ORBITAL OCCUPATIONS
C=======================================================================
C
      IF (IPAIRI.NE.1.AND.IPNMIX.NE.1.AND.
     *    ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.
     *   (LASTAN.EQ.1.AND.NLSIZN.GE.1.AND.NEGSIZ(0).EQ.1.OR.
     *    LASTAP.EQ.1.AND.NLSIZP.GE.1.AND.NEGSIZ(1).EQ.1)) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' FOR LASTA.=1, NEGATIVE VALUES OF'',
     *                            ''    '',      1X,20(1H/),/,
     *                 1X,20(1H/),'' LALSIZ ARE NOT ALLOWED          '',
     *                            ''    '',      1X,20(1H/))')
          ERRSTR='NEGATIVE LALSIZ NOT ALLOWED FOR LASTA.=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
      IF (IPAIRI.NE.1.AND.IPNMIX.NE.1.AND.
     *    ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.
     *   (LASTAN.EQ.1.AND.NLSIQN.GE.1.AND.NEGSIQ(0).EQ.1.OR.
     *    LASTAP.EQ.1.AND.NLSIQP.GE.1.AND.NEGSIQ(1).EQ.1)) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' FOR LASTA.=1, NEGATIVE VALUES OF'',
     *                            ''    '',      1X,20(1H/),/,
     *                 1X,20(1H/),'' LALSIQ ARE NOT ALLOWED          '',
     *                            ''    '',      1X,20(1H/))')
          ERRSTR='NEGATIVE LALSIQ NOT ALLOWED FOR LASTA.=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
C=======================================================================
C     SUMMING UP THE PARTICLE NUMBERS IN THE VACUUM CONFIGURATIONS
C     FOR THE PROTON-NEUTRON MIXING
C=======================================================================
C
      NUMNUC=0
C
      IF (ISIMPY.EQ.1) THEN
C
          IF (ISIGNY.EQ.1) THEN
C
C=======================================================================
C                SIGNATURE/PARITY CASE
C=======================================================================
C                FOR IROTAT=0, THE BLOCKS WITH ISIGNA=1  ARE  IGNORED,
C                              AND THE OCCUPATION NUMBERS AT ISIGNA=0
C                              ARE DOUBLED
C=======================================================================
C
              DO IPARIT=0,NDPARI
C
                 DO IREVER=0,IROTAT
C
                    NUMNUC=NUMNUC+NVAMIG(IPARIT,IREVER)*(2-IROTAT)
C
                 END DO
C
              END DO
C
          ELSE
C
C=======================================================================
C                SIMPLEX CASE
C=======================================================================
C                FOR IROTAT=0, THE BLOCK  WITH ISIMPY=1   IS  IGNORED,
C                              AND THE OCCUPATION NUMBERS AT ISIMPL=0
C                              ARE DOUBLED
C=======================================================================
C
              DO IREVER=0,IROTAT
C
                 NUMNUC=NUMNUC+NVAMIM(IREVER)*(2-IROTAT)
C
              END DO
C
          END IF
C
      ELSE
C
          IF (ISIQTY.EQ.1) THEN
C
C=======================================================================
C                PARITY CASE
C=======================================================================
C
              DO IPARIT=0,NDPARI
C
                 NUMNUC=NUMNUC+NVAMIQ(IPARIT)
C
              END DO
C
          ELSE
C
C=======================================================================
C            NO-SYMMETRY CASE
C=======================================================================
C
              NUMNUC=IN_FIX+IZ_FIX
C
          END IF
C
      END IF
C
C=======================================================================
C     CHECKING THE PARTICLE NUMBERS
C=======================================================================
C
      IF (IPAIRI.NE.1.AND.IPNMIX.EQ.1.AND.NUMNUC.NE.IN_FIX+IZ_FIX) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCOMPATIBLE PNMIX PARTICLE'',
     *                            '' NUMBERS'',      1X,20(1H/),/
     *                 1X,20(1H/),''              (REQUESTED)'',
     *                            '' (VACUUM)   '',      1X,20(1H/),/
     *                 1X,20(1H/),''   NUCLEONS:      '',I3,''    '',
     *                            ''   '',I3,            7X,20(1H/),/)')
     *    IN_FIX+IZ_FIX,NUMNUC
C
          ERRSTR='INCOMPATIBLE PNMIX PARTICLE NUMBERS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IOPTGS.LT.0.OR.IOPTGS.GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ONLY 0=<IOPTGS=<2 ALLOWED,'',
     *                            '' NOW IOPTGS='',I5,2X,20(1H/),/)')
     *    IOPTGS
C
          ERRSTR=' OPTIGS<0 OR OPTIGS>2 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPA2HF(0).LT.0.OR.IPA2HF(0).GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ONLY 0=<IPA2HF(0)=<2 ALLOWED,'',
     *                            '' IPA2HF(0)='',I3,2X,20(1H/),/)')
     *    IPA2HF(0)
C
          ERRSTR=' IPA2HF(0)<0 OR IPA2HF(0)>2 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPA2HF(1).LT.0.OR.IPA2HF(1).GT.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ONLY 0=<IPA2HF(1)=<2 ALLOWED,'',
     *                            '' IPA2HF(1)='',I3,2X,20(1H/),/)')
     *    IPA2HF(1)
C
          ERRSTR=' IPA2HF(1)<0 OR IPA2HF(1)>2 NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPA2HF(0).GT.0.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPA2HF(0)>0 INCOMPATIBLE WITH'',
     *                            '' IPAHFB=0'',3X,20(1H/),/)')
C
          ERRSTR='IPA2HF(0)>0 VS. IPAHFB=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPA2HF(1).GT.0.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPA2HF(1)>0 INCOMPATIBLE WITH'',
     *                            '' IPAHFB=0'',3X,20(1H/),/)')
C
          ERRSTR='IPA2HF(1)>0 VS. IPAHFB=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IREAWS.EQ.1.AND.IOPTGS.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IREAWS=1 IS INCOMPATIBLE WITH'',
     *                            '' IOPTGS>0'',3X,20(1H/),/)')
C
          ERRSTR='IREAWS=1 VS. IOPTGS>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
#if(USE_MPI==1)
      IF (IREAWS.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,18(1H/),'' IREAWS=1 IS INCOMPATIBLE WITH'',
     *                            '' PARALLEL MODE'',3X,17(1H/),/)')
C
          ERRSTR='IREAWS=1 AND PARALLEL MODE IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
#endif
C
C=======================================================================
C
      IF (EPSITE.GT.0..AND.NULAST.LE.0) THEN
          WRITE(NFIPRI,'(/,1X,20(1H/),1X,
     *                   ''NULAST='',I3,'' AND EPSITE>0'',
     *                     1X,20(1H/),/)')
     *    NULAST
C
          ERRSTR='NULAST.LE.0 AND EPSITE.GT.0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NUCONS.LT.0) THEN
          WRITE(NFIPRI,'(/,1X,20(1H/),1X,
     *                   ''NUCONS='',I3,''             '',
     *                     1X,20(1H/),/)')
     *    NUCONS
C
          ERRSTR='NUCONS.LT.0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (EPSITE.LT.0..OR.NULAST.LT.0) THEN
          WRITE(NFIPRI,'(/,1X,20(1H/),1X,
     *                   ''NULAST='',I3,''  OR EPSITE<0'',
     *                     1X,20(1H/),/,
     *                     1X,20(1H/),1X,''IS NOT AN ALLOWED VALUE'',
     *                                                  1X,20(1H/),/)')
     *    NULAST
C
          ERRSTR='NULAST.LT.0 OR EPSITE.LT.0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (EPSCON.LT.0..AND.NUCONS.GT.0) THEN
          WRITE(NFIPRI,'(/,1X,20(1H/),1X,
     *                   ''NUCONS='',I3,'' AND EPSCON<0'',
     *                     1X,20(1H/),/,
     *                     1X,20(1H/),1X,''IS NOT AN ALLOWED VALUE'',
     *                                                  1X,20(1H/),/)')
     *    NUCONS
C
          ERRSTR='NUCONS.GT.0 AND EPSCON.LT.0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (EPSPNG.GT.0..AND.NUPING.LE.1) THEN
          WRITE(NFIPRI,'(/,1X,20(1H/),''NUPING='',I3,'' AND EPSPNG>0'',
     *                                             2X,20(1H/),/)')
     *                                              NUPING
C
          ERRSTR='NUPING.LE.1 AND EPSPNG.GT.0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(NIBLOC).GE.1.AND.(ISIMPY.EQ.1.OR.ISIQTY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' BLOCKING BASED ON NILSSON LABELS '',
     *                     ''    '',     1X,20(1H/),/,
     *          1X,20(1H/),'' REQUIRES ISIMPY=0 & ISIQTY=1, FOR'',
     *                     '' NOW'',     1X,20(1H/),/)')
C
          ERRSTR=' NIBLOC>0 REQUIRES ISIMPY=0 & ISIQTY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(NIBLOC).GE.1.AND.(MAXVAL(IABS(IDSIQN)).GE.1.OR.
     *                             MAXVAL(IABS(IDSIQP)).GE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' BLOCKING BASED ON NILSSON LABELS '',
     *                     ''    '',     1X,20(1H/),/,
     *          1X,20(1H/),'' REQUIRES IDSIQN=0 & IDSIQP=0     '',
     *                     ''    '',     1X,20(1H/),/)')
C
          ERRSTR=' NIBLOC>0 REQUIRES IDSIQN=0 & IDSIQP=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(NIBLOC).GE.1.AND.(MAXVAL(IABS(IDSIZN)).GE.1.OR.
     *                             MAXVAL(IABS(IDSIZP)).GE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' BLOCKING BASED ON NILSSON LABELS '',
     *                     ''    '',     1X,20(1H/),/,
     *          1X,20(1H/),'' REQUIRES IDSIZN=0 & IDSIZP=0     '',
     *                     ''    '',     1X,20(1H/),/)')
C
          ERRSTR=' NIBLOC>0 REQUIRES IDSIZN=0 & IDSIZP=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(NIBLOC).GE.1.AND.(MAXVAL(NIBLOM).GT.+1.OR.
     *                             MINVAL(NIBLOM).LT.-1.OR.
     *                             MAXVAL(NIBLOE).GT.+1.OR.
     *                             MINVAL(NIBLOE).LT.-1)) THEN
C
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' BLOCKING BASED ON NILSSON LABELS '',
     *                     ''    '',     1X,20(1H/),/,
     *          1X,20(1H/),'' REQUIRES |NIBLOM|<2 & |NIBLOE|<2 '',
     *                     ''    '',     1X,20(1H/),/)')
C
          ERRSTR=' NIBLOC>0 REQUIRES |NIBLOM|<2 & |NIBLOE|<2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.ISIMPY.EQ.1.AND.ISIGNY.EQ.1.AND.IPNMIX.NE.1)
     *                                                              THEN
C
          IF (ISPFLI.LE.0.OR.ISPFLI.GT.NDSTAT.OR.
     *        N_OCCU(ISPFLI,IPAFLI,IREFLI,ICHFLI).NE.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT SIGNATURE PARTICLE'',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                '' IPAFLI='',I2,
     *                                '' ISIFLI='',I2,   8X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,IPAFLI,
     *                            IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT SIGNATURE PARTICLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ISHFLI.LE.0.OR.ISHFLI.GT.NDSTAT.OR.
     *        N_OCCU(ISHFLI,IPAFLI,IREFLI,ICHFLI).NE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT SIGNATURE   HOLE  '',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                '' IPAFLI='',I2,
     *                                '' ISIFLI='',I2,   8X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,IPAFLI,
     *                            IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT SIGNATURE HOLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ABS(IFLIPI).GE.3.AND.ABS(IFLIPI).LE.8) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT OBSERVABLE INDEX  '',
     *                                '' (SIGN) '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' IFLIPI='',I2,
     *                                ''        '',2X,
     *                                ''        '',2X,   8X,20(1H/),/)')
     *
     *                     IFLIPI
C
              ERRSTR=' INCORRECT SIGNATURE OBSERVABLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (NOFILG(IPAFLI,IREFLI,ICHFLI).GE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' FILLING APPROXIMATION'',
     *                                '' INCOMPATIBLE'', 1X,20(1H/),/,
     *                     1X,20(1H/),'' WITH THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                '' IPAFLI='',I2,
     *                                '' ISIFLI='',I2,   8X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,IPAFLI,
     *                            IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' SIGNATURE FILLING AND DIABATIC IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.ISIMPY.EQ.1.AND.ISIGNY.NE.1.AND.IPNMIX.NE.1)
     *                                                              THEN
C
          IF (ISPFLI.LE.0.OR.ISPFLI.GT.NDSTAT.OR.
     *        L_OCCU(ISPFLI,IREFLI,ICHFLI).NE.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT  SIMPLEX  PARTICLE'',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                '' ISIFLI='',I2,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,IREFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT SIMPLEX PARTICLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ISHFLI.LE.0.OR.ISHFLI.GT.NDSTAT.OR.
     *        L_OCCU(ISHFLI,IREFLI,ICHFLI).NE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT  SIMPLEX    HOLE  '',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                '' ISIFLI='',I2,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,IREFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT SIMPLEX HOLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
C=======================================================================
C
          IF (IPAFLI.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAFLI=1 IS FORBIDDEN FOR'',
     *                                '' ISIGNY=0'',7X,20(1H/),/)')
              ERRSTR='IPAFLI=1 AND ISIGNY=0 INCONSISTENCY IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ABS(IFLIPI).GE.3.AND.ABS(IFLIPI).LE.8) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT OBSERVABLE INDEX '',
     *                                '' (SIMPL) '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' IFLIPI='',I2,
     *                                ''        '',2X,
     *                                ''        '',2X,   8X,20(1H/),/)')
     *
     *                     IFLIPI
C
              ERRSTR=' INCORRECT SIMPLEX OBSERVABLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.IPNMIX.NE.1)
     *                                                              THEN
C
          IF (ISPFLI.LE.0.OR.ISPFLI.GT.2*NDSTAT.OR.
     *        K_OCCU(ISPFLI,IPAFLI,ICHFLI).NE.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT  PARITY   PARTICLE'',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                '' IPAFLI='',I2,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT PARITY PARTICLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ISHFLI.LE.0.OR.ISHFLI.GT.2*NDSTAT.OR.
     *        K_OCCU(ISHFLI,IPAFLI,ICHFLI).NE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT   PARITY    HOLE  '',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                '' IPAFLI='',I2,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT PARITY HOLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
C=======================================================================
C
          IF (IREFLI.NE.IPAFLI) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' ISIFLI=1 IS FORBIDDEN FOR'',
     *                                '' IPARTY=1'',7X,20(1H/),/)')
              ERRSTR='ISIFLI=1 AND IPARTY=1 INCONSISTENCY IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ABS(IFLIPI).GT.10) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT OBSERVABLE INDEX '',
     *                                '' (PARIT) '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' IFLIPI='',I2,
     *                                ''        '',2X,
     *                                ''        '',2X,   8X,20(1H/),/)')
     *
     *                     IFLIPI
C
              ERRSTR=' INCORRECT PARITY OBSERVABLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.IPNMIX.NE.1)
     *                                                              THEN
C
          IF (ISPFLI.LE.0.OR.ISPFLI.GT.2*NDSTAT.OR.
     *        M_OCCU(ISPFLI,ICHFLI).NE.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT NO-SYMMETRY PARTIC'',
     *                                ''LE INDEX'',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                ''        '',2X,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT NO-SYMMETRY PARTICLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ISHFLI.LE.0.OR.ISHFLI.GT.2*NDSTAT.OR.
     *        M_OCCU(ISHFLI,ICHFLI).NE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT NO-SYMMETRY HOLE  '',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                ''        '',2X,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT NO-SYMMETRY HOLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
C=======================================================================
C
          IF (IPAFLI.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' IPAFLI=1 IS FORBIDDEN FOR'',
     *                                '' ISIMPY=0'',7X,20(1H/),/)')
              ERRSTR='IPAFLI=1 AND ISIMPY=0 INCONSISTENCY IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (IREFLI.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' IREFLI=1 IS FORBIDDEN FOR'',
     *                                '' ISIMPY=0'',7X,20(1H/),/)')
              ERRSTR='IREFLI=1 AND ISIMPY=0 INCONSISTENCY IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ABS(IFLIPI).GT.10) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT OBSERVABLE INDEX '',
     *                                '' (NO-SYM)'',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' IFLIPI='',I2,
     *                                ''        '',2X,
     *                                ''        '',2X,   8X,20(1H/),/)')
     *
     *                     IFLIPI
C
              ERRSTR=' INCORRECT NO-SYMMETRY OBSERVABLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (NOFILZ(ICHFLI).GE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' FILLING APPROXIMATION'',
     *                                '' INCOMPATIBLE'', 1X,20(1H/),/,
     *                     1X,20(1H/),'' WITH THE DIABATIC DATA:   '',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' ICHFLI='',I2,
     *                                '' IPAFLI='',I2,
     *                                '' ISIFLI='',I2,   8X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ICHFLI,IPAFLI,
     *                            IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' NO-SYMM. FILLING INCOMP. WITH DIABATIC IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IDIABL=0
C
      IF (ISIMPY.EQ.1.AND.ISIGNY.EQ.1.AND.IPNMIX.NE.1) THEN
C
          INCORR=0
C
          DO IPARIT=0,NDPARI
             DO IREVER=0,NDREVE
                DO ICHARG=0,NDISOS
C
                   JSPFLI=NPFLIG(IPARIT,IREVER,ICHARG)
                   JSHFLI=NHFLIG(IPARIT,IREVER,ICHARG)
                   JFLIPI=NOFLIG(IPARIT,IREVER,ICHARG)
C
                   IF (JFLIPI.NE.0) THEN
C
                       IDIABL=1
C
                       IF (JSPFLI.LE.0.OR.JSPFLI.GT.NDSTAT.OR.
     *                     N_OCCU(JSPFLI,IPARIT,IREVER,ICHARG).NE.0)THEN
C
                           WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                            '' INCORRECT SIGNATURE PARTICLE'',
     *                            '' INDEX  '',      1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' IN THE DIABATIC DATA:   '',
     *                            ''     (BLOCK)'',  1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' ICHARG='',I2,
     *                            '' IPARIT='',I2,
     *                            '' IREVER='',I2,   8X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' JSPFLI='',I2,
     *                            '' JSHFLI='',I2,
     *                            '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            ICHARG,IPARIT,IREVER,
     *                            JSPFLI,JSHFLI,JFLIPI
C
                           INCORR=1
C
                       END IF
C
                       IF (JSHFLI.LE.0.OR.JSHFLI.GT.NDSTAT.OR.
     *                     N_OCCU(JSHFLI,IPARIT,IREVER,ICHARG).NE.1)THEN
C
                           WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                            '' INCORRECT SIGNATURE   HOLE  '',
     *                            '' INDEX  '',      1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' IN THE DIABATIC DATA:   '',
     *                            ''     (BLOCK)'',  1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' ICHARG='',I2,
     *                            '' IPARIT='',I2,
     *                            '' IREVER='',I2,   8X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' JSPFLI='',I2,
     *                            '' JSHFLI='',I2,
     *                            '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            ICHARG,IPARIT,IREVER,
     *                            JSPFLI,JSHFLI,JFLIPI
C
                           INCORR=1
C
                       END IF
C
                       IF (ABS(JFLIPI).GT.10.OR.
     *                    (ABS(JFLIPI).GE. 3.AND.ABS(JFLIPI).LE.8)) THEN
C
                           WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                            '' INCORRECT SIGNATURE OBSERVABLE'',
     *                            '' CODE '',        1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' IN THE DIABATIC DATA:   '',
     *                            ''     (BLOCK)'',  1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' ICHARG='',I2,
     *                            '' IPARIT='',I2,
     *                            '' IREVER='',I2,   8X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' JSPFLI='',I2,
     *                            '' JSHFLI='',I2,
     *                            '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            ICHARG,IPARIT,IREVER,
     *                            JSPFLI,JSHFLI,JFLIPI
C
                           INCORR=1
C
                       END IF
C
                       IF (NOFILG(IPARIT,IREVER,ICHARG).GE.1) THEN
C
                           WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                            '' FILLING APPROXIMATION'',
     *                            '' INCOMPATIBLE'', 1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' WITH THE DIABATIC DATA:   '',
     *                            ''     (BLOCK)'',  1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' ICHARG='',I2,
     *                            '' IPARIT='',I2,
     *                            '' IREVER='',I2,   8X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' JSPFLI='',I2,
     *                            '' JSHFLI='',I2,
     *                            '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            ICHARG,IPARIT,IREVER,
     *                            JSPFLI,JSHFLI,JFLIPI
C
                           INCORR=1
C
                       END IF
C
                   END IF
C
                END DO
             END DO
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORR. SIGNATURE BLOCKING/FILLING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.1.AND.ISIGNY.NE.1.AND.IPNMIX.NE.1) THEN
C
          INCORR=0
C
          DO IREVER=0,NDREVE
             DO ICHARG=0,NDISOS
C
                JSPFLI=NPFLIM(IREVER,ICHARG)
                JSHFLI=NHFLIM(IREVER,ICHARG)
                JFLIPI=NOFLIM(IREVER,ICHARG)
C
                IF (JFLIPI.NE.0) THEN
C
                    IDIABL=1
C
                    IF (JSPFLI.LE.0.OR.JSPFLI.GT.NDSTAT.OR.
     *                  L_OCCU(JSPFLI,IREVER,ICHARG).NE.0) THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT  SIMPLEX  PARTICLE'',
     *                         '' INDEX  '',      1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE DIABATIC DATA:   '',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' ICHARG='',I2,
     *                         '' IREVER='',I2,  18X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                         ICHARG,       IREVER,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
C
                    IF (JSHFLI.LE.0.OR.JSHFLI.GT.NDSTAT.OR.
     *                  L_OCCU(JSHFLI,IREVER,ICHARG).NE.1) THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT  SIMPLEX    HOLE  '',
     *                         '' INDEX  '',      1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE DIABATIC DATA:   '',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' ICHARG='',I2,
     *                         '' IREVER='',I2,  18X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                         ICHARG,       IREVER,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
C
                    IF (ABS(JFLIPI).GT.10.OR.
     *                 (ABS(JFLIPI).GE. 3.AND.ABS(JFLIPI).LE.8)) THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT SIMPLEX OBSERVABLE'',
     *                         '' CODE   '',      1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE DIABATIC DATA:   '',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' ICHARG='',I2,
     *                         '' IREVER='',I2,  18X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                         ICHARG,       IREVER,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
                END IF
C
             END DO
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT SIMPLEX BLOCKING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.IPNMIX.NE.1) THEN
C
          INCORR=0
C
          DO IPARIT=0,NDPARI
             DO ICHARG=0,NDISOS
C
                JSPFLI=NPFLIQ(IPARIT,ICHARG)
                JSHFLI=NHFLIQ(IPARIT,ICHARG)
                JFLIPI=NOFLIQ(IPARIT,ICHARG)
C
                IF (JFLIPI.NE.0) THEN
C
                    IDIABL=1
C
                    IF (JSPFLI.LE.0.OR.JSPFLI.GT.2*NDSTAT.OR.
     *                  K_OCCU(JSPFLI,IPARIT,ICHARG).NE.0) THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT  PARITY   PARTICLE'',
     *                         '' INDEX  '',      1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE DIABATIC DATA:   '',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' ICHARG='',I2,
     *                         '' IPARIT='',I2,  18X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                         ICHARG,IPARIT,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
C
                    IF (JSHFLI.LE.0.OR.JSHFLI.GT.2*NDSTAT.OR.
     *                  K_OCCU(JSHFLI,IPARIT,ICHARG).NE.1) THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT   PARITY    HOLE  '',
     *                         '' INDEX  '',      1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE DIABATIC DATA:   '',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' ICHARG='',I2,
     *                         '' IPARIT='',I2,  18X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                         ICHARG,IPARIT,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
C
                    IF (ABS(JFLIPI).GT.10) THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT PARITY  OBSERVABLE'',
     *                         '' CODE   '',      1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE DIABATIC DATA:   '',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' ICHARG='',I2,
     *                         '' IPARIT='',I2,  18X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                         ICHARG,IPARIT,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
                END IF
C
             END DO
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT PARITY BLOCKING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.IPNMIX.NE.1) THEN
C
          INCORR=0
C
          DO ICHARG=0,NDISOS
C
             JSPFLI=NPFLIZ(ICHARG)
             JSHFLI=NHFLIZ(ICHARG)
             JFLIPI=NOFLIZ(ICHARG)
C
             IF (JFLIPI.NE.0) THEN
C
                 IDIABL=1
C
                 IF (JSPFLI.LE.0.OR.JSPFLI.GT.2*NDSTAT.OR.
     *               M_OCCU(JSPFLI,ICHARG).NE.0) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT NO-SYMMETRY PARTICLE'',
     *                      '' INDEX'',        1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE DIABATIC DATA:   '',
     *                      ''     (BLOCK)'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' ICHARG='',I2,
     *                      ''        '',2X,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                      ICHARG,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
C
                 IF (JSHFLI.LE.0.OR.JSHFLI.GT.2*NDSTAT.OR.
     *               M_OCCU(JSHFLI,ICHARG).NE.1) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT NO-SYMMETRY HOLE  '',
     *                      '' INDEX  '',      1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE DIABATIC DATA:   '',
     *                      ''     (BLOCK)'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' ICHARG='',I2,
     *                      ''        '',2X,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                      ICHARG,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
C
                 IF (ABS(JFLIPI).GT.10) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT NO-SYMMETRY OBSERVABLE'',
     *                      '' CODE'',         1X,19(1H/),/,
     *                            1X,20(1H/),
     *                      '' IN THE DIABATIC DATA:   '',
     *                      ''      (BLOCK)'', 1X,19(1H/),/,
     *                            1X,20(1H/),
     *                      '' ICHARG='',I2,
     *                      ''        '',2X,  19X,19(1H/),/,
     *                            1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   9X,19(1H/),/)')
     *
     *                      ICHARG,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
C
                 IF (NOFILZ(ICHARG).GE.1) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' FILLING APPROXIMATION'',
     *                      '' INCOMPATIBLE'', 1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' WITH THE DIABATIC DATA FOR'',
     *                      '' NO SYMMETRY'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' ICHARG='',I2,
     *                      ''        '',2X,
     *                      ''        '',2X,   8X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                      ICHARG,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
C
             END IF
C
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT NO-SYMM. BLOCKING/FILLING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.ISIMPY.EQ.1.AND.ISIGNY.EQ.1.AND.IPNMIX.EQ.1)
     *                                                              THEN
C
          IF (ISPFLI.LE.0.OR.ISPFLI.GT.2*NDSTAT.OR.
     *        NMOCCU(ISPFLI,IPAFLI,IREFLI).NE.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT SIGNATURE PARTICLE'',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),''        '',2X,
     *                                '' IPAFLI='',I2,
     *                                '' ISIFLI='',I2,   8X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            IPAFLI,
     *                            IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT PNMIX SIGNATURE PARTICLE '',
     *                       ''INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ISHFLI.LE.0.OR.ISHFLI.GT.2*NDSTAT.OR.
     *        NMOCCU(ISHFLI,IPAFLI,IREFLI).NE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT SIGNATURE   HOLE  '',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),''        '',2X,
     *                                '' IPAFLI='',I2,
     *                                '' ISIFLI='',I2,   8X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            IPAFLI,
     *                            IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT PNMIX SIGNATURE HOLE '',
     *                       ''INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ABS(IFLIPI).GT.11.OR.
     *       (ABS(IFLIPI).GE.3.AND.ABS(IFLIPI).LE.8)) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT OBSERVABLE INDEX  '',
     *                                '' (SIGN) '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' IFLIPI='',I2,
     *                                ''        '',2X,
     *                                ''        '',2X,   8X,20(1H/),/)')
     *
     *                     IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT PNMIX SIGNATURE '',
     *                       ''OBSERVABLE INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.ISIMPY.EQ.1.AND.ISIGNY.NE.1.AND.IPNMIX.EQ.1)
     *                                                              THEN
C
          IF (ISPFLI.LE.0.OR.ISPFLI.GT.2*NDSTAT.OR.
     *        LMOCCU(ISPFLI,IREFLI).NE.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT  SIMPLEX  PARTICLE'',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),''        '',2X,
     *                                '' ISIFLI='',I2,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            IREFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT SIMPLEX PNMIX PARTICLE '',
     *                       ''INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ISHFLI.LE.0.OR.ISHFLI.GT.2*NDSTAT.OR.
     *        LMOCCU(ISHFLI,IREFLI).NE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT  SIMPLEX    HOLE  '',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),''        '',2X,
     *                                '' ISIFLI='',I2,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            IREFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT SIMPLEX PNMIX HOLE '',
     *                       ''INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
C=======================================================================
C
          IF (IPAFLI.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPAFLI=1 IS FORBIDDEN FOR'',
     *                                '' ISIGNY=0'',7X,20(1H/),/)')
              ERRSTR='IPAFLI=1 AND ISIGNY=0 INCONSISTENCY IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ABS(IFLIPI).GT.11.OR.
     *       (ABS(IFLIPI).GE.3.AND.ABS(IFLIPI).LE.8)) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT OBSERVABLE INDEX '',
     *                                '' (SIMPL) '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' IFLIPI='',I2,
     *                                ''        '',2X,
     *                                ''        '',2X,   8X,20(1H/),/)')
     *
     *                     IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT SIMPLEX PNMIX OBSERVABLE '',
     *                       ''INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.IPNMIX.EQ.1)
     *                                                              THEN
C
          IF (ISPFLI.LE.0.OR.ISPFLI.GT.4*NDSTAT.OR.
     *        KMOCCU(ISPFLI,IPAFLI).NE.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT  PARITY   PARTICLE'',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),''        '',2X,
     *                                '' IPAFLI='',I2,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT PARITY PNMIX PARTICLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ISHFLI.LE.0.OR.ISHFLI.GT.4*NDSTAT.OR.
     *        KMOCCU(ISHFLI,IPAFLI).NE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT   PARITY    HOLE  '',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),''        '',2X,
     *                                '' IPAFLI='',I2,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                            IPAFLI,
     *                     ISPFLI,ISHFLI,IFLIPI
C
              ERRSTR=' INCORRECT PARITY PNMIX HOLE INDEX IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
C=======================================================================
C
          IF (IREFLI.NE.IPAFLI) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' ISIFLI=1 IS FORBIDDEN FOR'',
     *                                '' IPARTY=1'',7X,20(1H/),/)')
              ERRSTR='ISIFLI=1 AND IPARTY=1 INCONSISTENCY IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ABS(IFLIPI).GT.11) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT OBSERVABLE INDEX '',
     *                                '' (PARIT) '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' IFLIPI='',I2,
     *                                ''        '',2X,
     *                                ''        '',2X,   8X,20(1H/),/)')
     *
     *                     IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT PARITY PNMIX OBSERVABLE '',
     *                       ''INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.IPNMIX.EQ.1)
     *                                                              THEN
C
          IF (ISPFLI.LE.0.OR.ISPFLI.GT.4*NDSTAT.OR.
     *        MMOCCU(ISPFLI).NE.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT NO-SYMMETRY PARTIC'',
     *                                ''LE INDEX'',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),''        '',2X,
     *                                ''        '',2X,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ISPFLI,ISHFLI,IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT NO-SYMMETRY PNMIX PARTICLE '',
     *                       ''INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ISHFLI.LE.0.OR.ISHFLI.GT.4*NDSTAT.OR.
     *        MMOCCU(ISHFLI).NE.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT NO-SYMMETRY HOLE  '',
     *                                '' INDEX  '',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),''        '',2X,
     *                                ''        '',2X,  18X,20(1H/),/,
     *                     1X,20(1H/),'' ISPFLI='',I2,
     *                                '' ISHFLI='',I2,
     *                                '' IFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                     ISPFLI,ISHFLI,IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT NO-SYMMETRY PNMIX HOLE '',
     *                       ''INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
C=======================================================================
C
          IF (IPAFLI.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' IPAFLI=1 IS FORBIDDEN FOR'',
     *                                '' ISIMPY=0'',7X,20(1H/),/)')
              ERRSTR='IPAFLI=1 AND ISIMPY=0 INCONSISTENCY IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (IREFLI.EQ.1) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' IREFLI=1 IS FORBIDDEN FOR'',
     *                                '' ISIMPY=0'',7X,20(1H/),/)')
              ERRSTR='IREFLI=1 AND ISIMPY=0 INCONSISTENCY IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
          IF (ABS(IFLIPI).GT.11) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' INCORRECT OBSERVABLE INDEX '',
     *                                '' (NO-SYM)'',      1X,20(1H/),/,
     *                     1X,20(1H/),'' IN THE PN DIABATIC DATA:'',
     *                                ''            '',  1X,20(1H/),/,
     *                     1X,20(1H/),'' IFLIPI='',I2,
     *                                ''        '',2X,
     *                                ''        '',2X,   8X,20(1H/),/)')
     *
     *                     IFLIPI
C
              WRITE(ERRSTR,'('' INCORRECT NO-SYMMETRY PNMIX '',
     *                       ''OBSERVABLE INDEX IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IDIABL=0
C
      IF (ISIMPY.EQ.1.AND.ISIGNY.EQ.1.AND.IPNMIX.EQ.1
     *                               .AND.IPAIRI.EQ.0) THEN
C
          INCORR=0
C
          DO IPARIT=0,NDPARI
             DO IREVER=0,NDREVE
C
                JSPFLI=NPMLIG(IPARIT,IREVER)
                JSHFLI=NHMLIG(IPARIT,IREVER)
                JFLIPI=NOMLIG(IPARIT,IREVER)
C
                IF (JFLIPI.NE.0) THEN
C
                    IDIABL=1
C
                    IF (JSPFLI.LE.0.OR.JSPFLI.GT.NDSTAT.OR.
     *                  NMOCCU(JSPFLI,IPARIT,IREVER).NE.0)THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT SIGNATURE PARTICLE'',
     *                         '' INDEX  '',      1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE PN DIABATIC DATA:'',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         ''        '',2X,
     *                         '' IPARIT='',I2,
     *                         '' IREVER='',I2,   8X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                                IPARIT,IREVER,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
C
                    IF (JSHFLI.LE.0.OR.JSHFLI.GT.2*NDSTAT.OR.
     *                  NMOCCU(JSHFLI,IPARIT,IREVER).NE.1)THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT SIGNATURE   HOLE  '',
     *                         '' INDEX  '',      1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE PN DIABATIC DATA:'',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         ''        '',2X,
     *                         '' IPARIT='',I2,
     *                         '' IREVER='',I2,   8X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                                IPARIT,IREVER,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
C
                    IF (ABS(JFLIPI).GT.11.OR.
     *                 (ABS(JFLIPI).GE. 3.AND.ABS(JFLIPI).LE.8)) THEN
C
                        WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                         '' INCORRECT SIGNATURE OBSERVABLE'',
     *                         '' CODE '',        1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' IN THE PN DIABATIC DATA:'',
     *                         ''     (BLOCK)'',  1X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         ''        '',2X,
     *                         '' IPARIT='',I2,
     *                         '' IREVER='',I2,   8X,20(1H/),/,
     *                                            1X,20(1H/),
     *                         '' JSPFLI='',I2,
     *                         '' JSHFLI='',I2,
     *                         '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                                IPARIT,IREVER,
     *                         JSPFLI,JSHFLI,JFLIPI
C
                        INCORR=1
C
                    END IF
C
                END IF
C
             END DO
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT SIGNATURE PNMIX BLOCKING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.1.AND.ISIGNY.NE.1.AND.IPNMIX.EQ.1
     *                               .AND.IPAIRI.EQ.0) THEN
C
          INCORR=0
C
          DO IREVER=0,NDREVE
C
             JSPFLI=NPMLIM(IREVER)
             JSHFLI=NHMLIM(IREVER)
             JFLIPI=NOMLIM(IREVER)
C
             IF (JFLIPI.NE.0) THEN
C
                 IDIABL=1
C
                 IF (JSPFLI.LE.0.OR.JSPFLI.GT.2*NDSTAT.OR.
     *               LMOCCU(JSPFLI,IREVER).NE.0) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT  SIMPLEX  PARTICLE'',
     *                      '' INDEX  '',      1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE PN DIABATIC DATA:'',
     *                      ''     (BLOCK)'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      ''        '',2X,
     *                      '' IREVER='',I2,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                                    IREVER,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
C
                 IF (JSHFLI.LE.0.OR.JSHFLI.GT.2*NDSTAT.OR.
     *               LMOCCU(JSHFLI,IREVER).NE.1) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT  SIMPLEX    HOLE  '',
     *                      '' INDEX  '',      1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE PN DIABATIC DATA:'',
     *                      ''     (BLOCK)'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      ''        '',2X,
     *                      '' IREVER='',I2,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                                    IREVER,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
C
                 IF (ABS(JFLIPI).GT.11.OR.
     *              (ABS(JFLIPI).GE. 3.AND.ABS(JFLIPI).LE.8)) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT SIMPLEX OBSERVABLE'',
     *                      '' CODE   '',      1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE PN DIABATIC DATA:'',
     *                      ''     (BLOCK)'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      ''        '',2X,
     *                      '' IREVER='',I2,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                                    IREVER,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
             END IF
C
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT SIMPLEX PNMIX BLOCKING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.ISIQTY.EQ.1.AND.IPNMIX.EQ.1
     *                               .AND.IPAIRI.EQ.0) THEN
C
          INCORR=0
C
          DO IPARIT=0,NDPARI
C
             JSPFLI=NPMLIQ(IPARIT)
             JSHFLI=NHMLIQ(IPARIT)
             JFLIPI=NOMLIQ(IPARIT)
C
             IF (JFLIPI.NE.0) THEN
C
                 IDIABL=1
C
                 IF (JSPFLI.LE.0.OR.JSPFLI.GT.4*NDSTAT.OR.
     *               KMOCCU(JSPFLI,IPARIT).NE.0) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT  PARITY   PARTICLE'',
     *                      '' INDEX  '',      1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE PN DIABATIC DATA:'',
     *                      ''     (BLOCK)'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      ''        '',2X,
     *                      '' IPARIT='',I2,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                             IPARIT,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
C
                 IF (JSHFLI.LE.0.OR.JSHFLI.GT.4*NDSTAT.OR.
     *               KMOCCU(JSHFLI,IPARIT).NE.1) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT   PARITY    HOLE  '',
     *                      '' INDEX  '',      1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE PN DIABATIC DATA:'',
     *                      ''     (BLOCK)'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      ''        '',2X,
     *                      '' IPARIT='',I2,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                             IPARIT,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
C
                 IF (ABS(JFLIPI).GT.11) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT PARITY  OBSERVABLE'',
     *                      '' CODE   '',      1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE PN DIABATIC DATA:   '',
     *                      ''     (BLOCK)'',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      ''        '',2X,
     *                      '' IPARIT='',I2,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFLI='',I2,
     *                      '' JSHFLI='',I2,
     *                      '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                             IPARIT,
     *                      JSPFLI,JSHFLI,JFLIPI
C
                     INCORR=1
C
                 END IF
             END IF
C
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT PARITY PNMIX BLOCKING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.ISIQTY.NE.1.AND.IPNMIX.EQ.1
     *                               .AND.IPAIRI.EQ.0) THEN
C
          INCORR=0
C
          JSPFLI=NPMLIZ
          JSHFLI=NHMLIZ
          JFLIPI=NOMLIZ
C
          IF (JFLIPI.NE.0) THEN
C
              IDIABL=1
C
              IF (JSPFLI.LE.0.OR.JSPFLI.GT.4*NDSTAT.OR.
     *            MMOCCU(JSPFLI).NE.0) THEN
C
                  WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                   '' INCORRECT NO-SYMMETRY PARTICLE'',
     *                   '' INDEX'',        1X,20(1H/),/,
     *                                      1X,20(1H/),
     *                   '' IN THE PN DIABATIC DATA:'',
     *                   ''     (BLOCK)'',  1X,20(1H/),/,
     *                                      1X,20(1H/),
     *                   ''        '',2X,
     *                   ''        '',2X,  18X,20(1H/),/,
     *                                      1X,20(1H/),
     *                   '' JSPFLI='',I2,
     *                   '' JSHFLI='',I2,
     *                   '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                   JSPFLI,JSHFLI,JFLIPI
C
                  INCORR=1
C
              END IF
C
              IF (JSHFLI.LE.0.OR.JSHFLI.GT.4*NDSTAT.OR.
     *            MMOCCU(JSHFLI).NE.1) THEN
C
                  WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                   '' INCORRECT NO-SYMMETRY HOLE  '',
     *                   '' INDEX  '',      1X,20(1H/),/,
     *                                      1X,20(1H/),
     *                   '' IN THE PN DIABATIC DATA:'',
     *                   ''     (BLOCK)'',  1X,20(1H/),/,
     *                                      1X,20(1H/),
     *                   ''        '',2X,
     *                   ''        '',2X,  18X,20(1H/),/,
     *                                      1X,20(1H/),
     *                   '' JSPFLI='',I2,
     *                   '' JSHFLI='',I2,
     *                   '' JFLIPI='',I2,   8X,20(1H/),/)')
     *
     *                   JSPFLI,JSHFLI,JFLIPI
C
                  INCORR=1
C
              END IF
C
              IF (ABS(JFLIPI).GT.11) THEN
C
                  WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                   '' INCORRECT NO-SYMMETRY OBSERVABLE'',
     *                   '' CODE'',         1X,19(1H/),/,
     *                         1X,20(1H/),
     *                   '' IN THE PN DIABATIC DATA:'',
     *                   ''      (BLOCK)'', 1X,19(1H/),/,
     *                         1X,20(1H/),
     *                   ''        '',2X,
     *                   ''        '',2X,  19X,19(1H/),/,
     *                         1X,20(1H/),
     *                   '' JSPFLI='',I2,
     *                   '' JSHFLI='',I2,
     *                   '' JFLIPI='',I2,   9X,19(1H/),/)')
     *
     *                   JSPFLI,JSHFLI,JFLIPI
C
                  INCORR=1
C
              END IF
C
          END IF
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT No-SYMM. PNMIX BLOCKING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IFLIPI.NE.0.AND.IDIABL.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' SINGLE-PAIR AND ALL-BLOCKS'',
     *                            '' DIABATIC'',2X,20(1H/),/,
     *                 1X,20(1H/),'' BLOCKINGS CANNOT BE USED  '',
     *                            ''         '',2X,20(1H/),/,
     *                 1X,20(1H/),'' S I M U L T A N E O U S L Y'',
     *                            ''        '',2X,20(1H/),/)')
C
          ERRSTR=' SINGLE-PAIR VS. ALL-BLOCKS INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFLIPI.NE.0.OR.IDIABL.NE.0).AND.IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' DIABATIC BLOCKING CANNOT '',
     *                            '' BE USED '',3X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH IROTAT=0    '',
     *                            ''         '',2X,20(1H/),/)')
C
          ERRSTR=' DIABATIC BLOCKING AND IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFLIPI.NE.0.OR.IDIABL.NE.0).AND.IPAIRI.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' DIABATIC BLOCKING CANNOT '',
     *                            '' BE USED '',3X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH IPAIRI=1    '',
     *                            ''         '',2X,20(1H/),/)')
C
          ERRSTR=' DIABATIC BLOCKING AND IPAIRI=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.1.AND.ISIGNY.EQ.1) THEN
C
          INCORR=0
C
          DO IPARIT=0,NDPARI
             DO IREVER=0,NDREVE
                DO ICHARG=0,NDISOS
C
                   JSPFIL=NPFILG(IPARIT,IREVER,ICHARG)
                   JSHFIL=NHFILG(IPARIT,IREVER,ICHARG)
                   JFILPI=NOFILG(IPARIT,IREVER,ICHARG)
C
                   IF (JFILPI.GE.1) THEN
C
                       IF (JSPFIL.LE.0.OR.JSPFIL.GT.NDSTAT.OR.
     *                     JSPFIL.LT.JSHFIL) THEN
C
                           WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                            '' INCORRECT SIGNATURE   UPPER '',
     *                            '' INDEX  '',      1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' IN THE FILLING APPROXIMATION'',
     *                            '' DATA:  '',  1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' ICHARG='',I2,
     *                            '' IPARIT='',I2,
     *                            '' IREVER='',I2,   8X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' JSPFIL='',I2,
     *                            '' JSHFIL='',I2,
     *                            '' JFILPI='',I2,   8X,20(1H/),/)')
     *
     *                            ICHARG,IPARIT,IREVER,
     *                            JSPFIL,JSHFIL,JFILPI
C
                           INCORR=1
C
                       END IF
C
                       IF (JSHFIL.LE.0.OR.JSHFIL.GT.NDSTAT.OR.
     *                     JSHFIL.GT.JSPFIL) THEN
C
                           WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                            '' INCORRECT SIGNATURE  LOWER  '',
     *                            '' INDEX  '',      1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' IN THE FILLING APPROXIMATION'',
     *                            '' DATA:  '',  1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' ICHARG='',I2,
     *                            '' IPARIT='',I2,
     *                            '' IREVER='',I2,   8X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' JSPFIL='',I2,
     *                            '' JSHFIL='',I2,
     *                            '' JFILPI='',I2,   8X,20(1H/),/)')
     *
     *                            ICHARG,IPARIT,IREVER,
     *                            JSPFIL,JSHFIL,JFILPI
C
                           INCORR=1
C
                       END IF
C
                       IF (JFILPI.GT.2*(JSPFIL-JSHFIL+1)) THEN
C
                           WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                            '' INCORRECT SIGNATURE PARTICLE'',
     *                            '' NUMBER '',        1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' IN THE FILLING  DATA:   '',
     *                            ''            '',  1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' ICHARG='',I2,
     *                            '' IPARIT='',I2,
     *                            '' IREVER='',I2,   8X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' JSPFIL='',I2,
     *                            '' JSHFIL='',I2,
     *                            '' JFILPI='',I2,   8X,20(1H/),/)')
     *
     *                            ICHARG,IPARIT,IREVER,
     *                            JSPFIL,JSHFIL,JFILPI
C
                           INCORR=1
C
                       END IF
C
                       IF (IPAIRI.EQ.1) THEN
C
                           WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                            '' FILLING  APPROXIMATION '',
     *                            '' INCOMPATIBLE'', 1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' WITH PAIRING CORRELATIONS'',
     *                            '' (IPAIRI=1)'',   1X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' ICHARG='',I2,
     *                            '' IPARIT='',I2,
     *                            '' IREVER='',I2,   8X,20(1H/),/,
     *                                               1X,20(1H/),
     *                            '' JSPFIL='',I2,
     *                            '' JSHFIL='',I2,
     *                            '' JFILPI='',I2,   8X,20(1H/),/)')
     *
     *                            ICHARG,IPARIT,IREVER,
     *                            JSPFIL,JSHFIL,JFILPI
C
                           INCORR=1
C
                       END IF
C
                   END IF
C
                END DO
             END DO
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT SIGNATURE FILLING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.ISIQTY.NE.1) THEN
C
          INCORR=0
C
          DO ICHARG=0,NDISOS
C
             JSPFIL=NPFILZ(ICHARG)
             JSHFIL=NHFILZ(ICHARG)
             JFILPI=NOFILZ(ICHARG)
C
             IF (JFILPI.NE.0) THEN
C
                 IDIABL=1
C
                 IF (JSPFIL.LE.0.OR.JSPFIL.GT.2*NDSTAT.OR.
     *               JSPFIL.LT.JSHFIL) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT NO-SYMMETRY UPPER'',
     *                      '' INDEX   '',     1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE FILLING  DATA:   '',
     *                      ''            '',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' ICHARG='',I2,
     *                      ''        '',2X,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFIL='',I2,
     *                      '' JSHFIL='',I2,
     *                      '' JFILPI='',I2,   8X,20(1H/),/)')
     *
     *                      ICHARG,
     *                      JSPFIL,JSHFIL,JFILPI
C
                     INCORR=1
C
                 END IF
C
                 IF (JSHFIL.LE.0.OR.JSHFIL.GT.2*NDSTAT.OR.
     *               JSHFIL.GT.JSPFIL) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT NO-SYMMETRY LOWER'',
     *                      '' INDEX   '',     1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' IN THE FILLING  DATA:   '',
     *                      ''            '',  1X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' ICHARG='',I2,
     *                      ''        '',2X,  18X,20(1H/),/,
     *                                         1X,20(1H/),
     *                      '' JSPFIL='',I2,
     *                      '' JSHFIL='',I2,
     *                      '' JFILPI='',I2,   8X,20(1H/),/)')
     *
     *                      ICHARG,
     *                      JSPFIL,JSHFIL,JFILPI
C
                     INCORR=1
C
                 END IF
C
                 IF (JFILPI.GT.2*(JSPFIL-JSHFIL+1)) THEN
C
                     WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                      '' INCORRECT NO-SYMMETRY PARTICLE'',
     *                      '' NUMBER'',         1X,19(1H/),/,
     *                            1X,20(1H/),
     *                      '' IN THE FILLING  DATA:   '',
     *                      ''             '', 1X,19(1H/),/,
     *                            1X,20(1H/),
     *                      '' ICHARG='',I2,
     *                      ''        '',2X,  19X,19(1H/),/,
     *                            1X,20(1H/),
     *                      '' JSPFIL='',I2,
     *                      '' JSHFIL='',I2,
     *                      '' JFILPI='',I2,   9X,19(1H/),/)')
     *
     *                      ICHARG,
     *                      JSPFIL,JSHFIL,JFILPI
C
                     INCORR=1
C
                 END IF
C
             END IF
C
          END DO
C
          IF (INCORR.EQ.1) THEN
              WRITE(ERRSTR,'('' INCORRECT NO-SYMMETRY FILLING '',
     *                       ''DATA IN TESDAT'')')
              CALL ERPUSH(ERRSTR,IERROR)
          END IF
C
      END IF
C
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.35H) AND  (2.52J)  THE  TEST
C                       BELOW INCLUDED ALSO THE FOLLOING CONDITION:
C                               NUMBSP(IREVER,ICHARG).GT.NLIMIT
C                       WHICH WAS STOPPING THE CODE IN CASE OF NLIMIT<0,
C                       THAT IS, WHEN THE BASIS WAS SUPPOSED TO  BE  CUT
C                       BASED ON THE ENERGIES OF THE HO STATES.
C                       THIS BUG WAS CORRECTED ON 13/02/2012 IN  VERSION
C                       (2.52K).
C=======================================================================
C
      INCORR=0
C
      DO IREVER=0,NDREVE
         DO ICHARG=0,NDISOS
C
            IF (NUMBSP(IREVER,ICHARG).LT.0.OR.
     *          NUMBSP(IREVER,ICHARG).GT.NDSTAT) THEN
C
                WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                 '' INCORRECT PHASE SPACE DEFINITION'',
     *                 ''    '',          1X,20(1H/),/,
     *                                    1X,20(1H/),
     *                 '' IREVER='',I4,
     *                 '' ICHARG='',I4,
     *                 '' NUMBSP='',I4,   2X,20(1H/),/,
     *                                    1X,20(1H/),
     *                 '' NLIMIT='',I4,
     *                 '' NDSTAT='',I4,
     *                 ''        '',      6X,20(1H/),/)')
     *
     *                 IREVER,ICHARG,NUMBSP(IREVER,ICHARG),
     *                 NLIMIT,NDSTAT
C
                INCORR=1
C
            END IF
C
         END DO
      END DO
C
      IF (INCORR.EQ.1) THEN
          ERRSTR=' INCORRECT PHASE SPACE DEFINITION IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
C=======================================================================
C
      IF ((ITILAX.NE.0.OR.ITISAX.NE.0).AND.IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' TILTED-AXIS CRANKING CANNOT'',
     *                            '' BE USED '',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH IROTAT=0    '',
     *                            ''         '',2X,20(1H/),/,
     *                 1X,20(1H/),'' (ITILAX='',I1,'', ITISAX='',I1,
     *                            '')        '',9X,20(1H/),/)')
     *
     *    ITILAX,ITISAX
C
          ERRSTR=' TILTED AXIS AND IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ITILAX.NE.0.OR.ITISAX.NE.0).AND.ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' TILTED-AXIS CRANKING CANNOT'',
     *                            '' BE USED '',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH ISIMPY=1    '',
     *                            ''         '',2X,20(1H/),/,
     *                 1X,20(1H/),'' (ITILAX='',I1,'', ITISAX='',I1,
     *                            '')        '',9X,20(1H/),/)')
     *
     *    ITILAX,ITISAX
C
          ERRSTR=' TILTED AXIS AND ISIMPY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ITILAX.NE.0.OR.ITISAX.NE.0).AND.ISIGNY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' TILTED-AXIS CRANKING CANNOT'',
     *                            '' BE USED '',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH ISIGNY=1    '',
     *                            ''         '',2X,20(1H/),/,
     *                 1X,20(1H/),'' (ITILAX='',I1,'', ITISAX='',I1,
     *                            '')        '',9X,20(1H/),/)')
     *
     *    ITILAX,ITISAX
C
          ERRSTR=' TILTED AXIS AND ISIGNY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1).AND.
     *    (ISIMPY.NE.1.OR.ISIGNY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' PARITY/SIGN. QUASIP.  BLOCKING'',
     *                            ''  ONLY'',1X,20(1H/),/,
     *                 1X,20(1H/),'' ALLOWED  FOR  ISIMPY=1 AND'',
     *                            '' ISIGNY=1'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' PAR./SIG. Q.P. BLOCKING & ISIMPY=0 OR '',
     *                   ''ISIGNY=0 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1).AND.
     *    (ISIMPY.NE.1.OR.ISIGNY.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' SIMPLEX QUASIPARTICLE BLOCKING'',
     *                            '' ONLY'',2X,20(1H/),/,
     *                 1X,20(1H/),'' ALLOWED  FOR  ISIMPY=1 AND'',
     *                            '' ISIGNY=0'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' SIMPLEX Q.P. BLOCKING & ISIMPY=0 OR '',
     *                   ''ISIGNY=1 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((MAXVAL(IABS(IDSIQN)).GE.1.OR.MAXVAL(IABS(IDSIQP)).GE.1).AND.
     *    (ISIMPY.EQ.1.OR.ISIQTY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' PARITY  Q.P. OR S.P.  BLOCKING'',
     *                            ''  ONLY'',1X,20(1H/),/,
     *                 1X,20(1H/),'' ALLOWED  FOR  ISIMPY=0 AND'',
     *                            '' ISIQTY=1'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' PARITY Q.P./S.P. BLOCKING & ISIMPY=0 OR '',
     *                   ''ISIQTY=0 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((MAXVAL(IABS(IDSIZN)).GE.1.OR.MAXVAL(IABS(IDSIZP)).GE.1).AND.
     *    (ISIMPY.EQ.1.OR.ISIQTY.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NO SYM. Q.P. OR S.P.  BLOCKING'',
     *                            ''  ONLY'',1X,20(1H/),/,
     *                 1X,20(1H/),'' ALLOWED  FOR  ISIMPY=0 AND'',
     *                            '' ISIQTY=0'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' NO SYM. Q.P./S.P. BLOCKING & ISIMPY=1 OR '',
     *                   ''ISIQTY=1 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFIBLN.EQ.1.OR.INIBLN.EQ.1).AND.IABS(IDSIGN).NE.1.AND.
     *    (ISIMPY.EQ.1.AND.ISIQTY.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING & FIXED/INITD NEUTRON'',
     *                            '' WAVE'',2X,20(1H/),/,
     *                 1X,20(1H/),'' FUNCTIONS REQUIRES THAT '',
     *                            '' |IDSIGN|=1'',2X,20(1H/),/)')
C
C=======================================================================
C         ATTENTION: BETWEEN  VERSIONS  (3.00K)  AND  (3.07),  CHARACTER
C                    VARIABLES  "ERRSTR"  WERE  WRITTEN   WITH   STRINGS
C                    CONTAINING "FIXED/INITLZD" THAT  WERE  69-CHARACTER
C                    LONG WHILE "ERRSTR" WAS DECLARED 68-CHARACTER LONG.
C                    THIS WAS CRASHING  THE  CODE  WHEN  THESE  SPECIFIC
C                    ERROR MESSAGES WERE SUPPOSED TO BE PRINTED. THE BUG
C                    WAS CORRECTED ON 09/09/2021 IN VERSION (3.07A).
C                    MORE SIMILAR BUGS WERE  CORRECTED  ON  27/01/24  IN
C                    VERSION (3.22P).
C=======================================================================
C
          WRITE(ERRSTR,'('' BLOCKING WITH FIXED/INITLZD NEUTRON WFS'',
     *                   '' AND |IDSIGN|<>1 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFIBLP.EQ.1.OR.INIBLP.EQ.1).AND.IABS(IDSIGP).NE.1.AND.
     *    (ISIMPY.EQ.1.AND.ISIQTY.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING & FIXED/INITD  PROTON'',
     *                            '' WAVE'',2X,20(1H/),/,
     *                 1X,20(1H/),'' FUNCTIONS REQUIRES THAT '',
     *                            '' |IDSIGP|=1'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING WITH FIXED/INITLZD PROTON WFS'',
     *                   '' AND |IDSIGP|<>1 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFIBLN.EQ.1.OR.INIBLN.EQ.1).AND.IABS(IDSIMN).NE.1.AND.
     *    (ISIMPY.EQ.1.AND.ISIQTY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING & FIXED/INITD NEUTRON'',
     *                            '' WAVE'',2X,20(1H/),/,
     *                 1X,20(1H/),'' FUNCTIONS REQUIRES THAT '',
     *                            '' |IDSIMN|=1'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING WITH FIXED/INITLZD NEUTRON WFS'',
     *                   '' AND |IDSIMN|<>1 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFIBLP.EQ.1.OR.INIBLP.EQ.1).AND.IABS(IDSIMP).NE.1.AND.
     *    (ISIMPY.EQ.1.AND.ISIQTY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING & FIXED/INITD  PROTON'',
     *                            '' WAVE'',2X,20(1H/),/,
     *                 1X,20(1H/),'' FUNCTIONS REQUIRES THAT '',
     *                            '' |IDSIMP|=1'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING WITH FIXED/INITLZD PROTON WFS'',
     *                   '' AND |IDSIMP|<>1 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFIBLN.EQ.1.OR.INIBLN.EQ.1).AND.
     *     MAXVAL(IABS(IDSIQN)).LT.1.AND.
     *    (ISIMPY.NE.1.AND.ISIQTY.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' BLOCKING & FIXED/INITD NEUTRON'',
     *                           '' WAVE'',2X,20(1H/),/,
     *                1X,20(1H/),'' FUNCTIONS RQUIRS'',
     *                           '' MAXVAL(|IDSIQN|)>0'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING WITH FIXED/INITLZD NEUTRON WFS'',
     *                   '' AND MAXVAL(|IDSIQN|)<1'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFIBLP.EQ.1.OR.INIBLP.EQ.1).AND.
     *     MAXVAL(IABS(IDSIQP)).LT.1.AND.
     *    (ISIMPY.NE.1.AND.ISIQTY.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                1X,20(1H/),'' BLOCKING & FIXED/INITD  PROTON'',
     *                           '' WAVE'',2X,20(1H/),/,
     *                1X,20(1H/),'' FUNCTIONS RQUIRS'',
     *                           '' MAXVAL(|IDSIQP|)>0'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING WITH FIXED/INITLZD PROTON WFS'',
     *                   '' AND MAXVAL(|IDSIQP|)<1'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFIBLN.EQ.1.OR.INIBLN.EQ.1).AND.
     *     MAXVAL(IABS(IDSIZN)).LT.1.AND.
     *    (ISIMPY.NE.1.AND.ISIQTY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING & FIXED/INITD NEUTRON'',
     *                            '' WAVE'',2X,20(1H/),/,
     *                1X,20(1H/),'' FUNCTIONS RQUIRS'',
     *                           '' MAXVAL(|IDSIZN|)>0'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING WITH FIXED/INITLZD NEUTRON WFS'',
     *                   '' AND MAXVAL(|IDSIZN|)<1'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFIBLP.EQ.1.OR.INIBLP.EQ.1).AND.
     *     MAXVAL(IABS(IDSIZP)).LT.1.AND.
     *    (ISIMPY.NE.1.AND.ISIQTY.NE.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING & FIXED/INITD  PROTON'',
     *                            '' WAVE'',2X,20(1H/),/,
     *                1X,20(1H/),'' FUNCTIONS RQUIRS'',
     *                           '' MAXVAL(|IDSIZP|)>0'',2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING WITH FIXED/INITLZD PROTON WFS'',
     *                   '' AND MAXVAL(|IDSIZP|)<1'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIMN).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQN)).GE.1.OR.
     *     MAXVAL(IABS(IDSIZN)).GE.1).AND.
     *     INIBLN.EQ.0 .AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING NONINITIALIZED NEUTRON'',
     *                            '' WAVE'',             1X,20(1H/),/,
     *                 1X,20(1H/),'' FUNCTIONS  REQUIRES  THAT '',
     *                            '' ICONTI=1'',         2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING NONINITIALIZED NEUTRON WFS &'',
     *                   '' ICONTI=0 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGP).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQP)).GE.1.OR.
     *     MAXVAL(IABS(IDSIZP)).GE.1).AND.
     *     INIBLP.EQ.0 .AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING NONINITIALIZED  PROTON'',
     *                            '' WAVE'',             1X,20(1H/),/,
     *                 1X,20(1H/),'' FUNCTIONS  REQUIRES  THAT '',
     *                            '' ICONTI=1'',         2X,20(1H/),/)')
C
          WRITE(ERRSTR,'('' BLOCKING NONINITIALIZED PROTON WFS &'',
     *                   '' ICONTI=0 IN TESDAT'')')
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1.OR.
     *     IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQN)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQP)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIZN)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIZP)).EQ.1).AND.IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *             1X,20(1H/),'' QUASIPARTICLE BLOCKING REQUIRES THAT'',
     *                                                   1X,20(1H/),/,
     *             1X,20(1H/),'' THE TIME-REVERSAL BE BROKEN IROTAT=1'',
     *                                                   1X,20(1H/),/)')
C
          ERRSTR=' QUASIPARTICLE BLOCKING ONLY FOR IROTAT=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      JDSIGN=0
      JDSIMN=0
      JDSIQN=0
      JDSIZN=0
C
      IF (       IABS(IDSIGN) .GE.1) JDSIGN=1
      IF (       IABS(IDSIMN) .GE.1) JDSIMN=1
      IF (MAXVAL(IABS(IDSIQN)).GE.1) JDSIQN=1
      IF (MAXVAL(IABS(IDSIZN)).GE.1) JDSIZN=1
C
      IF (JDSIGN+JDSIMN+JDSIQN+JDSIZN.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *             1X,20(1H/),'' NEUTRON Q.P. OR S.P.  BLOCKING  IS  '',
     *                                                   1X,20(1H/),/,
     *             1X,20(1H/),'' ALLOWED FOR ONE SYMMETRY CASE ONLY  '',
     *                                                   1X,20(1H/),/,
     *             1X,20(1H/),'' IDSIGN = '',I2,'' IDSIMN = '',I2,
     *                                                  14X,20(1H/),/,
     *             1X,20(1H/),'' MAXVAL(IABS(IDSIQN)) = '',I2,
     *                                                  12X,20(1H/),/,
     *             1X,20(1H/),'' MAXVAL(IABS(IDSIZN)) = '',I2,
     *                                                  12X,20(1H/),/)')
     *             IDSIGN,IDSIMN,MAXVAL(IABS(IDSIQN)),
     *                           MAXVAL(IABS(IDSIZN))
C
          ERRSTR=' MULTI-SYMMETRY NEUTRON QUASIPART. BLOCKING IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      JDSIGP=0
      JDSIMP=0
      JDSIQP=0
      JDSIZP=0
C
      IF (       IABS(IDSIGP) .GE.1) JDSIGP=1
      IF (       IABS(IDSIMP) .GE.1) JDSIMP=1
      IF (MAXVAL(IABS(IDSIQP)).GE.1) JDSIQP=1
      IF (MAXVAL(IABS(IDSIZP)).GE.1) JDSIZP=1
C
      IF (JDSIGP+JDSIMP+JDSIQP+JDSIZP.GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *             1X,20(1H/),'' PROTON  Q.P. OR S.P.  BLOCKING  IS  '',
     *                                                   1X,20(1H/),/,
     *             1X,20(1H/),'' ALLOWED FOR ONE SYMMETRY CASE ONLY  '',
     *                                                   1X,20(1H/),/,
     *             1X,20(1H/),'' IDSIGP = '',I2,'' IDSIMP = '',I2,
     *                                                  14X,20(1H/),/,
     *             1X,20(1H/),'' MAXVAL(IABS(IDSIQP)) = '',I2,
     *                                                  12X,20(1H/),/,
     *             1X,20(1H/),'' MAXVAL(IABS(IDSIZP)) = '',I2,
     *                                                  12X,20(1H/),/)')
     *             IDSIGP,IDSIMP,MAXVAL(IABS(IDSIQP)),
     *                           MAXVAL(IABS(IDSIZP))
C
          ERRSTR=' MULTI-SYMMETRY PROTON QUASIPART. BLOCKING IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIGN).NE.1.AND.
     *    IABS(IDSIMN).NE.1.AND.
     *    MAXVAL(IABS(IDSIQN)).NE.1.AND.
     *    MAXVAL(IABS(IDSIZN)).NE.1.AND.LIPNON.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *             1X,20(1H/),'' QUASIPARTICLE BLOCKING REQUIRED FOR '',
     *                                                   1X,20(1H/),/,
     *             1X,20(1H/),'' EXCLUDING NEUTRON ORBITAL FROM L-N  '',
     *                                                   1X,20(1H/),/)')
C
          ERRSTR=' USE QUASIPARTICLE BLOCKING FOR LIPNON=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIGP).NE.1.AND.
     *    IABS(IDSIMP).NE.1.AND.
     *    MAXVAL(IABS(IDSIQP)).NE.1.AND.
     *    MAXVAL(IABS(IDSIZP)).NE.1.AND.LIPNOP.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *             1X,20(1H/),'' QUASIPARTICLE BLOCKING REQUIRED FOR '',
     *                                                   1X,20(1H/),/,
     *             1X,20(1H/),'' EXCLUDING THE PROTON ORBITAL FROM LN'',
     *                                                   1X,20(1H/),/)')
C
          ERRSTR=' USE QUASIPARTICLE BLOCKING FOR LIPNOP=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((ITILAX.NE.0.OR.ITISAX.NE.0).AND.JPABCS.GT.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' TILTED-AXIS CRANKING CANNOT'',
     *                            '' BE USED '',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH BCS PAIRING  '',
     *                            ''         '',1X,20(1H/),/,
     *                 1X,20(1H/),'' (ITILAX='',I1,'', ITISAX='',I1,
     *                            '')        '',9X,20(1H/),/)')
     *
     *    ITILAX,ITISAX
C
          ERRSTR=' TILTED AXIS INCONSISTENT WITH IPABCS>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAHFB.LT.1.AND.(IFEFIN.EQ.1.OR.IFEFIP.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' FIXED FERMI ENERGY CAN ONLY'',
     *                            '' BE  USED'',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH IPAHFB> 0   '',
     *                            ''          '',1X,20(1H/),/)')
C
          ERRSTR=' NO FIXED FERMI ENERGY ALLOWED FOR IPAHFB=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (JPABCS.EQ.2.AND.(IDEFIN.NE.1.OR.IDEFIP.NE.1)) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPABCS=2 REQUIRES BOTH'',
     *                            '' IDEFIN=1 AND  '',20(1H/),/,
     *                 1X,20(1H/),'' IDEFIP=1                '',
     *                            ''         '',4X,20(1H/),/)')
          ERRSTR='IPABCS/IDEFIN/IDEFIP INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
      END IF
C
C=======================================================================
C
      IF (IPAHFB.LT.1.AND.JPABCS.NE.2.AND.
     *   (IDEFIN.EQ.1.OR.IDEFIP.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' FIXED PAIRING GAPS CAN ONLY'',
     *                            '' BE  USED'',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH IPAHFB> 0 OR'',
     *                            '' IPABCS= 2'',1X,20(1H/),/)')
C
          ERRSTR=' FIXED GAPS AND IPAHFB<1 AND IPABCS<>2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IMFHFB.EQ.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' HFB MEAN FIELD CAN ONLY'',
     *                            '' BE REQUESTED'',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH IPAHFB> 0   '',
     *                            ''          '',1X,20(1H/),/)')
C
          ERRSTR=' HFB MEAN FIELD NOT ALLOWED FOR IPAHFB=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IMFHFB.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' HFB MEAN FIELD CAN ONLY'',
     *                            '' BE REQUESTED'',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH IPNMIX = 0  '',
     *                            '' FOR NOW  '',1X,20(1H/),/)')
C
          ERRSTR=' HFB MEAN FIELD NOT ALLOWED FOR IPNMIX=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IMFHFB.NE.0.AND.IPAHFB.EQ.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CANONICAL MEAN FIELD MUST'',
     *                            '' BE REQUESTED'',1X,20(1H/),/,
     *                 1X,20(1H/),'' IN CASE OF IPAHFB=2      '',
     *                            ''             '',1X,20(1H/),/)')
C
          ERRSTR=' HFB MEAN FIELD NOT ALLOWED FOR IPAHFB=2 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1.OR.
     *     IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQN)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQP)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIZN)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIZP)).EQ.1).AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING OF QUASIP. CAN ONLY'',
     *                            '' BE USED'',1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH IPAHFB> 0   '',
     *                            ''          '',1X,20(1H/),/)')
C
          ERRSTR=' BLOCKING OF Q.P. AND IPAHFB=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1.OR.
     *     IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQN)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQP)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIZN)).EQ.1.OR.
     *     MAXVAL(IABS(IDSIZP)).EQ.1).AND.
     *     IPRGCM.GE.1.AND.IPAHFB.GE.1.AND.ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING OF QUASIP. CAN ONLY'',
     *                            '' BE USED'', 1X,20(1H/),/,
     *                 1X,20(1H/),'' WITH PROJECTION FOR'',
     *                            '' ISIMPY=0        '',1X,20(1H/),/)')
C
          ERRSTR=' Q.P. BLOCKING, IPRGCM>0, AND ISIMPY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.2.OR.IABS(IDSIGP).EQ.2.OR.
     *     IABS(IDSIMN).EQ.2.OR.IABS(IDSIMP).EQ.2.OR.
     *     MAXVAL(IABS(IDSIQN)).EQ.2.OR.MAXVAL(IABS(IDSIQP)).EQ.2.OR.
     *     MAXVAL(IABS(IDSIZN)).EQ.2.OR.MAXVAL(IABS(IDSIZP)).EQ.2).AND.
     *     IPRGCM.GE.1.AND.IPAIRI.LT.1.AND.
     *    (ISIMPY.EQ.1               )) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING OF SING-P. CAN ONLY'',
     *                            '' BE USED'', 1X,20(1H/),/,
     *                 1X,20(1H/),'' WITH PROJECTION IF'',
     *                            '' ISIMPY=0, FOR NOW'',1X,20(1H/),/)')
C
          ERRSTR=' BLKING OF S.P. & IPRGCM>0 & ISIMPY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      THE TEST BELOW WAS REMOVED ON 05/11/2022 IN VERSION 3.15I,
C      BECAUSE IT APPEARS TO BE NOT NEEDED
C=======================================================================
C
C     IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1.OR.
C    *     IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
C    *     MAXVAL(IABS(IDSIQN)).GE.1.OR.
C    *     MAXVAL(IABS(IDSIQP)).GE.1.OR.
C    *     MAXVAL(IABS(IDSIZN)).GE.1.OR.
C    *     MAXVAL(IABS(IDSIZP)).GE.1).AND.
C    *    (LIPKIN.EQ.1.OR.LIPKIP.EQ.1)) THEN
C
C         WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),'' BLOCKING OF QUASIPAR. CANNOT'',
C    *                            '' BE USED'',    1X,20(1H/),/,
C    *                 1X,20(1H/),'' TOGETHER WITH THE LIPKIN'',
C    *                            '' METHOD, YET'',1X,20(1H/),/)')
C
C         ERRSTR=' BLOCKING OF Q.P. AND THE LIPKIN METHOD IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1.OR.
     *     IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQN)).GE.1.OR.
     *     MAXVAL(IABS(IDSIQP)).GE.1.OR.
     *     MAXVAL(IABS(IDSIZN)).GE.1.OR.
     *     MAXVAL(IABS(IDSIZP)).GE.1).AND.IPAHFB.GE.1.AND.
     *    (IRENMA.EQ.1.OR.IRENIN.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING OF Q.P./S.P. CANNOT'',
     *                            '' BE USED'',    1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH THE RENORM'',
     *                            '' MASS OR INE'',1X,20(1H/),/)')
C
          ERRSTR=' BLOCKING OF Q.P. AND RENORMAL. MASS/INER IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IABS(IDSIGN).EQ.1.OR.IABS(IDSIGP).EQ.1.OR.
     *     IABS(IDSIMN).EQ.1.OR.IABS(IDSIMP).EQ.1.OR.
     *     MAXVAL(IABS(IDSIQN)).GE.1.OR.
     &     MAXVAL(IABS(IDSIQP)).GE.1.OR.
     *     MAXVAL(IABS(IDSIZN)).GE.1.OR.
     *     MAXVAL(IABS(IDSIZP)).GE.1).AND.
     *     IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' BLOCKING OF Q.P./S.P. CANNOT'',
     *                            '' BE USED'',    1X,20(1H/),/,
     *                 1X,20(1H/),'' TOGETHER WITH PROT-NEUTR'',
     *                            '' MIXING YET '',1X,20(1H/),/)')
C
          ERRSTR=' BLOCKING OF Q.P. AND PROT-NEUTR MIXING IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIGN).EQ.1.AND.(INSIGN.LT.0.OR.INSIGN.GT.NDSTAT)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIGN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    INSIGN
C
          ERRSTR=' INCORRECT VALUE OF INSIGN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIGP).EQ.1.AND.(INSIGP.LT.0.OR.INSIGP.GT.NDSTAT)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIGP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    INSIGP
C
          ERRSTR=' INCORRECT VALUE OF INSIGP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIMN).EQ.1.AND.(INSIMN.LT.0.OR.INSIMN.GT.NDSTAT)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIMN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    INSIMN
C
          ERRSTR=' INCORRECT VALUE OF INSIMN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIMP).EQ.1.AND.(INSIMP.LT.0.OR.INSIMP.GT.NDSTAT)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIMP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    INSIMP
C
          ERRSTR=' INCORRECT VALUE OF INSIMP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIQN)).GE.1.AND.(MINVAL(INSIQN).LT.0.OR.
     *                                   MAXVAL(INSIQN).GT.NDSTAT)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIQN'',4X,
     *                            ''       '',1X,20(1H/),/)')
C
          ERRSTR=' INCORRECT VALUE OF INSIQN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIQP)).GE.1.AND.(MINVAL(INSIQP).LT.0.OR.
     *                                   MAXVAL(INSIQP).GT.NDSTAT)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIQP'',4X,
     *                            ''       '',1X,20(1H/),/)')
C
          ERRSTR=' INCORRECT VALUE OF INSIQP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MINVAL(IDSIQN).LT.0.AND.IPAIRI.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIQN'',
     *                            '' FOR HF'',5X,20(1H/),/)')
C
          ERRSTR=' INCORRECT VALUE OF INSIQN FOR HF IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MINVAL(IDSIQP).LT.0.AND.IPAIRI.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIQP'',
     *                            '' FOR HF'',5X,20(1H/),/)')
C
          ERRSTR=' INCORRECT VALUE OF INSIQP FOR HF IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIZN)).GE.1.AND.
     *   (MINVAL(INSIZN).LT.0.OR.MAXVAL(INSIZN).GT.NDSTAT)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIZN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    INSIZN
C
          ERRSTR=' INCORRECT VALUE OF INSIZN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIZP)).GE.1.AND.
     *   (MINVAL(INSIZP).LT.0.OR.MAXVAL(INSIZP).GT.NDSTAT)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF INSIZP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    INSIZP
C
          ERRSTR=' INCORRECT VALUE OF INSIZP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIZN)).GE.1) THEN
C
          NBBLOC=0
C
          DO NUBLOC=1,NDBLOC
C
             IF (IABS(IDSIZN(NUBLOC)).GE.1) THEN
C
                 NBBLOC=NBBLOC+1
C
                 DO MUBLOC=1,NUBLOC-1
C
                    IF (INSIZN(MUBLOC).EQ.INSIZN(NUBLOC)) THEN
C
                        WRITE(NFIPRI,'(/,
     *                  1X,20(1H/),'' S.P  OR Q.P.  BLKD TWICE,'',
     *                             '' INSIZN='',I3,1X,20(1H/),/)')
     *                  INSIZN(MUBLOC)
C
                        ERRSTR=' DOUBLE VALUE OF INSIZN IN TESDAT'
                        CALL ERPUSH(ERRSTR,IERROR)
C
                    END IF
C
                 END DO
C
             END IF
C
          END DO
C
          IF (NBBLOC.GT.1.AND.MAXVAL(IABS(IDSIZN)).GE.2) THEN
C
              WRITE(NFIPRI,'(/,
     *        1X,20(1H/),'' MULTI S.P. BLOCKING'',
     *                   '' FOR IDZIZN NOT  '',1X,20(1H/),/,
     *        1X,20(1H/),'' YET IMPLEMENTED IN '',
     *                   '' CONSIZ          '',1X,20(1H/),/)')
C
              ERRSTR=' NO MULTI S.P. BLOCKING FOR IDZIZN IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIZP)).GE.1) THEN
C
          NBBLOC=0
C
          DO NUBLOC=1,NDBLOC
C
             IF (IABS(IDSIZP(NUBLOC)).GE.1) THEN
C
                 NBBLOC=NBBLOC+1
C
                 DO MUBLOC=1,NUBLOC-1
C
                    IF (INSIZP(MUBLOC).EQ.INSIZP(NUBLOC)) THEN
C
                        WRITE(NFIPRI,'(/,
     *                  1X,20(1H/),'' S.P  OR Q.P.  BLKD TWICE,'',
     *                             '' INSIZP='',I3,1X,20(1H/),/)')
     *                  INSIZP(MUBLOC)
C
                        ERRSTR=' DOUBLE VALUE OF INSIZP IN TESDAT'
                        CALL ERPUSH(ERRSTR,IERROR)
C
                    END IF
C
                 END DO
C
             END IF
C
          END DO
C
          IF (NBBLOC.GT.1.AND.MAXVAL(IABS(IDSIZP)).GE.2) THEN
C
              WRITE(NFIPRI,'(/,
     *        1X,20(1H/),'' MULTI S.P. BLOCKING'',
     *                   '' FOR IDZIZP NOT  '',1X,20(1H/),/,
     *        1X,20(1H/),'' YET IMPLEMENTED IN '',
     *                   '' CONSIZ          '',1X,20(1H/),/)')
C
              ERRSTR=' NO MULTI S.P. BLOCKING FOR IDZIZP IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIQN)).GE.1) THEN
C
          NBBLOC=0
C
          DO NUBLOC=1,NDBLOC
C
             IF (IABS(IDSIQN(NUBLOC)).GE.1) THEN
C
                 NBBLOC=NBBLOC+1
C
                 DO MUBLOC=1,NUBLOC-1
C
                    IF (INSIQN(MUBLOC).EQ.INSIQN(NUBLOC).AND.
     *                  IPSIQN(MUBLOC).EQ.IPSIQN(NUBLOC)) THEN
C
                        WRITE(NFIPRI,'(/,
     *                  1X,20(1H/),'' S.P  OR Q.P.  BLKD TWICE,'',
     *                             '' INSIQN='',I3,1X,20(1H/),/,
     *                  1X,20(1H/),''                          '',
     *                             '' IPSIQN='',I3,1X,20(1H/),/)')
     *
     *                  INSIQN(MUBLOC),IPSIQN(MUBLOC)
C
                        ERRSTR='DOUBLD VALUE OF INSIQN/IPSIQN IN TESDAT'
                        CALL ERPUSH(ERRSTR,IERROR)
C
                    END IF
C
                 END DO
C
             END IF
C
          END DO
C
          IF (NBBLOC.GT.1) THEN
C
              WRITE(NFIPRI,'(/,
     *        1X,20(1H/),'' MULTI-S.P/Q.P. BLOCKING FOR NEUTRONS'',
     *                                                     1X,20(1H/),/,
     *        1X,20(1H/),'' WITH CONSERVED PARITY NOT READY  YET'',
     *                                                     1X,20(1H/))')
C
          ERRSTR='NEUT MULTI S.P/Q.P. BLOC&PRTY NOT READY YET IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIQP)).GE.1) THEN
C
          NBBLOC=0
C
          DO NUBLOC=1,NDBLOC
C
             IF (IABS(IDSIQP(NUBLOC)).GE.1) THEN
C
                 NBBLOC=NBBLOC+1
C
                 DO MUBLOC=1,NUBLOC-1
C
                    IF (INSIQP(MUBLOC).EQ.INSIQP(NUBLOC).AND.
     *                  IPSIQP(MUBLOC).EQ.IPSIQP(NUBLOC)) THEN
C
                        WRITE(NFIPRI,'(/,
     *                  1X,20(1H/),'' S.P  OR Q.P.  BLKD TWICE,'',
     *                             '' INSIQP='',I3,1X,20(1H/),/,
     *                  1X,20(1H/),''                          '',
     *                             '' IPSIQP='',I3,1X,20(1H/),/)')
     *
     *                  INSIQP(MUBLOC),IPSIQP(MUBLOC)
C
                        ERRSTR='DOUBLD VALUE OF INSIQP/IPSIQP IN TESDAT'
                        CALL ERPUSH(ERRSTR,IERROR)
C
                    END IF
C
                 END DO
C
             END IF
C
          END DO
C
          IF (NBBLOC.GT.1) THEN
C
              WRITE(NFIPRI,'(/,
     *        1X,20(1H/),'' MULTI-S.P/Q.P. BLOCKING FOR  PROTONS'',
     *                                                     1X,20(1H/),/,
     *        1X,20(1H/),'' WITH CONSERVED PARITY NOT READY  YET'',
     *                                                     1X,20(1H/))')
C
          ERRSTR='PROT MULTI S.P/Q.P. BLOC&PRTY NOT READY YET IN TESDAT'
              CALL ERPUSH(ERRSTR,IERROR)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIQN)).GE.2) THEN
C
          DO NUBLOC=1,NDBLOC
C
             IF (IDSIQN(NUBLOC).EQ.2) THEN
C
                 DO MUBLOC=1,NUBLOC-1
C
                    IF (IDSIQN(MUBLOC).NE.0.AND.
     *                  IDSIQN(MUBLOC).NE.IDSIQN(NUBLOC)) THEN
C
                        WRITE(NFIPRI,'(/,
     *                  1X,20(1H/),'' MIXED S.P AND Q.P BLOCK.,'',
     *                             '' IDSIQN1='',I2,1X,20(1H/),/,
     *                  1X,20(1H/),''                          '',
     *                             '' IDSIQN2='',I2,1X,20(1H/),/)')
     *
     *                  IDSIQN(MUBLOC),IDSIQN(NUBLOC)
C
                        ERRSTR=' MIXED NEUT S.P AND Q.P BLOCK IN TESDAT'
                        CALL ERPUSH(ERRSTR,IERROR)
C
                    END IF
C
                 END DO
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIQP)).GE.2) THEN
C
          DO NUBLOC=1,NDBLOC
C
             IF (IDSIQP(NUBLOC).EQ.2) THEN
C
                 DO MUBLOC=1,NUBLOC-1
C
                    IF (IDSIQP(MUBLOC).NE.0.AND.
     *                  IDSIQP(MUBLOC).NE.IDSIQP(NUBLOC)) THEN
C
                        WRITE(NFIPRI,'(/,
     *                  1X,20(1H/),'' MIXED S.P AND Q.P BLOCK.,'',
     *                             '' IDSIQP1='',I2,1X,20(1H/),/,
     *                  1X,20(1H/),''                          '',
     *                             '' IDSIQP2='',I2,1X,20(1H/),/)')
     *
     *                  IDSIQP(MUBLOC),IDSIQP(NUBLOC)
C
                        ERRSTR=' MIXED PROT S.P AND Q.P BLOCK IN TESDAT'
                        CALL ERPUSH(ERRSTR,IERROR)
C
                    END IF
C
                 END DO
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIZN)).GE.2) THEN
C
          DO NUBLOC=1,NDBLOC
C
             IF (IDSIZN(NUBLOC).EQ.2) THEN
C
                 DO MUBLOC=1,NUBLOC-1
C
                    IF (IDSIZN(MUBLOC).NE.0.AND.
     *                  IDSIZN(MUBLOC).NE.IDSIZN(NUBLOC)) THEN
C
                        WRITE(NFIPRI,'(/,
     *                  1X,20(1H/),'' MIXED S.P AND Q.P BLOCK.,'',
     *                             '' IDSIZN1='',I2,1X,20(1H/),/,
     *                  1X,20(1H/),''                          '',
     *                             '' IDSIZN2='',I2,1X,20(1H/),/)')
     *
     *                  IDSIZN(MUBLOC),IDSIZN(NUBLOC)
C
                        ERRSTR=' MIXED NEUT S.P AND Q.P BLOCK IN TESDAT'
                        CALL ERPUSH(ERRSTR,IERROR)
C
                    END IF
C
                 END DO
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIZP)).GE.2) THEN
C
          DO NUBLOC=1,NDBLOC
C
             IF (IDSIZP(NUBLOC).EQ.2) THEN
C
                 DO MUBLOC=1,NUBLOC-1
C
                    IF (IDSIZP(MUBLOC).NE.0.AND.
     *                  IDSIZP(MUBLOC).NE.IDSIZP(NUBLOC)) THEN
C
                        WRITE(NFIPRI,'(/,
     *                  1X,20(1H/),'' MIXED S.P AND Q.P BLOCK.,'',
     *                             '' IDSIZP1='',I2,1X,20(1H/),/,
     *                  1X,20(1H/),''                          '',
     *                             '' IDSIZP2='',I2,1X,20(1H/),/)')
     *
     *                  IDSIZP(MUBLOC),IDSIZP(NUBLOC)
C
                        ERRSTR=' MIXED PROT S.P AND Q.P BLOCK IN TESDAT'
                        CALL ERPUSH(ERRSTR,IERROR)
C
                    END IF
C
                 END DO
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIGN).EQ.1.AND.IPSIGN.NE.0.AND.IPSIGN.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IPSIGN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IPSIGN
C
          ERRSTR=' INCORRECT VALUE OF IPSIGN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIGP).EQ.1.AND.IPSIGP.NE.0.AND.IPSIGP.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IPSIGP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IPSIGP
C
          ERRSTR=' INCORRECT VALUE OF IPSIGP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIGN).EQ.1.AND.ISSIGN.NE.0.AND.ISSIGN.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ISSIGN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    ISSIGN
C
          ERRSTR=' INCORRECT VALUE OF ISSIGN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIGP).EQ.1.AND.ISSIGP.NE.0.AND.ISSIGP.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF ISSIGP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    ISSIGP
C
          ERRSTR=' INCORRECT VALUE OF ISSIGP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIMN).EQ.1.AND.IRSIMN.NE.0.AND.IRSIMN.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IRSIMN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IRSIMN
C
          ERRSTR=' INCORRECT VALUE OF IRSIMN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(IDSIMP).EQ.1.AND.IRSIMP.NE.0.AND.IRSIMP.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IRSIMP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    IRSIMP
C
          ERRSTR=' INCORRECT VALUE OF IRSIMP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIQN)).GE.1.AND.MINVAL(IPSIQN).LT.0.AND.
     *                                  MAXVAL(IPSIQN).GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IPSIQN'',4X,
     *                            ''       '',1X,20(1H/),/)')
C
          ERRSTR=' INCORRECT VALUE OF IPSIQN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIQP)).GE.1.AND.MINVAL(IPSIQP).LT.0.AND.
     *                                  MAXVAL(IPSIQP).GT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF IPSIQP'',4X,
     *                            ''       '',1X,20(1H/),/)')
C
          ERRSTR=' INCORRECT VALUE OF IPSIQP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(NLSIGN).GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NLSIGN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NLSIGN
C
          ERRSTR=' INCORRECT VALUE OF NLSIGN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NLSIGN.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NLSIGN<>0 NOT IMPLEMENTED'',
     *                            '' YET       '',1X,20(1H/),/)')
C
          ERRSTR=' NLSIGN<>0 NOT IMPLEMENTED YET'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(NLSIMN).GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NLSIMN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NLSIMN
C
          ERRSTR=' INCORRECT VALUE OF NLSIMN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NLSIMN.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NLSIMN<>0 NOT IMPLEMENTED'',
     *                            '' YET       '',1X,20(1H/),/)')
C
          ERRSTR=' NLSIMN<>0 NOT IMPLEMENTED YET'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(NLSIQN).GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NLSIQN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NLSIQN
C
          ERRSTR=' INCORRECT VALUE OF NLSIQN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(NLSIZN).GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NLSIZN='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NLSIZN
C
          ERRSTR=' INCORRECT VALUE OF NLSIZN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((NLSIGN.NE.0.OR.NLSIMN.NE.0.OR.NLSIQN.NE.0.OR.NLSIZN.NE.0)
     *     .AND.(MOD(MXALIN,2).NE.1.OR.MXALIN.LT.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NOT AN ODD VALUE OF MXALIN='',I3,
     *                            ''      '',1X,20(1H/),/)')
     *    MXALIN
C
          ERRSTR=' INCORRECT VALUE OF MXALIN IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(NLSIGP).GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NLSIGP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NLSIGP
C
          ERRSTR=' INCORRECT VALUE OF NLSIGP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(NLSIMP).GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NLSIMP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NLSIMP
C
          ERRSTR=' INCORRECT VALUE OF NLSIMP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(NLSIQP).GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NLSIQP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NLSIQP
C
          ERRSTR=' INCORRECT VALUE OF NLSIQP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IABS(NLSIZP).GT.3) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INCORRECT VALUE OF NLSIZP='',I3,
     *                            ''       '',1X,20(1H/),/)')
     *    NLSIZP
C
          ERRSTR=' INCORRECT VALUE OF NLSIZP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((NLSIGP.NE.0.OR.NLSIMP.NE.0.OR.NLSIQP.NE.0.OR.NLSIZP.NE.0)
     *     .AND.(MOD(MXALIP,2).NE.1.OR.MXALIP.LT.0)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' NOT AN ODD VALUE OF MXALIP='',I3,
     *                            ''      '',1X,20(1H/),/)')
     *    MXALIP
C
          ERRSTR=' INCORRECT VALUE OF MXALIP IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPAIRI.NE.1) THEN
C
          IF (NLSIGN.NE.0.OR.NLSIGP.NE.0) THEN
C
              IF (ISIMPY.NE.1.OR.ISIQTY.NE.1) THEN
C
                  WRITE(NFIPRI,'(/,
     *         1X,20(1H/),'' VALUES OF NLSIGN(P) = '',I2,''('',I2,'')'',
     *                    '' ARE NOT'',1X,20(1H/),/,
     *         1X,20(1H/),'' COMPATIBLE WITH ISIMPY<>1//ISIQTY<>1'',
     *                                 1X,20(1H/),/)')
     *                NLSIGN,NLSIGP
C
                      ERRSTR=' INCORR. VALUE OF NLSIGN/NLSIGP IN TESDAT'
                      CALL ERPUSH(ERRSTR,IERROR)
C
              END IF
C
          END IF
C
          IF (NLSIMN.NE.0.OR.NLSIMP.NE.0) THEN
C
              IF (ISIMPY.NE.1.OR.ISIQTY.EQ.1) THEN
C
                  WRITE(NFIPRI,'(/,
     *         1X,20(1H/),'' VALUES OF NLSIMN(P) = '',I2,''('',I2,'')'',
     *                    '' ARE NOT'',1X,20(1H/),/,
     *         1X,20(1H/),'' COMPATIBLE WITH ISIMPY<>1//ISIQTY= 1'',
     *                                 1X,20(1H/),/)')
     *                NLSIMN,NLSIMP
C
                      ERRSTR=' INCORR. VALUE OF NLSIMN/NLSIMP IN TESDAT'
                      CALL ERPUSH(ERRSTR,IERROR)
C
              END IF
C
          END IF
C
          IF (NLSIQN.NE.0.OR.NLSIQP.NE.0) THEN
C
              IF (ISIMPY.EQ.1.OR.ISIQTY.NE.1) THEN
C
                  WRITE(NFIPRI,'(/,
     *         1X,20(1H/),'' VALUES OF NLSIQN(P) = '',I2,''('',I2,'')'',
     *                    '' ARE NOT'',1X,20(1H/),/,
     *         1X,20(1H/),'' COMPATIBLE WITH ISIMPY= 1//ISIQTY<>1'',
     *                                 1X,20(1H/),/)')
     *                NLSIQN,NLSIQP
C
                      ERRSTR=' INCORR. VALUE OF NLSIQN/NLSIQP IN TESDAT'
                      CALL ERPUSH(ERRSTR,IERROR)
C
              END IF
C
          END IF
C
          IF (NLSIZN.NE.0.OR.NLSIZP.NE.0) THEN
C
              IF (ISIMPY.EQ.1.OR.ISIQTY.EQ.1) THEN
C
                  WRITE(NFIPRI,'(/,
     *         1X,20(1H/),'' VALUES OF NLSIZN(P) = '',I2,''('',I2,'')'',
     *                    '' ARE NOT'',1X,20(1H/),/,
     *         1X,20(1H/),'' COMPATIBLE WITH ISIMPY= 1//ISIQTY= 1'',
     *                                 1X,20(1H/),/)')
     *                NLSIZN,NLSIZP
C
                      ERRSTR=' INCORR. VALUE OF NLSIZN/NLSIZP IN TESDAT'
                      CALL ERPUSH(ERRSTR,IERROR)
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF ((IFLAGI(1).NE.0.OR.IFLAGI(3).NE.0).AND.ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' QUADRATIC X- OR Z-CONSTRAINT'',
     *                            '' CANNOT '',1X,20(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH ISIMPY=1'',
     *                            ''     '',2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFLAGI(1)='',I1,
     *                            '', IFLAGI(3)='',I1,
     *                            '')        '',3X,20(1H/),/)')
     *
     *    IFLAGI(1),IFLAGI(3)
C
          ERRSTR='X- OR Z-CONSTRAINT AND ISIMPY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFTAGI(1).NE.0.OR.IFTAGI(3).NE.0).AND.ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' QUADRATIC ISVEC X- OR Z-CONS'',
     *                            '' CANNOT '',1X,20(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH ISIMPY=1'',
     *                            ''     '',2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFTAGI(1)='',I1,
     *                            '', IFTAGI(3)='',I1,
     *                            '')        '',3X,20(1H/),/)')
     *
     *    IFTAGI(1),IFTAGI(3)
C
          ERRSTR='ISOVECTOR X- OR Z-CONSTRAINT AND ISIMPY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFLAGA.NE.0.AND.ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CONSTRAINT ON OMEGA TIMES SPIN'',
     *                            '' CANNOT'',1X,19(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH ISIMPY=1'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='CONSTRAINT ON OMEGA x SPIN VS. ISIMPY=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFLAGI(1).NE.0.OR.IFLAGI(2).NE.0.OR.IFLAGI(3).NE.0).AND.
     *     IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' QUADRATIC CONSTRAINT ON SPIN'',
     *                            '' CANNOT '', 1X,20(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IROTAT=0'',
     *                            ''     '',    2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFLAGI(1)='',I1,
     *                            '', IFLAGI(2)='',I1,
     *                            '')        '',3X,20(1H/),/,
     *                 1X,20(1H/),''  IFLAGI(3)='',I1,
     *                            '')           '',1X,
     *                            ''         '',3X,20(1H/),/)')
     *
     *    IFLAGI(1),IFLAGI(2),IFLAGI(3)
C
          ERRSTR='CONSTRAINT ON SPIN AND IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFTAGI(1).NE.0.OR.IFTAGI(2).NE.0.OR.IFTAGI(3).NE.0).AND.
     *     IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' QUADRATIC ISVEC CONS ON SPIN'',
     *                            '' CANNOT '', 1X,20(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IROTAT=0'',
     *                            ''     '',    2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFTAGI(1)='',I1,
     *                            '', IFTAGI(2)='',I1,
     *                            '')        '',3X,20(1H/),/,
     *                 1X,20(1H/),''  IFTAGI(3)='',I1,
     *                            '')           '',1X,
     *                            ''         '',3X,20(1H/),/)')
     *
     *    IFTAGI(1),IFTAGI(2),IFTAGI(3)
C
          ERRSTR='ISOVECTOR CONSTRAINT ON SPIN AND IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFLAGT(1).NE.0.OR.IFLAGT(2).NE.0.OR.IFLAGT(3).NE.0).AND.
     *     IPNMIX.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' QUADR. CONSTRAINT ON ISOSPIN'',
     *                            '' CANNOT '', 1X,20(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IPNMIX=0'',
     *                            ''     '',    2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFLAGT(1)='',I1,
     *                            '', IFLAGT(2)='',I1,
     *                            '')        '',3X,20(1H/),/,
     *                 1X,20(1H/),''  IFLAGT(3)='',I1,
     *                            '')           '',1X,
     *                            ''         '',3X,20(1H/),/)')
     *
     *    IFLAGT(1),IFLAGT(2),IFLAGT(3)
C
          ERRSTR='CONSTRAINT ON ISOSPIN AND IPNMIX=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFLAGI(1).NE.0.OR.IFLAGI(2).NE.0.OR.IFLAGI(3).NE.0).AND.
     *     IFLAGA.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' QUADRATIC CONSTRAINT ON SPIN'',
     *                            '' CANNOT '', 1X,20(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IFLAGA=1'',
     *                            ''     '',    2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFLAGI(1)='',I1,
     *                            '', IFLAGI(2)='',I1,
     *                            '')        '',3X,20(1H/),/,
     *                 1X,20(1H/),''  IFLAGI(3)='',I1,
     *                            '')           '',1X,
     *                            ''         '',3X,20(1H/),/)')
     *
     *    IFLAGI(1),IFLAGI(2),IFLAGI(3)
C
          ERRSTR='CONSTRAINT ON SPIN AND IFLAGA=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFTAGI(1).NE.0.OR.IFTAGI(2).NE.0.OR.IFTAGI(3).NE.0).AND.
     *     IFLAGA.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' QUADRATIC ISVEC CONS ON SPIN'',
     *                            '' CANNOT '', 1X,20(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IFLAGA=1'',
     *                            ''     '',    2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFTAGI(1)='',I1,
     *                            '', IFTAGI(2)='',I1,
     *                            '')        '',3X,20(1H/),/,
     *                 1X,20(1H/),''  IFTAGI(3)='',I1,
     *                            '')           '',1X,
     *                            ''         '',3X,20(1H/),/)')
     *
     *    IFTAGI(1),IFTAGI(2),IFTAGI(3)
C
          ERRSTR='ISOVECTOR CONSTRAINT ON SPIN AND IFLAGA=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFLALI(1).NE.0.OR.IFLALI(2).NE.0.OR.IFLALI(3).NE.0).AND.
     *     IMOVAX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' AUGMENTED CONSTRAINT ON SPIN'',
     *                            '' CANNOT '', 1X,20(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IMOVAX=1'',
     *                            ''     '',    2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFLALI(1)='',I1,
     *                            '', IFLALI(2)='',I1,
     *                            '')        '',3X,20(1H/),/,
     *                 1X,20(1H/),''  IFLALI(3)='',I1,
     *                            '')           '',1X,
     *                            ''         '',3X,20(1H/),/)')
     *
     *    IFLALI(1),IFLALI(2),IFLALI(3)
C
          ERRSTR='AUG. CONS. ON SPIN AND IMOVAX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFLAGA.NE.0.AND.IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CONSTRAINT ON OMEGA TIMES SPIN'',
     *                            '' CANNOT'',1X,19(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IROTAT=0'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='CONSTRAINT ON OMEGA x SPIN VS. IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NO_ORB.EQ.1.AND.IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CONSTRAINT ON INTRINSIC SPIN'',
     *                            '' ONLY  IS'',1X,19(1H/),/,
     *                 1X,20(1H/),'' NOT COMPATIBLE  WITH  IROTAT=0'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='CONSTRAINT ON INTRINSIC SPIN VS. IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFLAGA.NE.0.AND.ITILAX.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CONSTRAINT ON OMEGA TIMES SPIN'',
     *                            '' CANNOT'',1X,19(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH ITILAX=0'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='CONSTRAINT ON OMEGA x SPIN VS. ITILAX=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFLAGA.NE.0.AND.ITISAX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CONSTRAINT ON OMEGA TIMES SPIN'',
     *                            '' CANNOT'',1X,19(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH ITISAX=1'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='CONSTRAINT ON OMEGA x SPIN VS. ITISAX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFLAGA.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CONSTRAINT ON NON-ZERO'',
     *                            '' PRODUCT'',    10X,17(1H/),/,
     *                 1X,20(1H/),'' OMEGA TIMES SPIN IS NOT YET'',
     *                            '' IMPLEMENTED'',1X,17(1H/),/)')
C
          ERRSTR='IFLAGA.NE.0 AND ABS(ASKEDA)>0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      OMEGAT=OMEGAX**2+OMEGAY**2+OMEGAZ**2
C
      IF (IFLAGA.NE.0.AND.OMEGAT.LT.1.0D-20) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CONSTRAINT ON NON-ZERO'',
     *                            '' PRODUCT'',      10X,17(1H/),/,
     *                 1X,20(1H/),'' OMEGA TIMES SPIN  CANNOT  BE '',
     *                            '' USED  FOR'',     1X,17(1H/),/,
     *                 1X,20(1H/),'' VANISHING OMEGA         '',
     *                            ''               '',1X,17(1H/),/)')
C
          ERRSTR='IFLAGA.NE.0 AND OMEGAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C         RESTRICTION BELOW HAS BEEN REMOVED IN 2.07D ON 04/01/04 WITH
C         THE ASSMPTION THAT THE CODE AS IS WILL FUNCTION PROPERLY.
C=======================================================================
C
C     IF (IFLAGA.NE.0.AND.
C    *   (ISIMTX.EQ.1.OR.JSIMTY.EQ.1.OR.ISIMTZ.EQ.1)) THEN
C
C         WRITE(NFIPRI,'(/,1X,20(1H/),'' WARNING: CONSTRAINT ON NON'',
C    *                                ''-ZERO PRODUCT'',1X,17(1H/),/,
C    *                     1X,20(1H/),'' OMEGA TIMES SPIN IS NOT'',
C    *                                '' COMPATIBLE WITH'',1X,17(1H/),/,
C    *                     1X,20(1H/),'' ISIMTX=1 OR ISIMTY=1, OR'',
C    *                                '' ISIMTZ=1,  AND'', 1X,17(1H/),/,
C    *                     1X,20(1H/),'' HAS BEEN REMOVED.       '',
C    *                            ''               '', 1X,17(1H/),/)')
C
C         IFLAGA=0
C
C     END IF
C
C=======================================================================
C
      IF (IMOVAX.NE.0.AND.IMOVAX.NE.1.AND.IMOVAX.NE.-1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),1X,
     *                   ''IMOVAX='',I3,''             '',
     *                                                   1X,20(1H/),/,
     *                     1X,20(1H/),1X,''IS NOT AN ALLOWED VALUE'',
     *                                                   1X,20(1H/),/)')
     *    IMOVAX
C
          ERRSTR='VALUE OF IMOVAX NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IMOVAX.NE.0.AND.ITILAX.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ADJUSTABLE DIRECTION OF OMEGA '',
     *                            '' CANNOT'',1X,19(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH ITILAX=0'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='ADJUSTABLE DIRECTION OF OMEGA VS. ITILAX=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IMOVAX.NE.0.AND.ITISAX.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ADJUSTABLE DIRECTION OF OMEGA '',
     *                            '' CANNOT'',1X,19(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH ITISAX=1'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='ADJUSTABLE DIRECTION OF OMEGA VS. ITISAX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IMOVAX.NE.0.AND.IFLAGA.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ADJUSTABLE DIRECTION OF OMEGA '',
     *                            '' CANNOT'',1X,19(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IFLAGA=1'',
     *                            ''       '',1X,19(1H/),/)')
C
          ERRSTR='ADJUSTABLE DIRECTION OF OMEGA VS. IFLAGA=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IOCONT.EQ.1.AND.IMOVAX.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IOCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' IMOVAX=0'',1X,19(1H/),/)')
C
          ERRSTR='IOCONT=1 VS. IMOVAX=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFLALI(1).EQ.0.AND.IFLALI(2).EQ.0.AND.IFLALI(3).EQ.0).AND.
     *    ISCONT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' IFLALI(K)=0'',1X,19(1H/),/)')
C
          ERRSTR='ISCONT=1 VS. IFLALI(K)=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF ((IFLALT(1).EQ.0.AND.IFLALT(2).EQ.0.AND.IFLALT(3).EQ.0).AND.
     *    ITCONT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' IFLALT(K)=0'',1X,19(1H/),/)')
C
          ERRSTR='ITCONT=1 VS. IFLALT(K)=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFLAGT(2).EQ.1.AND.IROTAT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' QUADRATIC CONSTRAINT ON ISOSPIN'',
     *                            '' TY CANNOT '', 1X,15(1H/),/,
     *                 1X,20(1H/),'' BE USED TOGETHER WITH IROTAT=0'',
     *                            ''     '',    2X,20(1H/),/,
     *                 1X,20(1H/),'' (IFLAGT(1)='',I1,
     *                            '', IFLAGT(2)='',I1,
     *                            '')        '',3X,20(1H/),/,
     *                 1X,20(1H/),''  IFLAGT(3)='',I1,
     *                            '')           '',1X,
     *                            ''         '',3X,20(1H/),/)')
     *
     *    IFLAGT(1),IFLAGT(2),IFLAGT(3)
C
          ERRSTR='CONSTRAINT ON ISOSPIN TY AND IROTAT=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IPCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IPCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IYCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IYCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IYCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IGCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IGPCON.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IGPCON=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IGPCON=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IECONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IECONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IECONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ILCONT.GE.1.AND.IPCONT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ILCONT>0 IS INCOMPATIBLE WITH'',
     *                            '' IPCONT=0'',1X,19(1H/),/)')
C
          ERRSTR='ILCONT>0 VS. IPCONT=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IFCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IFCONT.EQ.1.AND.IYCONT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' WARNING: FOR IYCONT = 1 AND'',
     *                            '' IFCONT = 1'',1X,19(1H/),/,
     *                 1X,20(1H/),'' THE YUKAWA FILE WILL BE IGNORED'',
     *                            ''       '',1X,19(1H/),/)')
C
      END IF
C
C=======================================================================
C
      IF (IFCONT.EQ.1.AND.IGCONT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' WARNING: FOR IGCONT = 1 AND'',
     *                            '' IFCONT = 1'',1X,19(1H/),/,
     *                 1X,20(1H/),'' THE GOGNY  FILE WILL BE IGNORED'',
     *                            ''       '',1X,19(1H/),/)')
C
      END IF
C
C=======================================================================
C
      IF (IFCONT.EQ.1.AND.IGPCON.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' WARNING: FOR IGPCON = 1 AND'',
     *                            '' IFCONT = 1'',1X,19(1H/),/,
     *                 1X,20(1H/),'' THE GOGNY PAIRING FILE WILL BE'',
     *                            '' IGNORED'',1X,19(1H/),/)')
C
      END IF
C
C=======================================================================
C
      IF (IFCONT.EQ.1.AND.IECONT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' WARNING: FOR IECONT = 1 AND'',
     *                            '' IFCONT = 1'',1X,19(1H/),/,
     *                 1X,20(1H/),'' THE REGUL  FILE WILL BE IGNORED'',
     *                            ''       '',1X,19(1H/),/)')
C
      END IF
C
C=======================================================================
C
      IF (IFCONT.EQ.1.AND.ILCONT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' WARNING: FOR ILCONT = 1 AND'',
     *                            '' IFCONT = 1'',1X,19(1H/),/,
     *                 1X,20(1H/),'' THE LIPKIN FILE WILL BE IGNORED'',
     *                            ''       '',1X,19(1H/),/)')
C
      END IF
C
C=======================================================================
C
      IF (IMCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IMCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IMCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IMCONT.EQ.1.AND.IFCONT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IMCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' IFCONT=0'',1X,19(1H/),/)')
C
          ERRSTR='IMCONT=1 VS. IFCONT=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IACONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IACONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IACONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IOCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IOCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IOCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ISCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='ISCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ITCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='ITCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IRCONT.EQ.1.AND.ICONTI.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IRCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' ICONTI=0'',1X,19(1H/),/)')
C
          ERRSTR='IRCONT=1 VS. ICONTI=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IRCONT.EQ.1.AND.IFCONT.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IRCONT=1 IS INCOMPATIBLE WITH'',
     *                            '' IFCONT=0'',1X,19(1H/),/)')
C
          ERRSTR='IRCONT=1 VS. IFCONT=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C     THE RESTRICTION BELOW WAS NOT REALLY NECESSARY AND HAS BEEN
C     REMOVED ON 07/01/2020 IN VERSION (2.92G).
C=======================================================================
C
C     IF ((ICOUDI.EQ.2.OR.ICOUEX.EQ.2).AND.
C    *     ICONTI.EQ.1.AND.IFCONT.NE.1) THEN
C
C         WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),'' IFCONT=0 IS INCOMPATIBLE WITH'',
C    *                            '' ICONTI=1'',1X,19(1H/),/,
C    *                 1X,20(1H/),'' AND (ICOUDI=2 OR ICOUEX=2)   '',
C    *                            ''         '',1X,19(1H/),/)')
C
C         ERRSTR='IFCONT=0 VS. ICONTI=1 AND GAUSSIAN COULOMB IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C
      IF ((ICOUDI.EQ.2.OR.ICOUEX.EQ.2).AND.IBROYD.GE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IBROYD=1 IS INCOMPATIBLE WITH'',
     *                            '' ICOUDI=2'',1X,19(1H/),/,
     *                 1X,20(1H/),'' OR ICOUEX=2                  '',
     *                            ''         '',1X,19(1H/),/)')
C
          ERRSTR='IBROYD=1 AND GAUSSIAN COULOMB IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
C     IF (ICOULO.EQ.0.AND.ICONTI.EQ.0.AND.ICOUDI.EQ.1) THEN
C
C         WRITE(NFIPRI,'(/,
C    *                 1X,20(1H/),'' ICOULO=0 USED FOR ICONTI=0 &'',
C    *                            '' ICOUDI=1 '',1X,19(1H/),/,
C    *                 1X,20(1H/),'' RESULTS IN A SEGMENTATION FAULT'',
C    *                            '' FOR   '',1X,19(1H/),/,
C    *                 1X,20(1H/),'' UNKNOWN REASONS, SEE EXAMPLE'',
C    *                            '' IN THE   '',1X,19(1H/),/,
C    *                 1X,20(1H/),'' DIRECTORY BUG.191124         '',
C    *                            ''         '',1X,19(1H/),/)')
C
C         ERRSTR='ICOULO=0, ICONTI=0, ICOUDI=1 --> BUG.191124 IN TESDAT'
C         CALL ERPUSH(ERRSTR,IERROR)
C
C     END IF
C
C=======================================================================
C      Only two LAPACK routines have been parallelized. If the  user's
C      default choice does not match the available options, we default
C      to a divide-and-conquer algorithm.
C=======================================================================
#if(USE_SCALAPACK==1)
C
      KZHPEV=0
C
#if(SWITCH_DIAG==1)
      KZHPEV = 1
#endif
C
#if(SWITCH_DIAG==4)
      KZHPEV = 4
#endif
C
      IF (KZHPEV.NE.1.AND.KZHPEV.NE.4) THEN
C
          WRITE(NFIPRI,'(79(''/''),/,''///'',73X,''///'')')
          WRITE(NFIPRI,'(''///  KZHPEV = '',i1,'' IS NOT AUTHORIZED '',
     *         ''IN CURRENT IMPLEMENTATION OF SCALAPACK    ///'')')
     *                          KZHPEV
          WRITE(NFIPRI,'(''///  DEFAULTING TO KZPHEV=1 INSTEAD '',
     *         ''(DIVIDE-AND-CONQUER ALGORITHM)          ///'')')
          WRITE(NFIPRI,'(''///'',73X,''///'',/,79(''/''),/)')
C
          ERRSTR='INCORRECT VALUE OF KZHPEV IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
#endif
C
C=======================================================================
C      Compatibility check for the shell correction
C=======================================================================
C      IFSHEL>0 requires proton and neutron mean-fields in the q.p. basis
C
      IF (IFSHEL.GE.1.AND.IPAHFB.EQ.2) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFSHEL>0 IS INCOMPATIBLE WITH'',
     *                            '' IPAHFB=2'',1X,19(1H/),/)')
C
          ERRSTR='IFSHEL>0 AND IPAHFB=2 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      IFSHEL>0 is incompatible with proton/neutron mixing
C
      IF (IFSHEL.GE.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFSHEL>0 IS INCOMPATIBLE WITH'',
     *                            '' IPNMIX=1'',1X,19(1H/),/)')
C
          ERRSTR='IFSHEL>0 AND IPNMIX=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      IFSHEL=0,1,2 (no shell correction, traditional, extended)
C
      IF (IFSHEL.LT.0.OR.IFSHEL.GT.2) THEN
C
          WRITE(NFIPRI,'(/,1X,20(''/''),1X,''IFSHEL='',I3,
     *                      ''             '',1X,20(''/''),/,
     *               1X,20(''/''),1X,''IS NOT AN ALLOWED VALUE'',
     *               1X,20(''/''),/)') IFSHEL
C
          ERRSTR='VALUE OF IFSHEL NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Compatibility check for fission fragment calculations
C=======================================================================
C      Accepted values for IFRAGM are 0 or 1
C
      IF (IFRAGM.LT.0.OR.IFRAGM.GT.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(''/''),1X,''IFRAGM='',I3,
     *                      ''             '',1X,20(''/''),/,
     *               1X,20(''/''),1X,''IS NOT AN ALLOWED VALUE'',
     *               1X,20(''/''),/)') IFRAGM
C
          ERRSTR='VALUE OF IFRAGM NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      IFRAGM=1 is incompatible with proton/neutron mixing
C
      IF (IFRAGM.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFRAGM=1 IS INCOMPATIBLE WITH'',
     *                            '' IPNMIX=1'',1X,19(1H/),/)')
C
          ERRSTR='IFRAGM=1 AND IPNMIX=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      IFRAGM=1 requires conserved simplex (for the time being)
C
      IF (IFRAGM.EQ.1.AND.ISIMPY.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFRAGM=1 IS INCOMPATIBLE WITH'',
     *                            '' ISIMPY=0'',1X,19(1H/),/)')
C
          ERRSTR='IFRAGM=1 AND ISIMPY=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      IFRAGM=1 requires time-reversal invariance (for the time being)
C
      IF (IFRAGM.EQ.1.AND.IROTAT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IFRAGM=1 IS INCOMPATIBLE WITH'',
     *                            '' IROTAT=1'',1X,19(1H/),/)')
C
          ERRSTR='IFRAGM=1 AND IROTAT=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      IFRAGM=1 is only possible in (standard) HFB mode (for the time being)
C
      IF (IFRAGM.EQ.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,17(1H/),'' IFRAGM=1 IS INCOMPATIBLE WITH'',
     *                            '' VALUE OF IPAHFB'',16(1H/),/)')
C
          ERRSTR='IFRAGM=1 AND IPAHFB=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C      Compatibility check for rotation of q.p.
C=======================================================================
C      Accepted values for MIN_QP are 0 or 1
C
      IF (MIN_QP.LT.0.OR.MIN_QP.GT.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(''/''),1X,''MIN_QP='',I3,
     *                      ''             '',1X,20(''/''),/,
     *               1X,20(''/''),1X,''IS NOT AN ALLOWED VALUE'',
     *               1X,20(''/''),/)') MIN_QP
C
          ERRSTR='VALUE OF MIN_QP NOT ALLOWED IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      MIN_QP=1 is incompatible with proton/neutron mixing
C
      IF (MIN_QP.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' MIN_QP=1 IS INCOMPATIBLE WITH'',
     *                            '' IPNMIX=1'',1X,19(1H/),/)')
C
          ERRSTR='MIN_QP=1 AND IPNMIX=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      MIN_QP=1 requires conserved simplex (for the time being)
C
      IF (MIN_QP.EQ.1.AND.ISIMPY.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' MIN_QP=1 IS INCOMPATIBLE WITH'',
     *                            '' ISIMPY=0'',1X,19(1H/),/)')
C
          ERRSTR='MIN_QP=1 AND ISIMPY=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      MIN_QP=1 requires time-reversal invariance (for the time being)
C
      IF (MIN_QP.EQ.1.AND.IROTAT.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' MIN_QP=1 IS INCOMPATIBLE WITH'',
     *                            '' IROTAT=1'',1X,19(1H/),/)')
C
          ERRSTR='MIN_QP=1 AND IROTAT=1 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      MIN_QP=1 is only possible in (standard) HFB mode (for the time being)
C
      IF (MIN_QP.EQ.1.AND.IPAHFB.LT.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,17(1H/),'' MIN_QP=1 IS INCOMPATIBLE WITH'',
     *                            '' VALUE OF IPAHFB'',16(1H/),/)')
C
          ERRSTR='MIN_QP=1 AND IPAHFB=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      MIN_QP=1 requires fission fragment definition
C
      IF (MIN_QP.EQ.1.AND.IFRAGM.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,17(1H/),'' MIN_QP=1 IS INCOMPATIBLE WITH'',
     *                            '' VALUE OF IFRAGM'',16(1H/),/)')
C
          ERRSTR='MIN_QP=1 AND IFRAGM=0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C      MIN_QP=1 requires zero-temperature
C
      IF (MIN_QP.EQ.1.AND.IFTEMP.NE.0) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,17(1H/),'' MIN_QP=1 IS INCOMPATIBLE WITH'',
     *                            '' VALUE OF IFTEMP'',16(1H/),/)')
C
          ERRSTR='MIN_QP=1 AND IFTEMP>0 INCONSISTENCY IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (IVACUM.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE OPTION OF IVACUM=1  IS'',
     *                                '' NOT YET  '',1X,20(1H/),/,
     *                     1X,20(1H/),'' IMPLEMENTED FOR IPNMIX=1  '',
     *                                ''          '',1X,20(1H/),/)')
C
          ERRSTR=' IVACUM=1 NOT IMPLEMENTED FOR IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (ITWOBA.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE OPTION OF ITWOBA=1  IS'',
     *                                '' NOT YET  '',1X,20(1H/),/,
     *                     1X,20(1H/),'' IMPLEMENTED FOR IPNMIX=1  '',
     *                                ''          '',1X,20(1H/),/)')
C
          ERRSTR=' ITWOBA=1 NOT IMPLEMENTED FOR IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (NUQEVE.EQ.1.AND.ITWOBA.EQ.1.AND.ISIMPY.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE OPTION OF NUQEVE=1 FOR'',
     *                                '' ITWOBA=1 '',    1X,20(1H/),/,
     *                     1X,20(1H/),'' IMPLEMENTED ONLY FOR'',
     *                                '' ISIMPY=0       '',
     *                                                   1X,20(1H/),/)')
C
          ERRSTR=' NUQEVE=1/ITWOBA=1 ONLY FOR ISIMPY=0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (LIPKIN.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE OPTION OF LIPKIN=1  IS'',
     *                                '' NOT YET  '',1X,20(1H/),/,
     *                     1X,20(1H/),'' IMPLEMENTED FOR IPNMIX=1  '',
     *                                ''          '',1X,20(1H/),/)')
C
          ERRSTR=' LIPKIN=1 NOT IMPLEMENTED FOR IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
C
      IF (LIPKIP.EQ.1.AND.IPNMIX.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,1X,20(1H/),'' THE OPTION OF LIPKIP=1  IS'',
     *                                '' NOT YET  '',1X,20(1H/),/,
     *                     1X,20(1H/),'' IMPLEMENTED FOR IPNMIX=1  '',
     *                                ''          '',1X,20(1H/),/)')
C
          ERRSTR=' LIPKIP=1 NOT IMPLEMENTED FOR IPNMIX=1 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
C=======================================================================
CLP@+ tests (preliminary version), maybe sth should be added
C=======================================================================
C
      if (((imaspar.eq.1).or.(imominer.eq.1)).and.
     &        ((isimpy.ne.1).or.(irotat.ne.0))) then
        write(nfipri,*) "incompatiblity maspar/mominer vs isimpy/irotat"
        stop 'incompatiblity maspar/mominer vs isimpy/irotat'
      endif

      if ((imaspar.eq.1).and.(numcoor.eq.0))then
        write(nfipri,*) "incompatiblity maspar vs numcoor, 1 vs 0"
        stop 'incompatiblity maspar vs numcoor, 1 vs 0'
      endif

      if ((imaspar.eq.0).and.(numcoor.gt.0))then
        write(nfipri,*) "incompatiblity maspar vs numcoor, 0 vs gt 0"
        stop 'incompatiblity maspar vs numcoor, 0 vs gt 0'
      endif
C
C=======================================================================
C      Compatibility checks for HFBTHO solver
C=======================================================================
C      IF_THO=1 is not compatible with any restart option.
C
      IF (IF_THO.EQ.1.AND.(ICONTI.EQ.1.OR.IPCONT.EQ.1.OR.
     *                     ILCONT.GE.1.OR.IFCONT.EQ.1.OR.
     *                     IYCONT.EQ.1.OR.IGCONT.EQ.1.OR.
     *                     IGPCON.EQ.1.OR.IECONT.EQ.1.OR.
     *                     ISCONT.EQ.1.OR.ITCONT.EQ.1.OR.
     *                     IOCONT.EQ.1.OR.IMCONT.EQ.1)) THEN
C
          WRITE(NFIPRI,'(/,1X,9(''/''),59X,9(''/''),/,
     *                  1X,9(''/''),'' USING HFBTHO RESTART OPTION '',
     *                  ''IF_THO=1 IS INCOMPATIBLE WITH '',9(''/''),/,
     *                  1X,9(''/''),23X,''*ANY*'',31X,9(''/''),/,
     *                  1X,9(''/''), 7X,''CONTINUATION OPTION '',
     *                  ''AVAILABLE IN HFODD'',14X,9(''/''),/,
     *                  1X,9(''/''),59X,9(''/''))')
C
          ERRSTR='HFBTHO CONTINUATION AND RESTARTS IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
      IF (IF_THO.EQ.1.AND.MINVAL(IFLAGQ).LT.0) THEN
C
          WRITE(NFIPRI,'(/,1X,9(''/''),59X,9(''/''),/,
     *                  1X,9(''/''),'' USING HFBTHO IS INCOMPATIBLE '',
     *                  ''WITH ANY VALUE OF IFLAGQ < 0 '',9(''/''),/,
     *                  1X,9(''/''),59X,9(''/''))')
C
          ERRSTR='HFBTHO AND IFLAGQ < 0 IN TESDAT'
          CALL ERPUSH(ERRSTR,IERROR)
C
      END IF
C
cC      Sanity check: if UNEDF functionals are requested, the flag
cC      IF_EDF must be set to 1
cC
c      IF ((SKYRME.EQ.'UNE0'.OR.SKYRME.EQ.'UNE1'.OR.SKYRME.EQ.'UNE2')
c     *                    .AND.IF_EDF.EQ.0) THEN
cC
c          WRITE(NFIPRI,'(/,1X,9(''/''),59X,9(''/''),/,
c     *                  1X,9(''/''),'' ACRONYMS UNE0, UNE1, UNE2 '',
c     *                  ''USED TO ENFORCE STRICT '',9(''/''),/,
c     *                  1X,9(''/''),'' COMPLIANCE  WITH THE  UNEDF'',
c     *                  ''  PARAMETRIZATIONS OF THE '',9(''/''),/,
c     *                  1X,9(''/''),'' SKYRME  EDF BY FIXING THE '',
c     *                  ''PAIRING STRENGTHS TO THEIR '',9(''/''),/,
c     *                  1X,9(''/''),'' UNEDF VALUES.'',40X,9(''/''),/,
c     *                  1X,9(''/''),59X,9(''/''),/,
c     *                  1X,9(''/''),'' USE  UDF0,  UDF1 OR  UDF2 '',
c     *                  ''IF YOU NEED FLEXIBILITY TO '',9(''/''),/,
c     *                  1X,9(''/''),'' TUNE THE PAIRING STRENGTH '',
c     *                  ''WITH UNEDF FUNCTIONALS.    '',9(''/''),/,
c     *                  1X,9(''/''),59X,9(''/''))')
cC
c          ERRSTR='IF_EDF=0 AND UNEDF FUNCTIONALS IN TESDAT'
c          CALL ERPUSH(ERRSTR,IERROR)
cC
c      END IF
cC
C=======================================================================
C      Stopping the program if any inconsistency in the data has been
C      encountered.
C=======================================================================
C
      IF (IERROR.GE.1) CALL ERSTOP(IERROR)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ERSTOP(IERROR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      CHARACTER
     *          ERRALL*68
C
      COMMON
     *       /ERRDAT/ ERRALL(1:NDERRO)
C
      DO I_ERRO=1,IERROR
C
         WRITE (0,'(A68)') ERRALL(I_ERRO)
C
      END DO
C
      STOP ' INPUT DATA ERRORS IDENTIFIED IN TESDAT, PROGRAM STOPPED'
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ERPUSH(ERRSTR,IERROR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      CHARACTER
     *          ERRSTR*68,ERRALL*68
C
      COMMON
     *       /ERRDAT/ ERRALL(1:NDERRO)
C
      IF (IERROR.LT.0.OR.IERROR.GT.NDERRO)
     *    STOP ' IERROR<1 OR INCREASE NDERRO IN ERPUSH'
C
      IERROR=IERROR+1
C
      ERRALL(IERROR)=ERRSTR
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETBAS(IN_FIX,IZ_FIX,IREAWS,NOSCIL,NLIMIT,ENECUT,
     *                                IOPTGS,JETACM,ISPHER,INIROT,
     *                                IPRGCM,NUAKNO,ICOUDI,ICOUEX,
     *                                       E_EFFE,IF_THO,ITWCEN,
     *                                              NLIMTW,ENECTW)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *           EBASIS(NDBTOT,NDTWCE),NBASIS(NDBTOT,NDTWCE),
     *           TOTEBA(2*NDBTOT),NTOTBA(2*NDBTOT),
     *           EBASEX(NDTWCE), MCOUNV(1:NDTWCE),
     *           NXHERV(NDTWCE),NYHERV(NDTWCE),NZHERV(NDTWCE)
      CHARACTER
     *           DIGITS(0:99)*2
      CHARACTER
     *           OPTIMU(0:2)*33
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
     *
     *      /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *      /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *               LYOFZV(0:NDZMAX,1:NDTWCE),
     *               LZOFXV(0:NDXMAX,1:NDTWCE),
     *               LXOFZV(0:NDZMAX,1:NDTWCE),
     *               LYOFXV(0:NDXMAX,1:NDTWCE),
     *               LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *      /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *               LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *               LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *      /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                                NZMAXV(1:NDTWCE)
      COMMON
     *       /BELIMI/ ELIMIT(1:NDTWCE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /PARIND/ INDPAR(1:NDBASE,0:NDPARI)
      COMMON
     *       /PARBAS/ IBAPAR(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /ESHIFT/ EFEBAS(0:NDISOS)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
      COMMON
     *       /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME
      COMMON
     *       /CHARGE/ ECHAR2
      COMMON
     *       /EXCHAN/ COULEX
      COMMON
     *       /LDUNKI/ ECH2_O,COEX_O
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /CENPOS/ CENCOR(1:NDKART,1:NDTWCE)
C
      DATA
     *      OPTIMU /'                                 ',
     *              'OPTIMUM NUMBERS 2BD GAUSS POINTS:',
     *              'OPTIMUM NUMBERS 3BD GAUSS POINTS:'/
C
C=======================================================================
C         THIS SUBROUTINE DEFINES THE BASIS PARAMETERS AND THE BASIS
C         ITSELF  FOR  THE NUMERICAL INTEGRATION OF THE HAMILTONIAN.
C=======================================================================
C
C         MEANING OF SOME PARAMETERS:
C
C         LXOFYV = 'LAST INDEX IN THE DIRECTION X RELATED TO Y'
C                   MAXIMUM VALUE OF THE 'NX' OSCILLATOR BASIS
C                   FOR FIXED 'NY'
C
C         LXOFZV => ... LZOFYV  ===> SIMILAR TO LXOFYV BUT FOR
C                   ALL THE OTHER COMBINATIONS OF   DIRECTIONS
C
C         LXOYZV => SIMILAR TO THE PREVIOUS ONES BUT LIMITED BY
C                   TWO OTHER ACTUAL QUANTUM NUMBERS  F I X E D
C
C         EACH PARAMETER IS DEFINED IN GENERAL FOR T H E  T W O
C         CENTER BASIS (LAST INDEX)
C=======================================================================
C
C         NOSCIL = MAXIMUM NUMBER OF THE HARMONIC OSCILLATOR SHELLS
C
C         NDIMEN = ((NOSCIL+2)**3-(NOSCIL+2))/6
C                =  (NOSCIL+1)(NOSCIL+2)(NOSCIL+3)/6
C
C         NOSCIL= 7 - NDIMEN=120
C         NOSCIL= 8 - NDIMEN=165
C         NOSCIL= 9 - NDIMEN=220
C         NOSCIL=10 - NDIMEN=286
C         NOSCIL=11 - NDIMEN=364
C         NOSCIL=12 - NDIMEN=455
C         NOSCIL=14 - NDIMEN=680
C         NOSCIL=16 - NDIMEN=969
C         NOSCIL=18 - NDIMEN=1330
C         NOSCIL=20 - NDIMEN=1771
C
C=======================================================================
C
C         HBARO() - HBAR-OMEGA (X) OR (Y) OR (Z); OSCILLATOR FREQUENCIES
C
C         SQ()FAT - DERIVATIVE - STRETCHING FACTORS FOR (X), (Y), OR (Z)
C                   VARIABLES (USED TO DEFINE THE DIMENSIONED VARIABLES)
C
C                   SQ()FAT = SQRT( MASS * HBARO() / H_BAR**2 )
C
C                   KSI ()  = SQ()FAT * (VARIABLE)
C
C         N()MAXV - THE MAXIMUM VALUES OF THE HARMONIC OSCILLATOR SHELLS
C                   IN THE (X), OR (Y), OR (Z)  DIRECTION,  RESPECTIVELY
C                   AND IN BOTH CENTERS (TWO-CENTER BASIS OPTION)
C
C=======================================================================
C
C         NLIMIT  - B A S I S   D E F I N I T I O N  P A R A M E T E R :
C
C                   EITHER NEGATIVE (ENECUT  DEFINES THE ENERGY CUT),
C                   OR POSITIVE, IN WHICH CASE THE TOTAL NUMBER OF BASIS
C                   STATES WILL BE EQUAL TO NLIMIT, OR ZERO, IN WHICH
C                   CASE NLIMIT IS DETERMINED BY THE NUMBER OF SPHERICAL
C                   HO SHELLS NOSCIL.
C
C=======================================================================
C
      IF (JETACM.EQ.0) THEN
C
          HBMRPA=HBMASS*(1.0D0-1.0D0/(IZ_FIX+IN_FIX))
      ELSE
          HBMRPA=HBMASS
C
      END IF
C
      ECHAR2=H_BARC/HBCOE2
C
      PI    =4.0D0*ATAN(1.0D0)
C
      IF (ICOUDI.EQ.0.AND.ICOUEX.EQ.0) ECHAR2=0.0D0
C
      IF (ICOUEX.EQ.1) THEN
C
          COULEX=-(3.0D0/4.0D0) * (3.0D0/PI)**(1.0D0/3.0D0) * ECHAR2
      ELSE
          COULEX=0.0D0
C
      END IF
C
      ECH2_O = ECHAR2
      COEX_O = COULEX
C
      ECHAR2 = ECHAR2 * E_EFFE * E_EFFE
      COULEX = COULEX * E_EFFE * E_EFFE
C
C=======================================================================
C
C
      DO LTWCEN = 1, ITWCEN
         HOMSCA(1,LTWCEN)=SQRT(XMASSN*HBAROX(LTWCEN))/H_BARC
         HOMSCA(2,LTWCEN)=SQRT(XMASSN*HBAROY(LTWCEN))/H_BARC
         HOMSCA(3,LTWCEN)=SQRT(XMASSN*HBAROZ(LTWCEN))/H_BARC
      END DO
C
      IF (ITWCEN.EQ.1) CENCOR=0.0D0
C
C=======================================================================
C
      IF (INPOME.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''FREQUENCIES OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
      END IF
C
      IF (INPOME.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''THE LENGTHS OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
      END IF
C
      IF (INPOME.EQ.3) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''THE CNSTNTS OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
      END IF
C
      IF (INPOME.EQ.4) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''LENGTHS OF THE H-O BASIS HAVE BEEN CALC'',
     *                 ''ULATED AS IN RING&SCHUCK EQ.(1.88)'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
      END IF
C
      IF (INPOME.EQ.5) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''FREQUENCIES OF THE H-O BASIS HAVE BEEN '',
     *                 ''CALCULATED FROM QUADR. CONSTRAINTS'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
      END IF
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *         1H*, 2X,''PHYSICAL CONSTANTS:     '',
     *                 ''H_BARC='',F12.8,11X,''HBCOE2='',F12.8,2X,1H*,/,
     *         1H*,77X,                                          1H*,/,
     *         1H*,26X,''XMASSN='',F12.8,11X,''XMASSP='',F12.8,2X,1H*,/,
     *         1H*,77X,                                          1H*,/,
     *         1H*,26X,''HBMASS='',F12.8,11X,''HBMRPA='',F12.8,2X,1H*,/,
     *         1H*,77X,                                          1H*,/,
     *         1H*,26X,''ECHAR2='',F12.8,11X,''COULEX='',F12.8,2X,1H*,/,
     *         1H*,77X,                                          1H*)')
     *
     *          H_BARC,HBCOE2,XMASSN,XMASSP,HBMASS,HBMRPA,ECHAR2,COULEX

C
C=======================================================================
C         CALCULATING THE NUMBER OF STATES IN EACH OF THE 3 OSCILLATORS
C=======================================================================
C         HERE STARTS THE TWO-CENTER LOOP (NOT INTENDED)
C=======================================================================
C
      DO LTWCEN=1,ITWCEN
C
         MCOUNT=0
C
         DO NX=0,NOSCIL
            DO NY=0,NOSCIL
               DO NZ=0,NOSCIL
C
                  MCOUNT=MCOUNT+1
C
                  IF (MCOUNT.GT.NDBTOT) STOP 'NOSCIL TOO BIG /SETBAS'
C
                  NBASIS(MCOUNT,LTWCEN)=MCOUNT
                  EBASIS(MCOUNT,LTWCEN)=HBAROX(LTWCEN)*(NX+0.5D0)
     *                                 +HBAROY(LTWCEN)*(NY+0.5D0)
     *                                 +HBAROZ(LTWCEN)*(NZ+0.5D0)
C
               END DO
            END DO
         END DO
C
         CALL ORDER1(EBASIS(:,LTWCEN),NBASIS(:,LTWCEN),MCOUNT)
C
C=======================================================================
C         IF NLIMIT>0 THE BASIS WILL BE DEFINED IN SUCH A WAY THAT
C         THE TOTAL NUMBER OF THE LOWEST BASIS STATES  RETAINED IS
C         EQUAL TO THE PRESCRIBED VALUE (NLIMIT).  WHENEVER NLIMIT
C         HAPPENS TO BE INSIDE A DEGENERATE MULTIPLET (A SPHERICAL
C         OR AXIAL SYMMETRY) THE WHOLE MULTIPLET IS TAKEN. IN SUCH
C         A CASE THE NUMBER OF STATES RETAINED  (LDBASE)  MAY BE A
C         LITTLE LARGER THAN THE PRESCRIBED VALUE (NLIMIT).
C
C         NOTE: IF INTERFACE WITH HFBTHO IS USED, NLIMIT VALUE HAS
C               ALREADY BEEN OVERWRITTEN. ACTUAL MAXIMUM ENERGY IN
C               THE BASIS IS SIMPLY E(NLIMIT)
C=======================================================================
C
         IF (LTWCEN.EQ.1) THEN
C
             NLIAUX=NLIMIT
             ENEAUX=ENECUT
C
         ELSEIF (LTWCEN.EQ.2) THEN
C
             IF (NLIMTW.EQ.0)
     *       NLIMTW=((NOSCIL+1)*(NOSCIL+2)*(NOSCIL+3))/6
             NLIAUX=NLIMTW
             ENEAUX=ENECTW
C
         END IF
C
       IF (IF_THO.EQ.0) THEN
C
          IF (NLIAUX.GT.0) THEN
              IF (NLIAUX.LE.MCOUNT) THEN
                  ELIMIT(LTWCEN)=EBASIS(NLIAUX,LTWCEN)+1.0D-5
              ELSE
                  ELIMIT(LTWCEN)=EBASIS(MCOUNT,LTWCEN)+1.0D-5
              END IF
          ELSE
              ELIMIT(LTWCEN)=ENEAUX
          END IF
C
       ELSE
C
          ELIMIT(LTWCEN)=EBASIS(NLIAUX,LTWCEN)+1.0D-5
C
       END IF
C
       MCOUNV(LTWCEN)=MCOUNT
C
C
C=======================================================================
C      HERE FINISHES THE TWO CENTER LOOP
C=======================================================================
C
      END DO
C
C=======================================================================
C         CALCULATING ENERGIES OF THE BASIS STATES AT THE FERMI SURFACE
C=======================================================================
C
       ICOUNT=0
C
       DO LTWCEN=1,ITWCEN
          DO JCOUNT=1,MCOUNV(LTWCEN)
C
             ICOUNT=ICOUNT+1
             NTOTBA(ICOUNT)=ICOUNT
             TOTEBA(ICOUNT)=EBASIS(JCOUNT,LTWCEN)
C
          END DO
       END DO
C
       EFEBAS(0)=TOTEBA(IN_FIX/2)
       EFEBAS(1)=TOTEBA(IZ_FIX/2)
C
C=======================================================================
C         ZEROING THE ARRAY OF SINGLE-PARTICLE INDICES
C=======================================================================
C
      INDICE(:,:,:,:)=0
C
C=======================================================================
C         SELECTING THE STATES INCLUDED IN THE BASIS
C=======================================================================
C         NUMCUT COUNTS THE TOTAL NUMBER OF STATES WHEREAS LDBATW
C         COUNTS THE NUMBER OF STATES IN BOTH BASES SEPARATELY
C=======================================================================
C
      NUMCUT=0
      LDBATW(:)=0
C
      DO LTWCEN=1,ITWCEN
C
         NXMAXV(LTWCEN)=0
         NYMAXV(LTWCEN)=0
         NZMAXV(LTWCEN)=0

C
         DO NX=0,NOSCIL
            DO NY=0,NOSCIL
               DO NZ=0,NOSCIL
C
                  EBASEX(LTWCEN)=HBAROX(LTWCEN)*(NX+0.5D0)
     *                          +HBAROY(LTWCEN)*(NY+0.5D0)
     *                          +HBAROZ(LTWCEN)*(NZ+0.5D0)
C
                  IF (EBASEX(LTWCEN).LT.ELIMIT(LTWCEN)) THEN
C
                      NUMCUT=NUMCUT+1
                      LDBATW(LTWCEN)=LDBATW(LTWCEN)+1
C
                      IF (LDBATW(LTWCEN).LE.NDBASE) THEN
C
C=======================================================================
C                  IS THE BASIS THE SAME AS THAT READ IN THE "READWS"?
C=======================================================================
C
                          IF (IREAWS.EQ.1) THEN
C
                              IF (ITWCEN.NE.1)
     *                            STOP ' IREAWS=1 & ITWCEN<>1 IN SETBAS'
C
                             IF (NXVECT(LDBATW(LTWCEN),LTWCEN).NE.NX.OR.
     *                           NYVECT(LDBATW(LTWCEN),LTWCEN).NE.NY.OR.
     *                           NZVECT(LDBATW(LTWCEN),LTWCEN).NE.NZ)
     *                                                              THEN
C
                               WRITE(NFIPRI,'(/,           1X,20(1H/),
     *                             '' INCOMPATIBLE BASES'',4X,20(1H/),/,
     *                             '' NUMCUT='',I3,
     *                             '' NXVECT='',I2,'' NX='',I2,
     *                             '' NYVECT='',I2,'' NY='',I2,
     *                             '' NZVECT='',I2,'' NZ='',I2)')
     *                       NUMCUT,NXVECT(LDBATW(LTWCEN),LTWCEN), NX,
     *                              NYVECT(LDBATW(LTWCEN),LTWCEN), NY,
     *                              NZVECT(LDBATW(LTWCEN),LTWCEN), NZ
C
                               STOP ' INCOMPATIBLE BASES IN SETBAS'
C
                               END IF
C
                            ELSE
C
C=======================================================================
C                      STORING THE QUANTUM NUMBERS OF THE BASIS STATES
C=======================================================================
C
                                NXVECT(LDBATW(LTWCEN),LTWCEN)=NX
                                NYVECT(LDBATW(LTWCEN),LTWCEN)=NY
                                NZVECT(LDBATW(LTWCEN),LTWCEN)=NZ
C
                            END IF
C
                         END IF
C
C=======================================================================
C                  DETERMINING THE MAXIMUM NUMBERS OF OSCILLATOR QUANTA
C=======================================================================
C
                         IF (NX.GT.NDXMAX.OR.
     *                       NY.GT.NDYMAX.OR.
     *                       NZ.GT.NDZMAX) THEN
C
                             WRITE(NFIPRI,'(/,
     *                              3X,20(1H/),/,''  CENTER='',I3,
     *                              1X,20(1H/),  ''  TOO LARGE BASIS'',
     *                              3X,20(1H/),/,''  NUMCUT='',I3,
     *                              '' NDXMAX='',I2,'' NX='',I2,
     *                              '' NDYMAX='',I2,'' NY='',I2,
     *                              '' NDZMAX='',I2,'' NZ='',I2)')
     *                          LTWCEN,NUMCUT,NDXMAX, NX,
     *                                 NDYMAX, NY,
     *                                 NDZMAX, NZ
C
                       STOP ' TOO LARGE OSCILLATOR NUMBERS IN SETBAS'
C
                         END IF
C
                         NXMAXV(LTWCEN)=MAX(NXMAXV(LTWCEN),NX)
                         NYMAXV(LTWCEN)=MAX(NYMAXV(LTWCEN),NY)
                         NZMAXV(LTWCEN)=MAX(NZMAXV(LTWCEN),NZ)
C
                         INDICE(NX,NY,NZ,LTWCEN)=LDBATW(LTWCEN)
C
                     END IF
C
                 END DO
             END DO
         END DO
C
C=======================================================================
C
         IF (LDBATW(LTWCEN).GT.NDBASE) THEN
C
             WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' CENTER INDEX OF BASIS SET   ='',I4,
     *                            ''  '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' TOO LARGE SP. BASIS: LDBASE ='',I4,
     *                            ''  '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' WAS ESTABLISHED FOR  NLIMIT ='',I4,
     *                            ''  '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' LDBASE CANNOT EXCEED NDBASE ='',I4,
     *                            ''  '',       2X,20(1H/),/,
     *                 1X,20(1H/),'' YOU MAY INCRESE NDBASE TO  LDBASE''
     *                           ,''  '',       2X,20(1H/),/,
     *                 1X,20(1H/),''   OR DECRESE NLIMIT BELOW  NDBASE''
     *                           ,''  '',       2X,20(1H/),/)')
     *           LTWCEN,NUMCUT,NLIMIT,NDBASE
C
             STOP ' INCORRECT VALUE OF NLIMIT OR NDBASE IN SETBAS'
C
         END IF
C
      END DO
C
C=======================================================================
C         IS THE SIZE OF THE BASIS THE SAME AS THAT READ IN THE "READWS"
C=======================================================================
C
      IF (IREAWS.EQ.1) THEN
C
          IF (NUMCUT.NE.LDBASE) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),''  INCOMPATIBLE NO. OF STATES'',
     *                     3X,20(1H/),/,
     *                                ''  NUMCUT='',I3,
     *                                ''  LDBASE='',I3)')
     *
     *                                    NUMCUT,LDBASE
C
              STOP 'INCOMPATIBLE NO. OF STATES IN SETBAS'
C
          END IF
C
      ELSE
C
          LDBASE=LDBATW(1)
C
          LDBTOT=0
          DO LTWCEN=1,ITWCEN
             LDBTOT=LDBTOT+LDBATW(LTWCEN)
          END DO
C
      END IF
C
C=======================================================================
C     COMPARE SIZES OF BOTH BASIS TO STOP THE CODE IF THEY ARE NOT EQUAL
C     THIS IS PROVISIONAL
C=======================================================================
C
C      NSICOM=MAXVAL(LDBATW,ITWCEN)
C      NSTEST=0
C
C      DO LTWCEN=1,ITWCEN
C
C          IF (NSICOM.NE.LDBATW(LTWCEN)) NSTEST=NSTEST+1
C
C      END DO
C
C      IF (NSTEST.NE.0) STOP 'BOTH BASIS HAVE NOT THE SAME SIZE'
C
C=======================================================================
C
      INCORR=0
C
      DO IREVER=0,NDREVE
         DO ICHARG=0,NDISOS
C
            IF (NUMBSP(IREVER,ICHARG).GT.LDBASE) THEN
C
                WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                 '' INCORRECT PHASE SPACE DEFINITION'',
     *                 ''    '',          1X,20(1H/),/,
     *                                    1X,20(1H/),
     *                 '' IREVER='',I4,
     *                 '' ICHARG='',I4,
     *                 '' NUMBSP='',I4,   2X,20(1H/),/,
     *                                    1X,20(1H/),
     *                 '' LDBASE='',I4,
     *                 '' NDSTAT='',I4,
     *                 ''        '',      6X,20(1H/),/)')
     *
     *                 IREVER,ICHARG,NUMBSP(IREVER,ICHARG),
     *                 LDBASE,NDSTAT
C
                INCORR=1
C
            END IF
C
         END DO
      END DO
C
      IF (INCORR.EQ.1)
     *    STOP ' INCORRECT PHASE SPACE DEFINITION IN SETBAS'
C
C=======================================================================
C         DETERMINING THE OPTIMUM NUMBERS OF GAUSS-INTEGRATION POINTS
C=======================================================================
C
      NXHERV(:)=0
      NYHERV(:)=0
      NZHERV(:)=0
C
      IF (IOPTGS.EQ.1.AND.IREAWS.NE.1) THEN
C
          DO LTWCEN=1,ITWCEN
             NXHERV(LTWCEN)=2*NXMAXV(LTWCEN)+2
             NYHERV(LTWCEN)=2*NYMAXV(LTWCEN)+2
             NZHERV(LTWCEN)=2*NZMAXV(LTWCEN)+2
          END DO
C
          NXHERM=MAXVAL(NXHERV,ITWCEN)
          NYHERM=MAXVAL(NYHERV,ITWCEN)
          NZHERM=MAXVAL(NZHERV,ITWCEN)
C
       END IF
C
       IF (IOPTGS.EQ.2.AND.IREAWS.NE.1) THEN
C
          DO LTWCEN=1,ITWCEN
             NXHERV(LTWCEN)=3*NXMAXV(LTWCEN)+2
             NYHERV(LTWCEN)=3*NYMAXV(LTWCEN)+2
             NZHERV(LTWCEN)=3*NZMAXV(LTWCEN)+2
          END DO
C
          NXHERM=MAXVAL(NXHERV,ITWCEN)
          NYHERM=MAXVAL(NYHERV,ITWCEN)
          NZHERM=MAXVAL(NZHERV,ITWCEN)
C
       END IF
C
C=======================================================================
C         DETERMINING PARITIES OF THE BASIS STATES
C=======================================================================
C
      DO LTWCEN=1,ITWCEN

       LDBASP(0)=0
       LDBASP(1)=0
C
       DO IBASE=1,LDBATW(LTWCEN)
C
          IPARIT=MOD(NXVECT(IBASE,LTWCEN)+NYVECT(IBASE,LTWCEN)
     *                                +NZVECT(IBASE,LTWCEN),2)
C
         LDBASP(IPARIT)=LDBASP(IPARIT)+1
         IF (LDBASP(IPARIT).GT.NDBASE) STOP ' LDBASP(IPARIT) IN SETBAS'
         INDPAR(LDBASP(IPARIT),IPARIT)=IBASE
C
         IBAPAR(IBASE,LTWCEN)=IPARIT
C
       END DO
C
       IF (LDBASP(0)+LDBASP(1).NE.LDBATW(LTWCEN)) THEN
          WRITE(NFIPRI,'(/,
     *          1X,20(1H/),'' CENTER INDEX OF BASIS SET   ='',I2
     *                           ,''  '',       2X,20(1H/),/)')
     *           LTWCEN
           STOP ' PARITY SUM IN SETBAS'
       END IF
C
      END DO
C
C=======================================================================
C         DETERMINING THE LIMITS OF THE BASIS IN THE NX-NY-NZ SPACE
C=======================================================================
C         X-DIRECTION
C=======================================================================
C     TWO CENTER BASIS LOOP STARTS HERE
C=======================================================================
C
      DO LTWCEN=1,ITWCEN
C
       DO NX=0,NXMAXV(LTWCEN)
         MAXIMY=0
         MAXIMZ=0
         DO NY=0,NYMAXV(LTWCEN)
            MAXIXY=0
            DO NZ=0,NZMAXV(LTWCEN)
               IF (INDICE(NX,NY,NZ,LTWCEN).NE.0) THEN
                   MAXIMY=MAX(MAXIMY,NY)
                   MAXIMZ=MAX(MAXIMZ,NZ)
                   MAXIXY=MAX(MAXIXY,NZ)
               END IF
            END DO
            LZOXYV(NX,NY,LTWCEN)=MAXIXY
         END DO
         LYOFXV(NX,LTWCEN)=MAXIMY
         LZOFXV(NX,LTWCEN)=MAXIMZ
       END DO
C
C=======================================================================
C         Y-DIRECTION
C=======================================================================
C
        DO NY=0,NYMAXV(LTWCEN)
         MAXIMZ=0
         MAXIMX=0
         DO NZ=0,NZMAXV(LTWCEN)
            MAXIYZ=0
            DO NX=0,NXMAXV(LTWCEN)
               IF (INDICE(NX,NY,NZ,LTWCEN).NE.0) THEN
                   MAXIMZ=MAX(MAXIMZ,NZ)
                   MAXIMX=MAX(MAXIMX,NX)
                   MAXIYZ=MAX(MAXIYZ,NX)
              END IF
            END DO
            LXOYZV(NY,NZ,LTWCEN)=MAXIYZ
         END DO
         LZOFYV(NY,LTWCEN)=MAXIMZ
         LXOFYV(NY,LTWCEN)=MAXIMX
        END DO
C
C=======================================================================
C         Z-DIRECTION
C=======================================================================
C
       DO NZ=0,NZMAXV(LTWCEN)
         MAXIMX=0
         MAXIMY=0
         DO NX=0,NXMAXV(LTWCEN)
            MAXIZX=0
            DO NY=0,NYMAXV(LTWCEN)
               IF (INDICE(NX,NY,NZ,LTWCEN).NE.0) THEN
                   MAXIMX=MAX(MAXIMX,NX)
                   MAXIMY=MAX(MAXIMY,NY)
                   MAXIZX=MAX(MAXIZX,NY)
              END IF
            END DO
            LYOZXV(NZ,NX,LTWCEN)=MAXIZX
         END DO
         LXOFZV(NZ,LTWCEN)=MAXIMX
         LYOFZV(NZ,LTWCEN)=MAXIMY
       END DO
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *          1H*, 2X,''OSCILLATOR LENGTHS:     '',
     *            ''X='',F10.7,6X,''Y='',F10.7,7X,''Z='',F10.7,2X,1H*,/,
     *          1H*,77X,                                          1H*,/,
     *          1H*, 2X,''OSCILLATOR CONSTANTS:   '',
     *            ''X='',F10.7,6X,''Y='',F10.7,7X,''Z='',F10.7,2X,1H*,/,
     *          1H*,77X,                                          1H*,/,
     *          1H*, 2X,''OSCILLATOR FREQUENCIES: '',
     *            ''X='',F10.7,6X,''Y='',F10.7,7X,''Z='',F10.7,2X,1H*,/,
     *          1H*,77X,                                          1H*)')
     *
     *            (1.D0/HOMSCA(KARTEZ,LTWCEN),KARTEZ=1,NDKART),
     *                 (HOMSCA(KARTEZ,LTWCEN),KARTEZ=1,NDKART),
     *                      HBAROX(LTWCEN),HBAROY(LTWCEN),HBAROZ(LTWCEN)

C
      IF (ITWCEN.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *          1H*, 2X,''BASIS CENTERED AT     : '',
     *            ''X='',F10.5,6X,''Y='',F10.5,7X,''Z='',F10.5,2X,1H*,/,
     *          1H*,77X,                                          1H*)')
     *                CENCOR(1,LTWCEN),CENCOR(2,LTWCEN),CENCOR(3,LTWCEN)
C
      END IF
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *            1H*, 2X,''BASIS CUT-OFF CONTROL PARAMETERS:'',
     *                    ''  NXMAXX ='',I3,''  NYMAXX ='',I3,
     *                    ''  NZMAXX ='',I4,                 2X,1H*,/,
     *            1H*,77X,                                      1H*,/,
     *            1H*, 2X,A33,
     *                    ''  NXHERM ='',I3,''  NYHERM ='',I3,
     *                    ''  NZHERM ='',I4,                  2X,1H*,/,
     *            1H*,77X,                                      1H*,/,
     *            1H*,35X,''  NLIMIT='',I4,''  LDBASE='',I4,
     *                    ''  MCOUNT='',I5,                  2X,1H*,/,
     *            1H*,77X,                                      1H*,/,
     *            1H*,35X,''  ENECUT='',F9.4,4X,
     *                    ''  ELIMIT='',F9.4,                2X,1H*,/,
     *            1H*,77X,                                      1H*,/,
     *            79(1H*),/)')
     *
     *                   NXMAXV(LTWCEN),NYMAXV(LTWCEN),NZMAXV(LTWCEN),
     *    OPTIMU(IOPTGS),NXHERM,NYHERM,NZHERM,
     *                           NLIMIT,LDBATW(LTWCEN),MCOUNV(LTWCEN),
     *                                          ENECUT,ELIMIT(LTWCEN)
C
C=======================================================================
C
      IF (NXHERM.LT.2*NXMAXV(LTWCEN)+2) THEN
         WRITE(NFIPRI,'(/,1X,20(1H/),''  WARNING: NXHERM='',I3,
     *                              ''  IS SMALLER THEN '',I3,
     *                                                     2X,14(1H/),/,
     *                    1X,20(1H/),''  AND DOES NOT ENSURE'',
     *                               ''  EXACT INTEGRATION  '',
     *                                                     2X,14(1H/),/
     *                            )') NXHERM,2*NXMAXV(LTWCEN)+2
      END IF
C
      IF (NYHERM.LT.2*NYMAXV(LTWCEN)+2) THEN
         WRITE(NFIPRI,'(/,1X,20(1H/),''  WARNING: NYHERM='',I3,
     *                               ''  IS SMALLER THEN '',I3,
     *                                                     2X,14(1H/),/,
     *                    1X,20(1H/),''  AND DOES NOT ENSURE'',
     *                               ''  EXACT INTEGRATION  '',
     *                                                     2X,14(1H/),/
     *                            )') NYHERM,2*NYMAXV(LTWCEN)+2
      END IF
C
      IF (NZHERM.LT.2*NZMAXV(LTWCEN)+2) THEN
         WRITE(NFIPRI,'(/,1X,20(1H/),''  WARNING: NZHERM='',I3,
     *                               ''  IS SMALLER THEN '',I3,
     *                                                     2X,14(1H/),/,
     *                    1X,20(1H/),''  AND DOES NOT ENSURE'',
     *                               ''  EXACT INTEGRATION  '',
     *                                                     2X,14(1H/),/
     *                            )') NZHERM,2*NZMAXV(LTWCEN)+2
      END IF
C
C=======================================================================
C
      IF (MOD(NXHERM,2).NE.0) THEN
         WRITE(NFIPRI,'(/,1X,20(1H/),''  NXHERM IS ODD:'',
     *                                         I3,2X,20(1H/),/)')
     *                                             NXHERM
         STOP 'NXHERM ODD IN SETBAS'
      END IF
C
      IF (MOD(NYHERM,2).NE.0) THEN
         WRITE(NFIPRI,'(/,1X,20(1H/),''  NYHERM IS ODD:'',
     *                                         I3,2X,20(1H/),/)')
     *                                            NYHERM
         STOP 'NYHERM ODD IN SETBAS'
      END IF
C
      IF (MOD(NZHERM,2).NE.0) THEN
         WRITE(NFIPRI,'(/,1X,20(1H/),''  NZHERM IS ODD:'',
     *                                         I3,2X,20(1H/),/)')
     *                                            NZHERM
         STOP 'NZHERM ODD IN SETBAS'
      END IF
C
C=======================================================================
C
      IF (NXHERM.GT.NDXHRM) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''NXHERM.GT.NDXHRM:'',3X,20(1H/),/,
     *                 1X,20(1H/),8X,I2,   ''.GT.''  ,I2,8X,20(1H/),/)')
     *                 NXHERM,NDXHRM
         STOP 'NXHERM.GT.NDXHRM IN SETBAS'
      END IF
C
      IF (NYHERM.GT.NDYHRM) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''NYHERM.GT.NDYHRM:'',3X,20(1H/),/,
     *                 1X,20(1H/),8X,I2,   ''.GT.''  ,I2,8X,20(1H/),/)')
     *                 NYHERM,NDYHRM
         STOP 'NYHERM.GT.NDYHRM IN SETBAS'
      END IF
C
      IF (NZHERM.GT.NDZHRM) THEN
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),4X,''NZHERM.GT.NDZHRM:'',3X,20(1H/),/,
     *                 1X,20(1H/),8X,I2,   ''.GT.''  ,I2,8X,20(1H/),/)')
     *                 NZHERM,NDZHRM
         STOP 'NZHERM.GT.NDZHRM IN SETBAS'
      END IF
C
C=======================================================================
C         PRINTING THE BASIS SHAPE DIAGRAMS (THE "DIAMONDS")
C=======================================================================
C
      DO IDIGIT=0,99
         WRITE(DIGITS(IDIGIT),'(I2)') IDIGIT
      END DO
C
      IF (ITWCEN.EQ.1) THEN
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *            1H*,3X,''SHAPE OF THE OSCILLATOR-BASIS DIAMOND'',
     *                   ''    (THREE CONSECUTIVE PROJECTIONS)'',
     *                                                       2X,1H*,/,
     *            1H*,77X,                                      1H*,/,
     *            79(1H*),/,1H*,77X,1H*)')
C
      ELSEIF (ITWCEN.EQ.2) THEN
       IF (LTWCEN.EQ.1) THEN
       WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *            1H*,6X,''SHAPE OF THE 1ST OSC-BASIS DIAMOND'',
     *                   ''    (THREE CONSECUTIVE PROJECTIONS)'',
     *                                                       2X,1H*,/,
     *            1H*,77X,                                      1H*,/,
     *            79(1H*),/,1H*,77X,1H*)')
       ELSEIF (LTWCEN.EQ.2) THEN
       WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *            1H*,6X,''SHAPE OF THE 2ND OSC-BASIS DIAMOND'',
     *                   ''    (THREE CONSECUTIVE PROJECTIONS)'',
     *                                                       2X,1H*,/,
     *            1H*,77X,                                      1H*,/,
     *            79(1H*),/,1H*,77X,1H*)')
       END IF
C
      END IF
C
C=======================================================================
C         NX - NY  P L A N E    NX - NY  P L A N E   NX - NY  P L A N E
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,8X,''NX ===>>>'',19(1X,A2),3X,1H*)')
     *                    (DIGITS(NX),NX=0,MIN(NXMAXV(LTWCEN),18)),
     *                     ('  ',NX=  MIN(NXMAXV(LTWCEN),18)+1,18)
C
      WRITE(NFIPRI,'(1H*,8X,''MAX.NY =>'',19(1X,A2),3X,1H*)')
     *     (DIGITS(LYOFXV(NX,LTWCEN)),NX=0,MIN(NXMAXV(LTWCEN),18)),
     *                     ('  ',NX=  MIN(NXMAXV(LTWCEN),18)+1,18)
C
      WRITE(NFIPRI,'(1H*,8X,''         '',19A3,3X,1H*)')
     *               ('---',NX=0,MIN(NXMAXV(LTWCEN),18)),
     *          ('   ',NX=  MIN(NXMAXV(LTWCEN),18)+1,18)
C
C=======================================================================
C
      DO NY=0,NYMAXV(LTWCEN)
C
         WRITE(NFIPRI,'(1H*,3X,''NY='',I2,2X,''('',I2,'')'',2X,''|'',
     *                19(1X,A2),3X,1H*)')
     *            NY,LXOFYV(NY,LTWCEN),
     *  (DIGITS(LZOXYV(NX,NY,LTWCEN)),NX=0,MIN(LXOFYV(NY,LTWCEN),18)),
     *                    ('  ',NX=  MIN(LXOFYV(NY,LTWCEN),18)+1,18)
C
      END DO
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,77X,1H*)')
C
C=======================================================================
C         NZ - NY  P L A N E    NZ - NY  P L A N E   NZ - NY  P L A N E
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,8X,''NZ ===>>>'',19(1X,A2),3X,1H*)')
     *               (DIGITS(NZ),NZ=0,MIN(NZMAXV(LTWCEN),18)),
     *                ('  ',NZ=  MIN(NZMAXV(LTWCEN),18)+1,18)
C
      WRITE(NFIPRI,'(1H*,8X,''MAX.NY =>'',19(1X,A2),3X,1H*)')
     *    (DIGITS(LYOFZV(NZ,LTWCEN)),NZ=0,MIN(NZMAXV(LTWCEN),18)),
     *                ('  ',NZ=  MIN(NZMAXV(LTWCEN),18)+1,18)
C
      WRITE(NFIPRI,'(1H*,8X,''         '',19A3,3X,1H*)')
     *                   ('---',NZ=0,MIN(NZMAXV(LTWCEN),18)),
     *                   ('   ',NZ=  MIN(NZMAXV(LTWCEN),18)+1,18)
C
C=======================================================================
C
      DO NY=0,NYMAXV(LTWCEN)
C
         WRITE(NFIPRI,'(1H*,3X,''NY='',I2,2X,''('',I2,'')'',2X,''|'',
     *                19(1X,A2),3X,1H*)')
     *            NY,LZOFYV(NY,LTWCEN),
     *  (DIGITS(LXOYZV(NY,NZ,LTWCEN)),NZ=0,MIN(LZOFYV(NY,LTWCEN),18)),
     *                     ('  ',NZ=  MIN(LZOFYV(NY,LTWCEN),18)+1,18)
C
      END DO
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,77X,1H*)')
C
C=======================================================================
C         NZ - NX  P L A N E    NZ - NX  P L A N E   NZ - NX  P L A N E
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,8X,''NZ ===>>>'',19(1X,A2),3X,1H*)')
     *                (DIGITS(NZ),NZ=0,MIN(NZMAXV(LTWCEN),18)),
     *                      ('  ',NZ=  MIN(NZMAXV(LTWCEN),18)+1,18)
C
      WRITE(NFIPRI,'(1H*,8X,''MAX.NX =>'',19(1X,A2),3X,1H*)')
     *       (DIGITS(LXOFZV(NZ,LTWCEN)),NZ=0,MIN(NZMAXV(LTWCEN),18)),
     *                     ('  ',NZ=  MIN(NZMAXV(LTWCEN),18)+1,18)
C
      WRITE(NFIPRI,'(1H*,8X,''         '',19A3,3X,1H*)')
     *                       ('---',NZ=0,MIN(NZMAXV(LTWCEN),18)),
     *                       ('   ',NZ=  MIN(NZMAXV(LTWCEN),18)+1,18)
C
C=======================================================================
C
      DO NX=0,NXMAXV(LTWCEN)
C
         WRITE(NFIPRI,'(1H*,3X,''NX='',I2,2X,''('',I2,'')'',2X,''|'',
     *                19(1X,A2),3X,1H*)')
     *            NX,LZOFXV(NX,LTWCEN),
     *  (DIGITS(LYOZXV(NZ,NX,LTWCEN)),NZ=0,MIN(LZOFXV(NX,LTWCEN),18)),
     *                     ('  ',NZ=  MIN(LZOFXV(NX,LTWCEN),18)+1,18)
C
      END DO
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C     TWO CENTER BASIS LOOP FINISHES HERE
C=======================================================================
C
      END DO
C
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
       IF (IPRGCM.GE.1.AND.NUAKNO.GT.1.AND.
     *   (HOMSCA(1,1).NE.HOMSCA(2,1).OR.
     *    HOMSCA(2,1).NE.HOMSCA(3,1).OR.
     *    HOMSCA(3,1).NE.HOMSCA(1,1))) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' IPRGCM>0 REQUIRES SPHERICAL'',
     *                            '' BASIS  '',        1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(1,1)-HOMSCA(2,1) = '',E13.6,
     *                                                 1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(2,1)-HOMSCA(3,1) = '',E13.6,
     *                                                 1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(3,1)-HOMSCA(1,1) = '',E13.6,
     *                                                 1X,20(1H/))')
C
          STOP ' NON-SPHERICAL BASIS FOR IPRGCM>0 IN SETBAS'
C
        END IF
C
C=======================================================================
C
       IF (INIROT.EQ.1.AND.(HOMSCA(1,1).NE.HOMSCA(2,1).OR.
     *                     HOMSCA(2,1).NE.HOMSCA(3,1).OR.
     *                     HOMSCA(3,1).NE.HOMSCA(1,1))) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' INIROT=1 REQUIRES SPHERICAL'',
     *                            '' BASIS  '',        1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(1,1)-HOMSCA(2,1) = '',E13.6,
     *                                                 1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(2,1)-HOMSCA(3,1) = '',E13.6,
     *                                                 1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(3,1)-HOMSCA(1,1) = '',E13.6,
     *                                                 1X,20(1H/))')
     *          HOMSCA(1,1)-HOMSCA(2,1),
     *          HOMSCA(2,1)-HOMSCA(3,1),
     *          HOMSCA(3,1)-HOMSCA(1,1)
C
          STOP ' NON-SPHERICAL BASIS FOR INIROT=1 IN SETBAS'
C
       END IF
C
C=======================================================================
C
       IF (ISPHER.EQ.1.AND.(HOMSCA(1,1).NE.HOMSCA(2,1).OR.
     *                     HOMSCA(2,1).NE.HOMSCA(3,1).OR.
     *                     HOMSCA(3,1).NE.HOMSCA(1,1))) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' ISPHER=1 REQUIRES SPHERICAL'',
     *                            '' BASIS  '',        1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(1,1)-HOMSCA(2,1) = '',E13.6,
     *                                                 1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(2,1)-HOMSCA(3,1) = '',E13.6,
     *                                                 1X,20(1H/),/,
     *             1X,20(1H/),'' HOMSCA(3,1)-HOMSCA(1,1) = '',E13.6,
     *                                                 1X,20(1H/))')
     *          HOMSCA(1,1)-HOMSCA(2,1),
     *          HOMSCA(2,1)-HOMSCA(3,1),
     *          HOMSCA(3,1)-HOMSCA(1,1)
C
          STOP ' NON-SPHERICAL BASIS FOR ISPHER=1 IN SETBAS'
C
       END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MULCOU(ISIMPY,ISIGNY,ISIQTY,NMUCOU)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /LISMOM/ LISLAM(1:NDPOLS),LISMIU(1:NDPOLS),NUPOLS
C
C=======================================================================
C         THIS SUBROUTINE SELECTS THE MULTIPOLES WHICH WILL BE USED FOR
C         A CALCULATION OF THE COULOMB POTENTIAL AT THE BOX  BOUNDARIES
C=======================================================================
C         FOR CONSERVED SIMPLEX (ISIMPY=1):
C         ONLY THE REAL PARTS OF MOMENTS ARE USED.
C=======================================================================
C         FOR CONSERVED SIGNATURE (ISIGNY=1):
C         1) THE      REAL PARTS  ARE USED ONLY FOR EVEN MOMENTS.
C         2) THE IMAGINARY PARTS  ARE USED ONLY FOR ODD  MOMENTS.
C=======================================================================
C         FOR CONSERVED PARITY (ISIQTY=1):
C         ONLY THE EVEN MOMENTS ARE USED.
C=======================================================================
C         ISIMPY  ISIGNY  ISIQTY |  REAL PARTS           IMAGINARY PARTS
C         -----------------------|--------------------------------------
C            0       0       0   |  ALL  MULTIPOLES      ALL  MULTIPOLES
C            0       0       1   |  EVEN MULTIPOLES      EVEN MULTIPOLES
C            0       1       0   |  EVEN MULTIPOLES      ODD  MULTIPOLES
C            1       0       0   |  ALL  MULTIPOLES      NONE MULTIPOLES
C            1       1       1   |  EVEN MULTIPOLES      NONE MULTIPOLES
C=======================================================================
C         FOR ISIMPY=0 AND ISIGNY=0 AND ISIQTY=0
C                      AND  FOR  NMUCOU   ==>>  4  (5,  6,  7,  8,  9)
C                      ONE NEEDS NDPOLS   ==>> 25 (36, 49, 64, 81,100)
C         FOR ISIMPY=0 AND ISIGNY=0 AND ISIQTY=1
C                      AND  FOR  NMUCOU   ==>>  4  (5,  6,  7,  8,  9)
C                      ONE NEEDS NDPOLS   ==>> 15 (15, 28, 28, 45, 45)
C         FOR ISIMPY=0 AND ISIGNY=1
C                      AND  FOR  NMUCOU   ==>>  4  (5,  6,  7,  8,  9)
C                      ONE NEEDS NDPOLS   ==>> 13 (18, 25, 32, 41, 50)
C         FOR ISIMPY=1 AND ISIGNY=0
C                      AND  FOR  NMUCOU   ==>>  4  (5,  6,  7,  8,  9)
C                      ONE NEEDS NDPOLS   ==>> 15 (21, 28, 36, 45, 55)
C         FOR ISIMPY=1 AND ISIGNY=1
C                      AND  FOR  NMUCOU   ==>>  4  (5,  6,  7,  8,  9)
C                      ONE NEEDS NDPOLS   ==>>  9 ( 9, 16, 16, 25, 25)
C=======================================================================
C
      MULPOL=0
C
C=======================================================================
C        ADDING REAL PARTS OF MULTIPOLE MOMENTS TO THE LIST
C=======================================================================
C
      DO LAMBDA=0,NMUCOU
         DO MIU=0,LAMBDA
C
            IF (MOD(LAMBDA,2).EQ.0.OR.(ISIGNY.NE.1.AND.ISIQTY.NE.1))THEN
C
               IF (MULPOL.GE.NDPOLS)
     *             STOP ' (1) MULPOL.GT.NDPOLS IN MULCOU'
C
               MULPOL=MULPOL+1
               LISLAM(MULPOL)=LAMBDA
               LISMIU(MULPOL)=MIU
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        ADDING IMAGINARY PARTS OF MULTIPOLE MOMENTS TO THE LIST
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.NMUCOU.GE.1) THEN
C
          DO LAMBDA=1,NMUCOU
             DO MIU=-LAMBDA,-1
C
                IF ((MOD(LAMBDA,2).EQ.1.AND.ISIQTY.NE.1).OR.
     *              (MOD(LAMBDA,2).EQ.0.AND.ISIGNY.NE.1)) THEN
C
                   IF (MULPOL.GE.NDPOLS)
     *                 STOP ' (2) MULPOL.GT.NDPOLS IN MULCOU'
C
                   MULPOL=MULPOL+1
                   LISLAM(MULPOL)=LAMBDA
                   LISMIU(MULPOL)=MIU
C
                END IF
C
             END DO
          END DO
C
      END IF
C
      NUPOLS=MULPOL
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PRECOU(NOSCIL,NUMCOU,NUMETA,BOUCOU,
     *                  NFICOU,FILCOU,ICOULI,ICOULO)
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
      CHARACTER
     *          FILCOU*68
C
C=======================================================================
C          THIS SOUBROUTINE DEFINES THE FOURIER INTEGRALS FOR THE
C          COULOMB POTENTIAL.
C=======================================================================
C
      CALL DEFCOU(NOSCIL,NUMCOU,BOUCOU)
C
C=======================================================================
C         CHECKING WHETHER THE COULOMB FILE EXISTS ON THE DISC
C=======================================================================
C
      ICOULE=0
C
      OPEN(NFICOU,FILE=FILCOU,STATUS='OLD',ERR=1,FORM='UNFORMATTED')
C
      ICOULE=1
      CLOSE(NFICOU)
C
    1 CONTINUE
C
C=======================================================================
C         FOR  ICOULI<>0  AND  ICOULO<>0  ONE ENTERS THE AUTOMATED MODE:
C         1) THE COULOMB FILE IS  READ  PROVIDED  IT EXISTS ON THE DISC,
C         2) THEN IT IS CHECKED IF IT CONTAINS THE CORRECT DATA.
C         3) IF IT DOESN'T EXIST, OR IF IT DOESN'T CONTAIN CORRECT DATA,
C            THE SUBROUTINE  "POWALL" IS CALLED AND THE COULOMB FILE IS
C            STORED ON THE DISC
C=======================================================================
C
      IF (ICOULI.NE.0.AND.ICOULO.NE.0) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' AUTOMATED HANDLING OF THE'',
     *               '' COULOMB FILE'',                 37X,1H*,/,
     *                                              1H*,77X,1H*)')
C
      END IF
C
      IREWRI=0
C
C=======================================================================
C         FOR  ICOULI<>0  THE COULOMB FILE IS READ FROM THE DISC
C=======================================================================
C         FOR  ICOULI<>0  AND  ICOULO<>0  ONE ENTERS THE AUTOMATED MODE:
C                                       (SEE THE RULES ENUMERATED ABOVE)
C=======================================================================
C
      IF (ICOULI.EQ.0.OR.
     *   (ICOULI.NE.0.AND.ICOULO.NE.0.AND.ICOULE.EQ.0)) THEN
C
          CALL POWALL(NUMCOU,NUMETA,BOUCOU)
C
      ELSE
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE COULOMB FILE READ FROM THE DISC,'',
     *               '' FILE NAME (FILCOU): '',         18X,1H*,/,
     *        1H*,2X,A68,                                7X,1H*,/,
     *                                              1H*,77X,1H*)')
     *
     *        FILCOU
C
          INPCOU=1
          I_SUCC=1
C
          OPEN(NFICOU,FILE=FILCOU,STATUS='OLD',FORM='UNFORMATTED')
          CALL RECOUL(NFICOU,INPCOU,I_SUCC,NUMCOU,NUMETA,BOUCOU)
          CLOSE(NFICOU)
C
          IF (I_SUCC.NE.1) THEN
              IF (ICOULI.NE.0.AND.ICOULO.NE.0) THEN
C
                  CALL POWALL(NUMCOU,NUMETA,BOUCOU)
                  IREWRI=1
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *                  1H*,1X,'' THE COULOMB DATA HAVE'',
     *                         '' BEEN RECALCULATED'',36X,1H*,/,
     *                                            1H*,77X,1H*)')
C
              ELSE
C
                  STOP ' INCORRECT DATA ON THE COULOMB FILE IN PRECOU'
C
              END IF
          END IF
C
      END IF
C
C=======================================================================
C         FOR  ICOULO<>0  THE COULOMB FILE IS WRITTEN ON THE DISC
C=======================================================================
C         FOR  ICOULI<>0  AND  ICOULO<>0  ONE ENTERS THE AUTOMATED MODE:
C                                       (SEE THE RULES ENUMERATED ABOVE)
C=======================================================================
C
      IF (ICOULO.NE.0.AND.(ICOULI.EQ.0.OR.(ICOULE.EQ.0.OR.IREWRI.EQ.1)))
     *    THEN
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *        1H*,1X,'' THE COULOMB FILE WRITTEN ON THE DISC,'',
     *               '' FILE NAME (FILCOU): '',         17X,1H*,/,
     *        1H*,2X,A68,                                7X,1H*,/,
     *                                              1H*,77X,1H*)')
     *
     *        FILCOU
C
          INPCOU=0
          I_SUCC=1
C
          OPEN(NFICOU,FILE=FILCOU,STATUS='UNKNOWN',FORM='UNFORMATTED')
          CALL RECOUL(NFICOU,INPCOU,I_SUCC,NUMCOU,NUMETA,BOUCOU)
          CLOSE(NFICOU)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RECOUL(NFICOU,INPCOU,I_SUCC,NUMCOU,NUMETA,BOUCOU)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          LIZLAM(1:NDPOLS),LIZMIU(1:NDPOLS)
      DIMENSION
     *          HOMSCB(NDKART)
C
      COMMON
     *       /WFACTO/ WALPOT(0:NDCOUL,0:NDCOUL,1:NDPOLS,1:NDKART,0:1),
     *                WALFAC(0:NDCOUL,                  1:NDKART,0:1)
      COMMON
     *       /LISMOM/ LISLAM(1:NDPOLS),LISMIU(1:NDPOLS),NUPOLS
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('RECOUL',1)
C
C=======================================================================
C     INPCOU - IF .NE.0 => THE FILE WITH THE UNIT NUMBER  NFICOU WILL BE
C                          USED TO  R E A D   THE COULOMB MATRICES WHICH
C                          HAVE BEEN PREVIOUSLY CALCULATED  BY  "POWALL"
C=======================================================================
C
      IF (INPCOU.NE.0) THEN
C
          REWIND(UNIT=NFICOU,IOSTAT=IERROR)
C
          IF (IERROR.NE.0) STOP 'ERROR IN REWINDING (6)'
C
          IFIRED=0
C
          READ (NFICOU) IVERIN
C
          IF (IVERIN.EQ.3) THEN
C
C=======================================================================
C             READING THE COULOMB ARRAYS' DIMENSIONS
C=======================================================================
C
              READ (NFICOU) MDCOUL,MDKART,MUPOLS
C
              IF (MDCOUL.NE.NDCOUL.OR.MDKART.NE.NDKART) THEN
C
                  WRITE(NFIPRI,'(/,                    1X,20(1H/),
     *                         ''  INCORRECT PARAMETER DIMENSIONS'',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  FOUND  ON  THE  COULOMB  FILE:'',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''            READ   SHOULD BE    '',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  NDCOUL='',I6,4X,I6,13X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  NDKART='',I6,4X,I6,13X,20(1H/),/)')
     *
     *            MDCOUL,NDCOUL,
     *            MDKART,NDKART
C
                  I_SUCC=-1
                  GO TO 1
C
              END IF
C
C=======================================================================
C
              IF (MUPOLS.NE.NUPOLS) THEN
C
                  WRITE(NFIPRI,'(/,                    1X,20(1H/),
     *                         ''  INCORRECT NUMBER OF MULTIPOLES'',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  FOUND  ON  THE  COULOMB  FILE:'',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''            READ   SHOULD BE    '',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  NUPOLS='',I6,4X,I6,13X,20(1H/),/)')
     *
     *            MUPOLS,NUPOLS
C
                  I_SUCC=-1
                  GO TO 1
C
              END IF
C
C=======================================================================
C             READING THE COULOMB MULTIPOLES
C=======================================================================
C
              READ (NFICOU) (LIZLAM(MULPOL),
     *                       LIZMIU(MULPOL),MULPOL=1,NUPOLS)
C
C=======================================================================
C             ATTENTION: THE TEST BELOW WAS ABSENT UP TO  VERSION  2.00,
C                        AND ONLY THE NUMBERS  OF  DIFFERENT  MULTIPOLES
C                        FOUND ON THE  COULOMB  FILE  WERE  TESTED. THIS
C                        COULD HAVE CAUSED  PROBLEMS, IF  FOR  DIFFERENT
C                        SYMMETRIES THE  LISTS  OF  MULTIPOLES  DIFFERED
C                        WHILE THE NUMERS OF MULTIPOLES WERE  THE  SAME.
C                        SUCH A PROBLEM WAS NOT POSSIBLE  FOR  ISIMPY=1,
C                        AND HENCE THE PUBLISHED VERSION 1.75R WAS SAFE.
C                        THIS BUG WAS CORRECTED  ON  11/07/2002  IN  THE
C                        VERSION 2.00A.
C=======================================================================
C
              IEQUAL=1
C
              DO MULPOL=1,NUPOLS
C
                 IF(LIZLAM(MULPOL).NE.LISLAM(MULPOL).OR.
     *              LIZMIU(MULPOL).NE.LISMIU(MULPOL)) IEQUAL=0
C
              END DO
C
C=======================================================================
C
              IF (IEQUAL.NE.1) THEN
C
                  WRITE(NFIPRI,'(/,                    1X,20(1H/),
     *                         ''  INCORRECT LIST OF MULTIPOLES  '',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  FOUND  ON  THE  COULOMB  FILE '',
     *                                                 6X,20(1H/),/)')
C
                  I_SUCC=-1
                  GO TO 1
C
              END IF
C
C=======================================================================
C             READING THE OSCILLATOR FREQUENCIES
C=======================================================================
C
              READ (NFICOU) (HOMSCB(KARTEZ),KARTEZ=1,NDKART)
C
              IEQUAL=1
C
              DO KARTEZ=1,NDKART
C
                 IF (ABS(HOMSCB(KARTEZ)-HOMSCA(KARTEZ,1)).GT.1.0D-10)
     *               IEQUAL=0
C
              END DO
C
C=======================================================================
C
              IF (IEQUAL.NE.1) THEN
C
                  WRITE(NFIPRI,'(/,                    1X,20(1H/),
     *                         ''  INCORRECT OSCILLATOR FREQUENCY'',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  FOUND  ON  THE  COULOMB  FILE:'',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''               READ   SHOULD BE '',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  HOMSCA-X='',2F10.6, 7X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  HOMSCA-Y='',2F10.6, 7X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  HOMSCA-Z='',2F10.6, 7X,20(1H/),/)')
     *
     *            (HOMSCB(KARTEZ),HOMSCA(KARTEZ,1),KARTEZ=1,NDKART)
C
                  I_SUCC=-1
                  GO TO 1
C
              END IF
C
C=======================================================================
C             READING THE COULOMB PARAMETERS
C=======================================================================
C
              READ (NFICOU)  MUMCOU,MUMETA,AOUCOU
C
              IF (MUMCOU.NE.NUMCOU.OR.MUMETA.NE.NUMETA.OR.
     *            ABS(AOUCOU-BOUCOU).GT.1.0D-10) THEN
C
                  WRITE(NFIPRI,'(/,                    1X,20(1H/),
     *                         ''  INCORRECT  COULOMB  PARAMETERS'',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  FOUND  ON  THE  COULOMB  FILE:'',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''            READ   SHOULD BE    '',
     *                                                 6X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  NUMCOU='',I6,4X,I6,13X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  NUMETA='',I6,4X,I6,13X,20(1H/),/,
     *                         1X,20(1H/),
     *                         ''  BOUCOU='',F6.2,4X,F6.2,
     *                                                13X,20(1H/),/)')
     *
     *            MUMCOU,NUMCOU,
     *            MUMETA,NUMETA,
     *            AOUCOU,BOUCOU
C
                  I_SUCC=-1
                  GO TO 1
C
              END IF
C
C=======================================================================
C             READING THE COULOMB ARRAYS
C=======================================================================
C
              READ (NFICOU) (((((WALPOT(JX,JY,MULPOL,KARTEZ,IWSIDE),
     *                          JX=0,NDCOUL),JY=0,NDCOUL),
     *                          MULPOL=1,NUPOLS),KARTEZ=1,NDKART),
     *                          IWSIDE=0,1)
C
              READ (NFICOU) (  ((WALFAC(JX,          KARTEZ,IWSIDE),
     *                          JX=0,NDCOUL),KARTEZ=1,NDKART),
     *                          IWSIDE=0,1)
C
              IFIRED=1
C
          END IF
C
          IF (IFIRED.EQ.0) THEN
C
              WRITE(NFIPRI,'(/,                 1X,18(1H/),
     *                  '' CANNOT READ THE COULOMB FILE VERSION:'',
     *                                       I3,1X,18(1H/),/)') IVERIN
C
              I_SUCC=-1
              GO TO 1
C
          END IF
C
      ELSE
C
C=======================================================================
C     INPCOU - IF .EQ.0 => THE FILE WITH THE UNIT NUMBER  NFICOU WILL BE
C                          USED TO  S T O R E THE COULOMB  ARRAYS  WHICH
C                          HAVE BEEN PREVIOUSLY CALCULATED  BY  "POWALL"
C=======================================================================
C
          REWIND(UNIT=NFICOU,IOSTAT=IERROR)
C
          IF (IERROR.NE.0) STOP 'ERROR IN REWINDING (7)'
C
          IVEROU=3
C
          WRITE(NFICOU) IVEROU
C
          IF (IVEROU.EQ.3) THEN
C
              WRITE(NFICOU) NDCOUL,NDKART,NUPOLS
C
              WRITE(NFICOU) (LISLAM(MULPOL),
     *                       LISMIU(MULPOL),MULPOL=1,NUPOLS)
C
              WRITE(NFICOU) (HOMSCA(KARTEZ,1),KARTEZ=1,NDKART)
C
              WRITE(NFICOU)  NUMCOU,NUMETA,BOUCOU
C
              WRITE(NFICOU) (((((WALPOT(JX,JY,MULPOL,KARTEZ,IWSIDE),
     *                          JX=0,NDCOUL),JY=0,NDCOUL),
     *                          MULPOL=1,NUPOLS),KARTEZ=1,NDKART),
     *                          IWSIDE=0,1)
C
              WRITE(NFICOU) (  ((WALFAC(JX,          KARTEZ,IWSIDE),
     *                          JX=0,NDCOUL),KARTEZ=1,NDKART),
     *                          IWSIDE=0,1)
C
          END IF
C
      END IF
C
C=======================================================================
C
    1 CONTINUE
C
      CALL CPUTIM('RECOUL',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE POWALL(NUMCOU,NUMETA,BOUCOU)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          FOURIE(0:NDCOUL,1:NDNETA)
      DIMENSION
     *          POSTIO(NDKART)
      COMMON
     *       /WFACTO/ WALPOT(0:NDCOUL,0:NDCOUL,1:NDPOLS,1:NDKART,0:1),
     *                WALFAC(0:NDCOUL,                  1:NDKART,0:1)
      COMMON
     *       /LISMOM/ LISLAM(1:NDPOLS),LISMIU(1:NDPOLS),NUPOLS
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('POWALL',1)
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES FOURIER TRANSFORMS OF  THE  COULOMB
C         POTENTIAL ON THE WALLS OF PARALLELEPIPED.
C=======================================================================
C         THE LAST TWO INDICES OF THE "WALPOT" ARRAY  DENOTE ONE OF  THE
C         SIX WALLS ACCORDING TO THE FOLLOWING CONVENTION:
C
C         KARTEZ    IWSIDE       WALL
C         ------    ------     -----------
C            1         1       X =  BOUCOU / HOMSCA(1,1) / SQRT(2)
C            1         0       X = -BOUCOU / HOMSCA(1,1) / SQRT(2)
C            2         1       Y =  BOUCOU / HOMSCA(2,1) / SQRT(2)
C            2         0       Y = -BOUCOU / HOMSCA(2,1) / SQRT(2)
C            3         1       Z =  BOUCOU / HOMSCA(3,1) / SQRT(2)
C            3         0       Z = -BOUCOU / HOMSCA(3,1) / SQRT(2)
C
C        THE FIRST (SECOND) INDEX CORRESPONDS TO  THE FOURIER LABEL IN
C        THE "KARTEZ-2" ("KARTEZ-1") DIRECTION. IN THIS CONVENTION, +3
C        HAS TO BE ADDED TO THE DIRECTION NUMBER WHENEVER IT COMES OUT
C        AS A NON-POSITIVE INTEGER. THIS AMOUNTS TO:
C
C        KARTEZ     FIRST INDEX   SECOND INDEX   WALL
C        ------     -----------   ------------   ----
C           1       Y-DIRECTION    Z-DIRECTION     X
C           2       Z-DIRECTION    X-DIRECTION     Y
C           3       X-DIRECTION    Y-DIRECTION     Z
C
C        THE MIDDLE (THIRD) INDEX CORRESPONDS TO A GIVEN  MULTIPOLE. THE
C        LIST OF MULTIPOLES TAKEN INTO ACCOUNT AT BOUNDARIES IS PREPARED
C        IN THE SUBROUTINE "MULCOU" AND STORED IN ARRAYS:       "LISLAM"
C                                                           AND "LISMIU"
C
C        AT PRESENT, SIMPSON INTEGRATION RULE IS USED BUT WE SHOULD LOOK
C        FOR AN ANALYTICAL EXPRESSION.
C
C=======================================================================
C        CALCULATING THE LAPLACIAN EIGENFUNCTIONS AT INTEGRATION NODES
C=======================================================================
C
      SQ2   =SQRT(2.0000000D0)
      PI    =4.0D0*ATAN(1.0D0)
      STEPOM=PI/(2.0D0*BOUCOU)
C
C     NUMETA=2*(NUMCOU/2)-1
C
      STEPET=2.0D0*BOUCOU/(NUMETA+1)
C
      IF (NUMETA.GT.NDNETA) THEN
C
         WRITE(NFIPRI,'(//,1X,''NUMETA='',I2,'' .GT. NDNETA='',I2,
     *                         ''   STOP IN POWALL'',//)') NUMETA,NDNETA
         STOP ' NUMETA.GT.NDNETA  IN  POWALL'
C
      END IF
C
      IF (MOD(NUMETA,2).NE.1) THEN
C
         WRITE(NFIPRI,'(//,1X,''NUMETA='',I2,''  MUST BE ODD.'',
     *                         ''   STOP IN POWALL'',//)') NUMETA
         STOP ' NUMETA IS EVEN  IN  POWALL'
C
      END IF
C
      DO IFOURI=0,NUMCOU
C
         XFOURI=STEPOM*(IFOURI+1)
C
         IF (MOD(IFOURI,2).EQ.0) THEN
C
            DO INDETA=1,NUMETA
               ETA=-BOUCOU+STEPET*INDETA
               FOURIE(IFOURI,INDETA)=COS(XFOURI*ETA)
            END DO
C
         ELSE
C
            DO INDETA=1,NUMETA
               ETA=-BOUCOU+STEPET*INDETA
               FOURIE(IFOURI,INDETA)=SIN(XFOURI*ETA)
            END DO
C
         END IF
C
      END DO
C
C=======================================================================
C        CALCULATING THE FOURIER INTEGRALS
C=======================================================================
C        LOOP OVER CARTESIAN DIRECTIONS
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         KARTEX=KARTEZ-2
         IF (KARTEX.LE.0) KARTEX=KARTEX+3
C
         KARTEY=KARTEZ-1
         IF (KARTEY.LE.0) KARTEY=KARTEY+3
C
C=======================================================================
C        LOOP OVER SIDES OF THE PARALLELEPIPED
C=======================================================================
C
         DO IWSIDE=0,1
C
            POSTIO(KARTEZ)=(2*IWSIDE-1) * BOUCOU / HOMSCA(KARTEZ,1) /SQ2
C
C=======================================================================
C           LOOP OVER MULTIPOLES
C=======================================================================
C
            DO MULPOL=1,NUPOLS
C
               LAMBDA=LISLAM(MULPOL)
               MIU   =LISMIU(MULPOL)
C
C=======================================================================
C             ZEROING MATRICES OF FOURIER TRANSFORMS
C=======================================================================
C
               DO JX = 0,NUMCOU
                  DO JY = 0,NUMCOU
C
                     WALPOT(JX,JY,MULPOL,KARTEZ,IWSIDE) = 0.0D0
C
                  END DO
               END DO
C
C=======================================================================
C              LOOPS OVER TWO-DIMENSIONAL POSITIONS ON THE WALL
C=======================================================================
C
               DO INDETX=1,NUMETA
C
                  SIMPSX=2*(MOD(INDETX,2)+1)/3.0D0
                  ETA=-BOUCOU+STEPET*INDETX
                  POSTIO(KARTEX)=ETA / HOMSCA(KARTEX,1) / SQ2
C
                  DO INDETY=1,NUMETA
C
                     SIMPSY=2*(MOD(INDETY,2)+1)/3.0D0
                     ETA=-BOUCOU+STEPET*INDETY
                     POSTIO(KARTEY)=ETA / HOMSCA(KARTEY,1) / SQ2
C
C=======================================================================
C         CALCULATING THE  SOLID HARMONICS  AT THE GIVEN POSITION ON THE
C         GIVEN WALL. FOR  NON-NEGATIVE  (NEGATIVE) VALUES OF  "MIU"  WE
C         CALCULATE THE REAL (IMAGINARY)  PARTS OF THE  SOLID  HARMONICS
C         FOR NIU=IABS(MIU).
C=======================================================================
C
                     IF (MIU.GE.0) THEN
C
                         IMAREA=+1
                         NIU   = MIU
                     ELSE
                         IMAREA=-1
                         NIU   =-MIU
C
                     END IF
C
                     CALL SOLHAR(REHARM,LAMBDA,NIU,POSTIO,IMAREA)
C
C=======================================================================
C         CALCULATING THE COULOMB POTENTIAL AT THE GIVEN POSITION ON THE
C         GIVEN WALL AND CORRESPONDING TO THE GIVEN MULTIPOLE  COMPONENT
C=======================================================================
C
                     DISWAL=SQRT(   POSTIO(1)**2
     *                            + POSTIO(2)**2
     *                            + POSTIO(3)**2 )
C
                     REHARM=REHARM/DISWAL**LAMBDA
C
                     POTWAL = 4.0*PI * REHARM
     *                               / DISWAL**(LAMBDA+1) / (2*LAMBDA+1)
C
                     POTWAL = SIMPSX * SIMPSY * POTWAL
C
C=======================================================================
C                    LOOPS OVER TWO FOURIER INDICES ON THE WALL
C=======================================================================
C
                     DO JX = 0,NUMCOU
                        DO JY = 0,NUMCOU
C
                           WALPOT(JX,JY,MULPOL,KARTEZ,IWSIDE) =
     *                     WALPOT(JX,JY,MULPOL,KARTEZ,IWSIDE)
     *
     *                                    +  POTWAL *  FOURIE(JX,INDETX)
     *                                              *  FOURIE(JY,INDETY)
                        END DO
                     END DO
C
C=======================================================================
C                   END LOOPS OVER TWO-DIMENSIONAL POSITIONS ON THE WALL
C=======================================================================
C
                  END DO
               END DO
C
C=======================================================================
C              NORMALIZING FOURIER INTEGRALS
C=======================================================================
C
               FACTOR =      ((2*BOUCOU)/(NUMETA+1))**2 /
     *                  ( 4*BOUCOU *SQRT(HOMSCA(KARTEX,1)
     *                                *HOMSCA(KARTEY,1)))
C
               DO JX = 0,NUMCOU
                  DO JY = 0,NUMCOU
C
                     WALPOT(JX,JY,MULPOL,KARTEZ,IWSIDE) =
     *               WALPOT(JX,JY,MULPOL,KARTEZ,IWSIDE) * FACTOR
C
                  END DO
               END DO
C
C=======================================================================
C              END LOOP OVER MULTIPOLES
C=======================================================================
C
            END DO
C
C=======================================================================
C           CALCULATING FACTORS WHICH DEPEND ON WALLS
C=======================================================================
C
            FACTOR=SQRT(HOMSCA(KARTEZ,1)**3)
C
            DO JZ = 0,NUMCOU
C
               RESULT = FACTOR * (JZ+1) * (-1)**(JZ/2)
C
               IF (IWSIDE.EQ.0.AND.MOD(JZ,2).EQ.1) RESULT=- RESULT
C
               WALFAC(JZ,KARTEZ,IWSIDE)=RESULT
C
            END DO
C
C=======================================================================
C           END LOOPS OVER DIRECTIONS AND SIDES
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('POWALL',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFCOU(NOSCIL,NUMCOU,BOUCOU)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          PHERMI(ND2MAX+1),DHERMI(ND2MAX+1)
C
      COMMON
     *       /FACHER/ HERFAC(0:ND2MAX)
      COMMON
     *       /BFACTO/ BFOURI(0:NDCOUL,0:ND2MAX)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE FOURIER INTEGRATION AUXILIARY
C         B-FACTORS (SEE NOTES)
C=======================================================================
C
      IF (NUMCOU.GT.NDCOUL) THEN
C
         WRITE(NFIPRI,'(//,1X,''NUMCOU='',I2,'' .GT. NDCOUL='',I2,
     *                         ''   STOP IN DEFCOU'',//)') NUMCOU,NDCOUL
         STOP ' NUMCOU.GT.NDCOUL  IN  DEFCOU'
C
      END IF
C
C=======================================================================
C        DEFINING THE VALUES OF THE HERMITE POLYNOMIALS AT FOURIER
C        INTEGRATION POINTS
C=======================================================================
C
      NMAIN2=2*NOSCIL
C
      PI   =4.0D0*ATAN(1.0D0)
      SQ2PI=SQRT(2.0D0*PI)
      STEP =PI/(2.0D0*BOUCOU)
C
      DO IFOURI = 0,NUMCOU
C
         XFOURI = STEP * (IFOURI+1)
C
         CALL D_HERM(XFOURI,NMAIN2,PHERMI,DHERMI,ND2MAX+1)
C
         IPTCOU=MOD(IFOURI,2)
C
         DO KOSCIL = 0,NMAIN2
C
            IF (MOD(KOSCIL,2).EQ.IPTCOU) THEN
C
               BFOURI(IFOURI,KOSCIL) = PHERMI(KOSCIL+1)/HERFAC(KOSCIL)
     *                               * EXP(-XFOURI*XFOURI/2.0D0)
     *                               * (-1)**(KOSCIL/2)
     *                               * SQ2PI
            ELSE
C
               BFOURI(IFOURI,KOSCIL) = 0.0D0
C
            END IF
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEVMUL(NOSACT,NGAUSS,KARTEZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEDER/ CODERI(1:NDDERI,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COESCA/ COSCAL(1:NDSCAL,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEMAG/ COGRAD(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /HERMEM/ HERONE(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /DIVMEM/ DHRONE(0:ND2MAX,1:NDGAUS,1:NDKART),
     *                DDHONE(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /INTMEM/ TWOWGT(1:NDGAUS,1:NDKART),
     *                TWOPNT(1:NDGAUS,1:NDKART)
      COMMON
     *       /POWNMU/ NMUPOW
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
C=======================================================================
C
C         THIS ROUTINE PERFORMS INTEGRATION OF THE MATRIX  ELEMENTS
C         OF POWERS OF POSITION VARIABLES WITH  HERMITE POLYNOMIALS
C
C         INT DX  H (N,X)  *  X**K  *  H  (M,X)   =   COMULT(K,N,M)
C
C         IT ALSO      PERFORMS INTEGRATION OF THE MATRIX  ELEMENTS
C         OF POWERS OF GRADIENT OPERATORS WITH  HERMITE POLYNOMIALS
C
C         INT DX  H (N,X)  *  D**K  *  H  (M,X)   =   CODERI(K,N,M)
C
C         IT ALSO      PERFORMS INTEGRATION OF THE MATRIX  ELEMENTS
C         OF POWERS OF SCALING  OPERATORS WITH  HERMITE POLYNOMIALS
C
C         INT DX  H (N,X)  *(X*D)**K*  H  (M,X)   =   COSCAL(K,N,M)
C
C         IT ALSO      PERFORMS INTEGRATION OF THE MATRIX  ELEMENTS
C         OF POWERS OF POSITIONS*GRADIENT WITH  HERMITE POLYNOMIALS
C
C         INT DX  H (N,X)  *(X**K)*D*  H  (M,X)   =   COGRAD(K,N,M)
C
C         WHERE:
C
C         H(N,X) IS THE HERMITE POLYNOMIAL OF THE ORDER  N AT POINT
C                   X ASSUMED TO BE NORMALIZED TO 1 WHEN ITS SQUARE
C                   IS INTEGRATED WITH EXP(-X**2).
C
C         NOSACT IS THE MAXIMUM ORDER OF  THE  HERMITE  POLYNOMIALS
C                   USED IN THE CODE.
C
C         H(N,X) HAS THE MAXIMUM ORDER = NOSACT
C
C         THE COEFFICIENTS  COMULT  ARE FOUND BY EXPLICIT  NUMERICAL
C                        G A U S S - H E R M I T E
C         INTEGRATION OF PRODUCTS APPEARING IN THE ABOVE INTEGRANDS.
C         THE ONE-BODY INTEGRATION WEIGHTS AND POINTS ARE USED.
C
C=======================================================================
C
      IF (NMUPOW.GT.NDMULT) STOP ' INCREASE NDMULT IN DEVMUL'
C
C=======================================================================
C        INTEGRATION OF POWERS OF POSITIONS
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=0,NMUPOW
C
               RESULT=0.0D0
C
               DO IGAUSS=1,NGAUSS
C
                  RESULT=RESULT+  TWOWGT(IGAUSS,KARTEZ)
     *                         *HERONE(N,IGAUSS,KARTEZ)
     *                         *HERONE(M,IGAUSS,KARTEZ)
     *                         *  TWOPNT(IGAUSS,KARTEZ)**K
C
               END DO
C
               COMULT(K,N,M,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        INTEGRATION OF POWERS OF GRADIENTS
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            RESULT=0.0D0
C
            DO IGAUSS=1,NGAUSS
C
               RESULT=RESULT+  TWOWGT(IGAUSS,KARTEZ)
     *                      *HERONE(N,IGAUSS,KARTEZ)
     *                      *DHRONE(M,IGAUSS,KARTEZ)
C
            END DO
C
            CODERI(1,N,M,KARTEZ)=RESULT
C
            RESULT=0.0D0
C
            DO IGAUSS=1,NGAUSS
C
               RESULT=RESULT+  TWOWGT(IGAUSS,KARTEZ)
     *                      *HERONE(N,IGAUSS,KARTEZ)
     *                      *DDHONE(M,IGAUSS,KARTEZ)
C
            END DO
C
            CODERI(2,N,M,KARTEZ)=RESULT
C
         END DO
      END DO
C
C=======================================================================
C        INTEGRATION OF POWERS OF SCALING OPERATORS
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            RESULT=0.0D0
C
            DO IGAUSS=1,NGAUSS
C
               RESULT=RESULT+  TWOWGT(IGAUSS,KARTEZ)
     *                      *HERONE(N,IGAUSS,KARTEZ)
     *                      *DHRONE(M,IGAUSS,KARTEZ)
     *                      *  TWOPNT(IGAUSS,KARTEZ)
C
            END DO
C
            COSCAL(1,N,M,KARTEZ)=RESULT
C
         END DO
      END DO
C
C=======================================================================
C        INTEGRATION OF POWERS OF POSITIONS TIMES GRADIENT
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=0,NMUPOW
C
               RESULT=0.0D0
C
               DO IGAUSS=1,NGAUSS
C
                  RESULT=RESULT+  TWOWGT(IGAUSS,KARTEZ)
     *                         *HERONE(N,IGAUSS,KARTEZ)
     *                         *DHRONE(M,IGAUSS,KARTEZ)
     *                         *  TWOPNT(IGAUSS,KARTEZ)**K
C
               END DO
C
               COGRAD(K,N,M,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C       THE CODE USES  UNDIMENSIONED  POSITION  VARIABLES.
C       THEREFORE, THE COEFFICIENTS COMULT ARE HERE SCALED
C       BY APPROPRIATE  FACTORS WHICH  TAKE  INTO  ACCOUNT
C       THESE  DIMENSIONS.  THEREFORE, THESE  COEFFICIENTS
C       CONTAIN DIMENSIONED MATRIX  ELEMENTS  OF  POSITION
C       VARIABLES.  SIMILARLY,  THE  COEFFICIENTS   CODERI
C       CONTAIN DIMENSIONED MATRIX ELEMENTS OF  GRADIENTS,
C       BECAUSE IN DEFINT THE DHRONE  AND  DDHONE   ARRAYS
C       HAVE BEEN MULTIPLIED BY THE  APPROPRIATE  FACTORS.
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=0,NMUPOW
C
               COMULT(K,N,M,KARTEZ)=COMULT(K,N,M,KARTEZ)
     *                                   /HOMSCA(KARTEZ,1)**K
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            COSCAL(1,N,M,KARTEZ)=COSCAL(1,N,M,KARTEZ)
     *                                /HOMSCA(KARTEZ,1)
C
         END DO
      END DO
C
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=0,NMUPOW
C
               COGRAD(K,N,M,KARTEZ)=COGRAD(K,N,M,KARTEZ)
     *                                   /HOMSCA(KARTEZ,1)**K
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ADJBAS(FCHOM0,IN_FIX,IZ_FIX)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
C
      DATA
     *        HBOM00 / 41.0 /
C
C=======================================================================
C
C            AUTOMATIC ADJUSTMENT OF BASIS CHARACTERISTICS
C
C      N.B. CURRENT VALUES ARE VERY PRIMITIVE AND ARE *NOT* BASED ON A
C           RIGOROUS BASIS STUDY BUT INSTEAD OF SOME PRE-COOKED FORMULA
C           WITH ASSUMED CORRECT ASYMPTOTICS... (SCHUNCK, 28/04/2011)
C
C=======================================================================
C
      Q2_VAL=QASKED(2,0)
C
C       This value comes from Javid. Sheikh
C      OMEGA0=0.08177491*EXP(-0.02256042*Q2_VAL)*(Q2_VAL-1.71901348)
C     *      +7.16688268
C
C      Cut-off: if the requested deformation is too weak we keep omega
C               at the value for Q2=30 barns,
C                  omega0 = 8.1464 = 0.1*EXP(-0.02*30)*30+6.5
C
      IF (ABS(Q2_VAL).GT.30.0) THEN
          OMEGA0=0.1*EXP(-0.02*Q2_VAL)*Q2_VAL+6.5
      ELSE
          OMEGA0=8.1464
      END IF
C
      A_MASS=REAL(IZ_FIX+IN_FIX)
      FCHOM0=OMEGA0 / (41.0/(A_MASS**(1.0/3.0)))
C
      DO LAMBDA=0,NDLAMB
         DO MIU=0,NDLAMB
            ALPHAR(LAMBDA,MIU)=0.0
         END DO
      END DO
C
C       This value comes from Javid. Sheikh
C      ALPHAR(2,0)=0.05306369*SQRT(Q2_VAL)
C
      ALPHAR(2,0)=0.05*SQRT(Q2_VAL)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      FUNCTION CVOLFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      CVOLFN=R**3*SIN(THETA)
C
      RETURN
      END
C
      FUNCTION ZMASFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      ZMASFN=R**4*SIN(THETA)*COS(THETA)
C
      RETURN
      END
C
      FUNCTION YMASFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      YMASFN=R**4*SIN(THETA)**2*SIN(PHI)
C
      RETURN
      END
C
      FUNCTION XMASFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      XMASFN=R**4*SIN(THETA)**2*COS(PHI)
C
      RETURN
      END
C
      FUNCTION BASZFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      BASZFN=R**5*COS(THETA)**2*SIN(THETA)
C
      RETURN
      END
C
      FUNCTION BASYFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      BASYFN=R**5*SIN(THETA)**3*SIN(PHI)**2
C
      RETURN
      END
C
      FUNCTION BASXFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      BASXFN=R**5*SIN(THETA)**3*COS(PHI)**2
C
      RETURN
      END
C
      FUNCTION ZMOMFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      ZMOMFN=R**5*SIN(THETA)**3
C
      RETURN
      END
C
      FUNCTION YMOMFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      YMOMFN=R**5*(SIN(THETA)**2*COS(PHI)**2+COS(THETA)**2)*SIN(THETA)
C
      RETURN
      END
C
      FUNCTION XMOMFN(THETA,PHI)
C
      CALL FORMFN(THETA,PHI,R)
C
      XMOMFN=R**5*(SIN(THETA)**2*SIN(PHI)**2+COS(THETA)**2)*SIN(THETA)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FORMFN(THETA,PHI,RESULT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          ALPHAC(0:NDLAMB,-NDLAMB:+NDLAMB)
      COMPLEX
     *          F
      COMPLEX
     *          YLM  (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMT (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMF (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMTT(0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMTF(0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMFF(0:NDLAMB,-NDLAMB:+NDLAMB)
C
      COMMON
     *       /ALINFO/ LAMACT(0:NDLAMB),MIUACT(0:NDLAMB,-NDLAMB:+NDLAMB)
      COMMON
     *       /YLDERI/ YLM,YLMT,YLMF,YLMTT,YLMTF,YLMFF
      COMMON
     *       /DEFORM/ ALPHAC,IREALA
      COMMON
     *       /LIMITL/ LAMMAX,NMUCON
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE FORM-FUNCTION =(1+SUM ALFA*Y)
C=======================================================================
C
      LEVEL=0
C
      CALL ZEROYL(YLM,YLMT,YLMF,YLMTT,YLMTF,YLMFF,LAMMAX,LEVEL)
C
      DO LAMBDA=0,LAMMAX
C
         IF (LAMACT(LAMBDA).LT.0) GO TO 1
C
         DO MIU=0,LAMBDA
C
            IF (MIUACT(LAMBDA,MIU).LT.-99) GO TO 2
C
            CALL YL_MIU(YLM,YLMT,YLMF,YLMTT,YLMTF,YLMFF,
     *                       LAMBDA,MIU,THETA,PHI,LEVEL)
   2        CONTINUE
C
         END DO
   1     CONTINUE
      END DO
C
      F=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C         S U M M I N G    U P   T H E   ALPHA* TIMES YLM  T E R M S
C=======================================================================
C
      DO LAMBDA=0,LAMMAX
         DO MIU=-LAMBDA,+LAMBDA
C
            F=F+CONJG(ALPHAC(LAMBDA,MIU))*YLM(LAMBDA,MIU)
C
         END DO
      END DO
C
      RESULT=1.0D0+REAL(F)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GEOMFR(R0PARM,CMSXFC,CMSYFC,CMSZFC,
     *                  CVOLFC,XMOMFC,YMOMFC,ZMOMFC,
     *                  HOMEGA,BASEX2,BASEY2,BASEZ2,
     *                                INNUMB,IZNUMB,
     *                                N1POIN,N2POIN,
     *                                       LAMMAX,
     *                  ITWCEN,LTWCEN,IFRANE,IFRAPR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      EXTERNAL
     *         CVOLFN,XMASFN,YMASFN,ZMASFN,BASXFN,BASYFN,BASZFN,
     *                                     XMOMFN,YMOMFN,ZMOMFN
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
      COMMON
     *       /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME
      COMMON
     *       /HOMTWC/ HOMEG2(1:NDTWCE)

CLP@
        common /limitl/ lamaux,nmucon
        dimension exalf(1:ndmult,-ndmult:ndmult)
        dimension rco(1:3), rco2(1:3)
        dimension parmul(0:ndmult,-ndmult:ndmult)


C
C=======================================================================
C
C         THIS SUBROUTINE CALCULATES THE GEOMETRICAL AUXILIARY FACTORS
C
C         1. CVOLFC - VOLUME CONSERVATION FACTOR
C
C         2. CMSXFC - POSITION OF THE CENTER OF MASS  (X - PROJECTION)
C         3. CMSYFC - POSITION OF THE CENTER OF MASS  (Y - PROJECTION)
C         4. CMSZFC - POSITION OF THE CENTER OF MASS  (Z - PROJECTION)
C
C         5. XMOMFC - MOMENT OF INERTIA  WITH RESPECT  TO  X - A X I S
C         6. YMOMFC - MOMENT OF INERTIA  WITH RESPECT  TO  Y - A X I S
C         7. ZMOMFC - MOMENT OF INERTIA  WITH RESPECT  TO  Z - A X I S
C
C         8. BASEX2 - THE BASIS S T R E T C H I N G FACTOR X - A X I S
C         9. BASEY2 - THE BASIS S T R E T C H I N G FACTOR Y - A X I S
C        10. BASEZ2 - THE BASIS S T R E T C H I N G FACTOR Z - A X I S
C
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
      VOLUM0=4.0D0/3.0D0*PI*R0PARM**3*REAL(IZNUMB+INNUMB)
C
      XMASS0=REAL(IZNUMB)*XMASSP+REAL(INNUMB)*XMASSN
C
      RADIUS=R0PARM*REAL(IZNUMB+INNUMB)**(1.0D0/3.0D0)
C
      IF (ITWCEN.EQ.2) THEN
C
          VOLUM0=4.0D0/3.0D0*PI*R0PARM**3*(IFRAPR+IFRANE)
C
          XMASS0=IFRAPR*XMASSP+IFRANE*XMASSN
C
          RADIUS=R0PARM*(IFRAPR+IFRANE)**(1.0D0/3.0D0)
C
      END IF
C
      DENS0 =XMASS0/VOLUM0/H_BARC**2
C
C=======================================================================
C
      XLOW=0.0D0
      YLOW=0.0D0
C
      XUPP=PI
      YUPP=2.0D0*PI
C
C=======================================================================
C         C O N S T A N T      V O L U M E      C O N D I T I O N
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,CVOLFN,RESULT)
C
      F=RESULT/4.0D0/PI
C
      CVOLFC=1.0D0/F**(1.0D0/3.0D0)
C
C=======================================================================
C         C E N T R E   O F   M A S S   ( C O O R D I N A T E   X)
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,XMASFN,RESCMX)
C
      CMSXFC=0.25D0*(CVOLFC*RADIUS)**4/VOLUM0*RESCMX
C
C=======================================================================
C         C E N T R E   O F   M A S S   ( C O O R D I N A T E   Y)
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,YMASFN,RESCMY)
C
      CMSYFC=0.25D0*(CVOLFC*RADIUS)**4/VOLUM0*RESCMY
C
C=======================================================================
C         C E N T R E   O F   M A S S   ( C O O R D I N A T E   Z)
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,ZMASFN,RESCMZ)
C
      CMSZFC=0.25D0*(CVOLFC*RADIUS)**4/VOLUM0*RESCMZ
C
C=======================================================================
C         BASIS:  X - S T R E T C H I N G   C O E F F I C I E N T
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,BASXFN,RESBX2)
C
      BASEX2=(CVOLFC*RADIUS)**5/VOLUM0/5.0D0*RESBX2
C
C=======================================================================
C         BASIS:  X - S T R E T C H I N G   C O E F F I C I E N T
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,BASYFN,RESBY2)
C
      BASEY2=(CVOLFC*RADIUS)**5/VOLUM0/5.0D0*RESBY2
C
C=======================================================================
C         BASIS:  X - S T R E T C H I N G   C O E F F I C I E N T
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,BASZFN,RESBZ2)
C
      BASEZ2=(CVOLFC*RADIUS)**5/VOLUM0/5.0D0*RESBZ2
C
C=======================================================================
C         T H E   M O M E N T   O F   I N E R T I A  (COMPONENT X)
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,XMOMFN,RESXMT)
C
      XMOMFC=DENS0*(CVOLFC*RADIUS)**5/5.0D0*RESXMT
C
C=======================================================================
C         T H E   M O M E N T   O F   I N E R T I A  (COMPONENT Y)
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,YMOMFN,RESYMT)
C
      YMOMFC=DENS0*(CVOLFC*RADIUS)**5/5.0D0*RESYMT
C
C=======================================================================
C         T H E   M O M E N T   O F   I N E R T I A  (COMPONENT Z)
C=======================================================================
C
      CALL Q2GAUS(N1POIN,N2POIN,XLOW,XUPP,YLOW,YUPP,ZMOMFN,RESZMT)
C
      ZMOMFC=DENS0*(CVOLFC*RADIUS)**5/5.0D0*RESZMT
C
C=======================================================================
C         CALCULATING THE H_BAR*OMEGA FACTORS FOR THE HO BASIS
C=======================================================================
C
      RXY=SQRT(BASEX2/BASEY2)
      RYZ=SQRT(BASEY2/BASEZ2)
      RXZ=SQRT(BASEX2/BASEZ2)
C
      IF (ITWCEN.EQ.1) THEN
C
          HBAROX(1)=HOMEGA*(RXY*RXZ)**(-1.0D0/3.0D0)
          HBAROY(1)=HOMEGA*(RXY/RYZ)**(+1.0D0/3.0D0)
          HBAROZ(1)=HOMEGA*(RXZ*RYZ)**(+1.0D0/3.0D0)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          HBAROX(LTWCEN)=HOMEG2(LTWCEN)*(RXY*RXZ)**(-1.0D0/3.0D0)
          HBAROY(LTWCEN)=HOMEG2(LTWCEN)*(RXY/RYZ)**(+1.0D0/3.0D0)
          HBAROZ(LTWCEN)=HOMEG2(LTWCEN)*(RXZ*RYZ)**(+1.0D0/3.0D0)
C
      END IF
C
      IF (LAMMAX.EQ.0) THEN
C
          HBAROY(LTWCEN)=HBAROX(LTWCEN)
          HBAROZ(LTWCEN)=HBAROX(LTWCEN)
C
      END IF
C
      IF (INPOME.EQ.1) THEN
C
          HBAROX(LTWCEN)=BASINX(LTWCEN)
          HBAROY(LTWCEN)=BASINY(LTWCEN)
          HBAROZ(LTWCEN)=BASINZ(LTWCEN)
C
      END IF
C
      IF (INPOME.EQ.2) THEN
C
          HBAROX(1)=(H_BARC/BASINX(1))**2/XMASSN
          HBAROY(1)=(H_BARC/BASINY(1))**2/XMASSN
          HBAROZ(1)=(H_BARC/BASINZ(1))**2/XMASSN
C
      END IF
C
      IF (INPOME.EQ.3) THEN
C
          HBAROX(1)=(H_BARC*BASINX(1))**2/XMASSN
          HBAROY(1)=(H_BARC*BASINY(1))**2/XMASSN
          HBAROZ(1)=(H_BARC*BASINZ(1))**2/XMASSN
C
      END IF
C
C=======================================================================
C         HERE IS THE IMPLEMENTATION OF THE OSCILLATOR LENGTHS FROM THE
C         MARKUS CODE, SEE HIS EMAIL OF 22/03/2019 10:29
C=======================================================================
C
      IF (INPOME.EQ.4) THEN
C
          OscLenHbar2M = 20.73553
          OscLenRad = 1.2
          OscLenFreq = 41.0
C
          fm = OscLenFreq * OscLenRad *
     *                    (REAL(IZNUMB+INNUMB)**(-0.333333333333333333))
C
          alength=sqrt( 2.0 * OscLenHbar2M / fm)
C
          xlength=alength*EXP(SQRT(5.0D0/4.0D0/PI)*ALPHAR(2,0)/(-2.0D0))
          ylength=alength*EXP(SQRT(5.0D0/4.0D0/PI)*ALPHAR(2,0)/(-2.0D0))
          zlength=alength*EXP(SQRT(5.0D0/4.0D0/PI)*ALPHAR(2,0)         )
C
          HBAROX(1)=(H_BARC/xlength)**2/XMASSN
          HBAROY(1)=(H_BARC/ylength)**2/XMASSN
          HBAROZ(1)=(H_BARC/zlength)**2/XMASSN
C
      END IF
C
      IF (INPOME.EQ.5) THEN
CLP@
          call proprxyz(R0PARM,IZNUMB,INNUMB,ax,ay,az)
          RXY=ax/ay
          RYZ=ay/az
          RXZ=ax/az
C
          HBAROX(1)=HOMEGA*(RXY*RXZ)**(-1.0D0/3.0D0)
          HBAROY(1)=HOMEGA*(RXY/RYZ)**(+1.0D0/3.0D0)
          HBAROZ(1)=HOMEGA*(RXZ*RYZ)**(+1.0D0/3.0D0)
CLP@
      END IF
CLP@  Here only alphar(2,0) and alphar(2,2) are taken into account

      IF (INPOME.EQ.6) THEN
                beta=sqrt(alphar(2,0)**2+2.d0*alphar(2,2)**2)
                gamma=atan2(sqrt(2.d0)*alphar(2,2),alphar(2,0))
                ff=sqrt(5.d0/(4.d0*pi))
                pi23=2.d0*pi/3.d0
                hbarox(1)=homega*exp(-ff*beta*cos(gamma-pi23))
                hbaroy(1)=homega*exp(-ff*beta*cos(gamma+pi23))
                hbaroz(1)=homega*exp(-ff*beta*cos(gamma))
      END IF

CLP@    A surface R(1+alf*Y) is constructed from multipole moments
CLP@  (not only quadrupole ones)  and then we follow the method
CLP@    of the case INPOME=0, i.e. <x_k^2> are calculated


        if (INPOME.eq.7) then

        lamx=nmucon

CLP@  Calling loadin is not necessary if LOADIN is called already
CLP@  in GEOMFC
        call loadin(lamx)

      aa=real(iznumb+innumb)
        call qasktoalf(lamx,radius,aa,ierror,exalf,exarad,exaden)

        densunit=1.d0

      CALL BOHINT(lamx,densunit,exarad,exalf,parsur,parmul)
        call frombohi(parsur,parmul,vol,rco,rco2)

        if (ierror.ne.0) then
                cvolfc=(volum0/vol)**(1./3.)
                cvf4=cvolfc**4
                cvf5=cvolfc*cvf4
                rco=rco*cvf4
                rco2=rco2*cvf5
        endif


        densre=1./volum0
        densmo=dens0/volum0

        CMSXFC=rco(1)*densre
        CMSYFC=rco(2)*densre
        CMSZFC=rco(3)*densre
      BASEX2=rco2(1)*densre
      BASEY2=rco2(2)*densre
      BASEZ2=rco2(3)*densre

      XMOMFC=(rco2(2)+rco2(3))*dens0
      YMOMFC=(rco2(1)+rco2(3))*dens0
      ZMOMFC=(rco2(1)+rco2(2))*dens0

                rx=sqrt(basex2)
                ry=sqrt(basey2)
                rz=sqrt(basez2)
                vp=(rx*ry*rz)**(1.d0/3.d0)

                hbarox(1)=homega*vp/rx
                hbaroy(1)=homega*vp/ry
                hbaroz(1)=homega*vp/rz
        endif

CLP@
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GEOMFC(INNUMB,IZNUMB,FCHOM0,R0PARM,HOMEGA,
     *                                LAMMAX,ISOTRO,CVOLFC,
     *                                CMSXFC,CMSYFC,CMSZFC,
     *                                XMOMFC,YMOMFC,ZMOMFC,
     *                                              ITWCEN)
C=======================================================================
      USE hfodd_sizes
      USE hfodd_twocen
C=======================================================================
      COMPLEX
     *          ALPHAC(0:NDLAMB,-NDLAMB:+NDLAMB)
C
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /BASE_2/ BASEX2,BASEY2,BASEZ2
      COMMON
     *       /DEFORM/ ALPHAC,IREALA
CLP@
      COMMON
     *       /LIMITL/ LAMAUX,NMUCON
CLP@
      COMMON
     *       /FRCONS/ FRGSTF(0:NDISOS,1:NDTWCE),
     *                FRGASK(0:NDISOS,1:NDTWCE),
     *                IFLFRG(0:NDISOS,1:NDTWCE),
     *                CLMFRA(0:NDISOS,1:NDTWCE),
     *                AVEFRA(0:NDISOS,1:NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /HOMTWC/ HOMEG2(1:NDTWCE)
      DATA
     *        HBOM00 / 41.0 /
C
C=======================================================================
C
C        THIS SUBROUTINE CALCULATES THE GEOMETRICAL FACTORS RELATED
C        TO THE  DEFINITION OF THE NUCLEAR SURFACE  IN TERMS OF THE
C        SPHERICAL HARMONICS AND DERIVES THE CORRESPONDING HARMONIC
C        OSCILLATOR FREQUENCIES
C
C        A) HBAROX,HBAROY,HBAROZ =>> DERIVED OSCILLATOR FREQUENCIES
C
C        B) CMSXFC,CMSYFC,CMSZFC =>> COORDINATES OF  CENTER OF MASS
C
C        C) XMOMFC,YMOMFC,ZMOMFC =>> CLASSICAL  MOMENTS  OF INERTIA
C
C=======================================================================
C
C        M E A N I N G  O F  S O M E  I N P U T  P A R A M E T E R S
C
C=======================================================================
C
C        A) THE NUCLEUS:
C
C        INNUMB, IZNUMB => THE N- AND THE Z-NUMBERS  OF  THE NUCLEUS
C                          FOR WHICH THE SURFACE IS DEFINED.
C
C        B) ITS DEFORMATION:
C
C        ALPHAR,        => A REAL  ARRAY  SPECIFYING THE NUCLEAR DE-
C                          FORMATIONS IN TERMS OF THE SPHERICAL HAR-
C                          MONICS. THE INTEGER PARAMETER "IREALA" IS
C                          EXPLICITLY SET TO  1  TO SPECIFY THAT THE
C                          DEFORMATIONS ARE REAL.
C
C        LAMMAX   => => => THE MAXIMUM MULTIPOLARITY  OF THE DEFORM.
C                          IN QUESTION (THE HIGHEST ORDER OF Y_LM'S)
C
C
C        C) THE RADIUS  P A R A M E T E R:
C
C        R0PARM   => => => THE RADIUS IS EQUAL TO R0PARM*A**(1/3) FM
C
C
C        D) PRECISION OF THE INTEGRATIONS IN GAUSS-LEGENDRE FORMULAS
C
C        N1POIN, N2POIN => THE NUMBER OF GAUSS INTEGRATION POINTS IN
C                          ONE (E.G.THETA) AND THE SECOND (E.G. PHI)
C                          DIRECTIONS
C
C=======================================================================
C
C        ATTENTION: IN THE WOODS - SAXON CALCULATIONS THE OSCILLATOR
C        FREQUENCIES ARE  CONVENIENTLY  MULTIPLIED  BY AN ADDITIONAL
C        FACTOR DENOTED
C                                 FCHOM0 ~ 1.20
C
C        WHICH ALLOWS TO DECREASE THE NUMBER OF THE  HO BASIS STATES.
C        THIS IS EQUIVALENT TO AN "AD HOC" OPTIMIZATION OF THE BASIS
C        WHICH MAY OR MAY NOT HAVE THE SAME MEANING IN THE H.F. CASE
C
C=======================================================================
C
      ZERO=0.0D0
C
      IFRAPR=0
      IFRANE=0
      HOMEG2=ZERO
C
      DO LTWCEN=1,ITWCEN
C
         IF (ITWCEN.EQ.1) THEN
C
             A_MASS=IZNUMB+INNUMB
C
         ELSEIF (ITWCEN.EQ.2) THEN
C
             CALL TWC_FRAGPAR(INNUMB,IZNUMB,LTWCEN,IFRAPR,IFRANE)
C
             A_MASS=REAL(IFRANE+IFRAPR)
C
         END IF
C
         HOMEGA        =HBOM00*FCHOM0/A_MASS**(1./3.)
         HOMEG2(LTWCEN)=HBOM00*FCHOM0/A_MASS**(1./3.)
C
         IREALA=1
C
         DO L=0,NDLAMB
            DO M=0,L
               ALPHAC(L, M)=        CMPLX(ALPHAR(L,M),ZERO)
               ALPHAC(L,-M)=(-1)**M*CMPLX(ALPHAR(L,M),ZERO)
            END DO
         END DO
C
         N1POIN=14
         N2POIN=14
C
C=======================================================================
C
         CALL LIMITY(ALPHAC,LAMMAX)
C
         IF (LAMMAX.GT.0) ISOTRO=0
         IF (LAMMAX.EQ.0) ISOTRO=1
C
C=======================================================================
C          ATTENTION: IN THIS SUBROUTINE LAMMAX VALUE IS TRANSFERRED
C                     INTO THE  COMMON BLOCK  UNDER THE NAME LAMAUX.
C                     THIS IS TO AVOID THE SAME VARIABLE NAME AS THE
C                     ONE APPEARING IN THE SUBROUTINE HEAD
C=======================================================================
C
         LAMAUX=LAMMAX
C
C=======================================================================
C
CLP@  Here we can define Ylm independently of INPOME option
CLP@    MAXLA=max(lammax,nmucon)
CLP@      CALL LOADIN(maxla)

         CALL LOADIN(LAMMAX)
C
C=======================================================================
C
CLP@
          CALL GEOMFR(R0PARM,CMSXFC,CMSYFC,CMSZFC,
     *            CVOLFC,XMOMFC,YMOMFC,ZMOMFC,
     *            HOMEGA,BASEX2,BASEY2,BASEZ2,
     *                          INNUMB,IZNUMB,
     *                          N1POIN,N2POIN,
     *                                 LAMMAX,
     *            ITWCEN,LTWCEN,IFRANE,IFRAPR)
C
      END DO
C
C=======================================================================
C         THE FOURTH AUXILIARY TABLE: ''ACTUAL RUN CONDITIONS''
C=======================================================================
C
CLP@
      CALL DEFPRIlp(LAMMAX,INNUMB,IZNUMB)
C
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *           1H*,43X,''HOMEGA='',F8.4,2X,''FCHOM0='',F8.4,2X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *          1H*, 2X,''OSCILLATOR FREQUENCIES:'',1X,
     *                                       ''HBAROX='',F8.4,2X,
     *                                       ''HBAROY='',F8.4,2X,
     *                                       ''HBAROZ='',F8.4,2X,1H*)')
     *
     *       HOMEGA,FCHOM0,HBAROX(1),HBAROY(1),HBAROZ(1)
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,2X,''MOMENTS OF INERTIA:   '',2X,
     *                                       ''XMOMFC='',F8.4,2X,
     *                                       ''YMOMFC='',F8.4,2X,
     *                                       ''ZMOMFC='',F8.4,2X,1H*)')
     *
     *                                             XMOMFC,YMOMFC,ZMOMFC
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,2X,''CENTERS OF MASS:   '',5X,
     *                                       ''CMSXFC='',F8.4,2X,
     *                                       ''CMSYFC='',F8.4,2X,
     *                                       ''CMSZFC='',F8.4,2X,1H*,/,
     *                                       1H*,77X,1H*,/,79(1H*),/)')
     *
     *                                             CMSXFC,CMSYFC,CMSZFC
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*, 2X,''OSC FREQ FIRST  CENTER:'',1X,
     *                                       ''HBAROX='',F8.4,2X,
     *                                       ''HBAROY='',F8.4,2X,
     *                                       ''HBAROZ='',F8.4,2X,1H*)')
     *
     *        HBAROX(1),HBAROY(1),HBAROZ(1)
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*, 2X,''OSC FREQ SECOND CENTER:'',1X,
     *                                       ''HBAROX='',F8.4,2X,
     *                                       ''HBAROY='',F8.4,2X,
     *                                       ''HBAROZ='',F8.4,2X,1H*)')
     *
     *        HBAROX(NDTWCE),HBAROY(NDTWCE),HBAROZ(NDTWCE)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
        SUBROUTINE DEFPRIlp(LAMMAX,INNUMB,IZNUMB)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PRIMOM(0:NDLAMB)*15
C
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE DEFORMATION PARAMETERS IN THE NUCLEAR
C       SURFACE FORMULA AS DEFINED TYPICALLY IN THE WOODS-SAXON PROGRAMS
C=======================================================================
C
      IF (INPOME.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,             1H*,77X,1H*,/,
     *          1H*,2X,''FREQUENCIES OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                          1H*,77X,1H*,/,79(1H*))')
          RETURN
C
      END IF
C
C
      IF (INPOME.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''THE LENGTHS OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          RETURN
C
      END IF
C
      IF (INPOME.EQ.3) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''THE CNSTNTS OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          RETURN
C
      END IF
C
      IF (INPOME.EQ.5) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''FREQUENCIES OF THE H-O BASIS HAVE BEEN '',
     *                 ''CALCULATED FROM QUADR. CONSTRAINTS'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          RETURN
C
      END IF


CLP@    Added printout for INPOME=6, with ALPHAR to be printed

      IF (INPOME.EQ.6) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''FREQUENCIES OF THE H-O BASIS HAVE BEEN '',
     *                 ''CALCULATED from alf_20 and alf_22 '',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
C          RETURN
C
      END IF

CLP@    Added printout for INPOME=7,  ALPHAR is not printed

      IF (INPOME.EQ.7) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''FREQUENCIES OF THE H-O BASIS HAVE BEEN '',
     *                 ''CALCULATED from mult. constraints '',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          RETURN
C
      END IF
C
      WRITE(NFIPRI,'(79(1H*),/,             1H*,77X,1H*,/,
     *             1H*,2X,''CLASSICAL NUCLEAR SURFACE DEFINED FOR:'',
     *             20X,''N ='',I3,3X,''Z ='',I3,2X,1H*,/,
     *                                    1H*,77X,1H*,/,79(1H*))')
     *
     *                                              INNUMB,IZNUMB
C
      DO MIU=0,NDLAMB
         PRIMOM(MIU)='  .............'
      END DO
C
      DO LAMBDA=1,MIN(LAMMAX,NDLAMB)
C
         DO MIU=0,LAMBDA
C
            IF (ABS(ALPHAR(LAMBDA,MIU)).LT.1.0E-10) THEN
C
                WRITE(PRIMOM(MIU),'(''  AL'',2I1,'' ='',3X,''ZERO'')')
     *                                                     LAMBDA,MIU
            ELSE
C
               IF (ABS(ALPHAR(LAMBDA,MIU)).LT.1.0E-3) THEN
C
                   WRITE(PRIMOM(MIU),'(''  AL'',2I1,'' ='',1PE7.0)')
     *                          LAMBDA,MIU,ALPHAR(LAMBDA,MIU)
               ELSE
C
                   WRITE(PRIMOM(MIU),'(''  AL'',2I1,'' ='',F7.3)')
     *                          LAMBDA,MIU,ALPHAR(LAMBDA,MIU)
               END IF
C
            END IF
C
            IF (PRIMOM(MIU)(11:12).EQ.' .') PRIMOM(MIU)(11:12)='0.'
C
         END DO
C
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,5A15,2X,1H*)')
     *                                             (PRIMOM(MIU),MIU=0,4)
C
         IF (LAMBDA.EQ.5)
     *   WRITE(NFIPRI,'(1H*,      60X,A15,2X,1H*)')
     *                                             (PRIMOM(MIU),MIU=5,5)
C
      END DO
C
      IF (LAMMAX.EQ.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                   1H*,2X,''SPHERICAL SHAPE REQUESTED FOR '',
     *                     ''THE SURFACE'',34X,1H*)')
C
      END IF
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
        subroutine qasktoalf(lamx,rad0,qa00,ierror,exalf,exarad,exaden)
CLP@    rr0,lamx,qa00 :: intent in
CLP@    ierrror, exalf, exarad :: intent out
CLP@  This routine calculates exarad and exalf() defining a surface
CLP@  r*(1+alfa*Y) from multipole moments given in QASKED()
CLP@  rad0 is a radius of an equivalent sphere (same density and vol)
CLP@  qa00 is A (mass number) to be put in a local copy of QASKED(0,0)
CLP@  lamx is maximal mulipolarity of QASKED() which is also equal to
CLP@  maximal multipolarity (lambda) of alpha()
CLP@  ierror=0 indicates that EXADEFlp has found a solution
CLP@  otherwise linear approximation is used
      USE hfodd_sizes

      COMMON /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     &                QASKED(0:NDMULT,-NDMULT:NDMULT),
     &                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)


        dimension exalf(1:ndmult,-ndmult:ndmult)
        dimension qaskloc(0:ndmult,-ndmult:ndmult)
        dimension qunl(0:ndmult,-ndmult:ndmult)

CLP@  Units for multipole moments
        qunl=1.d0
        pi=4.d0*atan(1.d0)
        sq4pi=sqrt(4.d0*pi)
        sq2=sqrt(2.d0)
        sq3=sqrt(3.d0)
        sq5=sqrt(5.d0)
        qunl(0,0)=+sq4pi
      qunl(1,0)=+sq4pi/sq3
      qunl(1,1)=-sq4pi/sq3*sq2
      qunl(2,0)=+sq4pi/sq5*2.d0
      qunl(2,1)=-sq4pi/(sq3*sq5)*sq2
      qunl(2,2)=+sq4pi/sq5*2.d0*sq2
      do lambda=0,lamx
         f10=10.d0**lambda
         do miu=0,lambda
            qunl(lambda,miu)=qunl(lambda,miu)/f10
         end do
      end do


CLP@    qaskloc is a local copy of QASKED
CJD@    qaskloc=qasked
        QASKLOC=0.0D0
        DO LAMBDA=1,NDMULT
           DO MIU=-LAMBDA,LAMBDA
              IF (IABS(IFLAGQ(LAMBDA,MIU)).EQ.1)
     *                QASKLOC(LAMBDA,MIU)=QASKED(LAMBDA,MIU)
           END DO
        END DO
CJD@
        qaskloc(0,0)=qa00

        rr0=sqrt(0.6d0*rad0**2)
        call mult2alf(lamx,ierror,rr0,qaskloc,qunl,exaden,exarad,
     &                  exalf)

        if (ierror.ne.0) then
CLP@  approximate (linear) alphas

        exarad=rad0
        fact=3.d0*qa00/(4.d0*pi)*rad0
      do lam=1,lamx
         do miu=-lam,lam
            exalf(lam,miu)=qaskloc(lam,miu)/(fact*qunl(lam,iabs(miu)))
           enddo
         fact=fact*rad0
        enddo
        endif

        end subroutine qasktoalf
C
C=======================================================================
C
      SUBROUTINE mult2alf(NEXBET,IERROR,DATRMS,QMOMUL,qunl,
     *                         EXADEN,EXARAD,EXABET)
CLP@    Density EXADEN kept fixed
CLP@  Condition on PARSUR removed
CLP@  see also comments CLP@ below
CLP@  New argument: qunl - array of units of mulitpoles
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT),
     *          ASKMUL(0:NDMULT,-NDMULT:NDMULT),
     *          PARMUL(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          EXABET(1:NDMULT,-NDMULT:NDMULT)
C
        dimension qunl(0:NDMULT,-NDMULT:NDMULT)
C
C=======================================================================
C THIS SUBROUTINE FINDS THE BOHR DEFORMATION PARAMETERS
C=======================================================================
C
      PI=4.D0*ATAN(1.D0)
      SQR4PI=SQRT(16.D0*ATAN(1.D0))
C
C=======================================================================
C REMOVING UNITS
C=======================================================================
C
      DO LAM=0,NEXBET
         DO MIU=-LAM,LAM
            ASKMUL(LAM,MIU)=QMOMUL(LAM,MIU)/qunl(LAM,IABS(MIU))
         END DO
      END DO
C
      ASKSUR=SQR4PI*ASKMUL(0,0)*DATRMS**2
      ASKRAD=SQRT(5.*ASKSUR/(3.*SQR4PI*ASKMUL(0,0)))
      ASKDEN=3*ASKMUL(0,0)/(SQR4PI*ASKRAD**3)
C
C=======================================================================
C SETTING INITIAL BETAS
C=======================================================================
C
      EXADEN=ASKDEN
      EXARAD=ASKRAD
      EXASUR=4.*PI*EXADEN*EXARAD**5/5.
      EXAQ00=SQR4PI*EXADEN*EXARAD**3/3.

      DO LAM=1,NEXBET
         DO MIU=-LAM,LAM
            EXABET(LAM,MIU)=0.
         END DO
      END DO
C
      EPS=0.01
      OLDCHI=0.
      ITERAT=0

C
    1 CONTINUE
C
C=======================================================================
C INTEGRATING MOMENTS
C=======================================================================
C
      CALL BOHINT(NEXBET,EXADEN,EXARAD,EXABET,PARSUR,PARMUL)
C
C=======================================================================
C CALCULATING CHI-SQUARE
C=======================================================================
C
      CHISQR=0
C
CLP@    LAM=0 is included in CHISQR
      DO LAM=0,NEXBET
         DO MIU=-LAM,LAM
            CHISQR=CHISQR+(PARMUL(LAM,MIU)-ASKMUL(LAM,MIU))**2
         END DO
      END DO
CLP@      CHISQR=CHISQR+(PARSUR-ASKSUR)**2
C
C=======================================================================
C ITERATIONS CONTROL
C=======================================================================
C
      IF (CHISQR.GT.1.0D+40.OR.ITERAT.GT.1000) THEN
          IERROR=1
          GO TO 3
      END IF
      IF (CHISQR.LT.1.0D-5) THEN
          IERROR=0
          GO TO 2
      END IF
      ITERAT=ITERAT+1
C
C=======================================================================
C ADJUSTING SLOW-DOWN
C=======================================================================
C
      IF (CHISQR.LT.OLDCHI) THEN
         EPS=EPS*(1.5-0.5*EPS*EPS)
      ELSE
         EPS=0.01
      END IF
      OLDCHI=CHISQR
C
C=======================================================================
C CALCULATING NEW BETAS
C=======================================================================
C
      FACTOR=EXADEN*EXARAD**4
      DO LAM=1,NEXBET
         DO MIU=-LAM,LAM
            EXABET(LAM,MIU)=EXABET(LAM,MIU)
     *                +EPS*(ASKMUL(LAM,MIU)-PARMUL(LAM,MIU))/FACTOR
         END DO
         FACTOR=FACTOR*EXARAD
      END DO

CLP@  Modified approach (cf EXADEF)
CLP@    density=EXADEN is kept fixed, while EXARAD is changed explicitly
CLP@  during iterations, so EXAQ00 is unnecessary


      EXASUR=EXASUR+EPS*(ASKSUR-PARSUR)
      EXARAD=EXARAD+EPS*(askmul(0,0)**(1./3.)-parmul(0,0)**(1./3.))

c      EXAQ00=EXAQ00+EPS*(ASKMUL(0,0)-PARMUL(0,0))
c      EXARAD=SQRT(5.*EXASUR/(3.*SQR4PI*EXAQ00))
c      EXADEN=3.*EXAQ00/(SQR4PI*EXARAD**3)

C
      GO TO 1
C
    2 CONTINUE
C
C=======================================================================
C MULTIPLYING NON-AXIAL BETAS BY SQUARE ROOT OF TWO
C=======================================================================
C

CLP@    We need rather alphas not betas, so we skip this step

c      DO LAM=1,NEXBET
c         DO MIU=1,LAM
c           EXABET(LAM, MIU)=EXABET(LAM, MIU)*SQRT(2.)
c           EXABET(LAM,-MIU)=EXABET(LAM,-MIU)*SQRT(2.)
c         END DO
c      END DO
C

    3 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
        subroutine frombohi(pars,parm,vol,rco,rco2)
CLP@  This routine is to be called after BOHINT
CLP@  Input: pars=<r^2> and array parmul are output from BOHINT
CLP@  On output: vol is a volume,
CLP@  rco(1:3) contains <x_k>,
CLP@  rco2(1:3) contains <x_k^2>
        use hfodd_sizes
        dimension parm(0:ndmult,-ndmult:ndmult)
        dimension rco(1:3), rco2(1:3)

        pi=4.*atan(1.d0)
        s4pi=sqrt(4.d0*pi)
        d24pi5=2.*sqrt(4.*pi/5.0)
        d4pi3=sqrt(4.*pi/3.0)

        vol=parm(0,0)*s4pi

        ska=d24pi5*parm(2,0)
        skb=sqrt(2.d0/3.d0)*d24pi5*parm(2,2)
        skc=pars

        rco(1)=-d4pi3*sqrt(2.0)*parm(1,1)
        rco(2)=d4pi3*sqrt(2.0)*parm(1,-1)
        rco(3)=d4pi3*parm(1,0)

        rco2(1)=(2.*skc-ska+3.*skb)/6.0
        rco2(2)=(2.*skc-ska-3.*skb)/6.0
        rco2(3)=(skc+ska)/3.0
        end subroutine frombohi
C
C=======================================================================
C
      SUBROUTINE Q2GAUS(N1POIN,N2POIN,XL,XU,YL,YU,F,RESULT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          XG4 (ND04),WT4 (ND04),
     *          XG8 (ND08),WT8 (ND08),
     *          XG12(ND12),WT12(ND12),
     *          XG16(ND16),WT16(ND16),
     *          XG32(ND32),WT32(ND32),
     *          XG64(ND64),WT64(ND64),INDEX(6)
C
      DIMENSION
     *          XPOINT(NDMAX),YPOINT(NDMAX),XWEIGH(NDMAX),YWEIGH(NDMAX)
C
      EXTERNAL
     *         F
C
      DATA
     *         INDEX / 4, 8, 12, 16, 32, 64 /
C
C=======================================================================
C          POINTS AND WEIGHTS FOR THE '4-POINT' GAUSS QUADRATURES
C=======================================================================
C
      DATA XG4
     *
     *          / .339981043584856D0,  .861136311594053D0/
C
      DATA WT4
     *
     *          / .652145154862546D0,  .347854845137454D0/
C
C=======================================================================
C          POINTS AND WEIGHTS FOR THE '8-POINT' GAUSS QUADRATURES
C=======================================================================
C
      DATA XG8
     *
     *         / .18343464249564981D0, .52553240991632899D0,
     *           .79666647741362674D0, .96028985649753623D0/
C
      DATA WT8
     *
     *         / .36268378337836199D0, .31370664587788729D0,
     *           .22238103445337447D0, .10122853629037627D0/
C
C=======================================================================
C          POINTS AND WEIGHTS FOR THE '12-POINT' GAUSS QUADRATURES
C=======================================================================
C
      DATA XG12
     *
     *        / .12523340851146892D0, .36783149899818019D0,
     *          .58731795428661745D0, .76990267419430469D0,
     *          .90411725637047486D0, .98156063424671925D0/
C
      DATA WT12
     *
     *       / .24914704581340279D0, .23349253653835481D0,
     *         .20316742672306592D0, .16007832854334623D0,
     *         .10693932599531843D0, .04717533638651182D0/
C
C=======================================================================
C          POINTS AND WEIGHTS FOR THE '16-POINT' GAUSS QUADRATURES
C=======================================================================
C
      DATA XG16
     *
     *         / .09501250983763744D0, .28160355077925891D0,
     *           .45801677765722739D0, .61787624440264375D0,
     *           .75540440835500304D0, .86563120238783174D0,
     *           .94457502307323258D0, .98940093499164993D0/
      DATA WT16
     *
     *         / .18945061045506850D0, .18260341504492359D0,
     *           .16915651939500254D0, .14959598881657673D0,
     *           .12462897125553387D0, .09515851168249278D0,
     *           .06225352393864789D0, .02715245941175408D0/
C
C=======================================================================
C          POINTS AND WEIGHTS FOR THE '32-POINT' GAUSS QUADRATURES
C=======================================================================
C
      DATA XG32
     *
     *          / .04830766568773832D0, .14447196158279649D0,
     *            .23928736225213708D0, .33186860228212765D0,
     *            .42135127613063535D0, .50689990893222939D0,
     *            .58771575724076233D0, .66304426693021520D0,
     *            .73218211874028968D0, .79448379596794241D0,
     *            .84936761373256997D0, .89632115576605213D0,
     *            .93490607593773969D0, .96476225558750643D0,
     *            .98561151154526834D0, .99726386184948156D0/
      DATA WT32
     *
     *          / .09654008851472780D0, .09563872007927486D0,
     *            .09384439908080457D0, .09117387869576389D0,
     *            .08765209300440381D0, .08331192422694676D0,
     *            .07819389578707031D0, .07234579410884851D0,
     *            .06582222277636185D0, .05868409347853555D0,
     *            .05099805926237618D0, .04283589802222668D0,
     *            .03427386291302143D0, .02539206530926206D0,
     *            .01627439473090567D0, .00701861000947009D0/
C
C=======================================================================
C          POINTS AND WEIGHTS FOR THE '64-POINT' GAUSS QUADRATURES
C=======================================================================
C
      DATA XG64
     *
     *          / .02435029266342443D0, .07299312178779904D0,
     *            .12146281929612055D0, .16964442042399282D0,
     *            .21742364374000708D0, .26468716220876742D0,
     *            .31132287199021096D0, .35722015833766812D0,
     *            .40227015796399160D0, .44636601725346409D0,
     *            .48940314570705296D0, .53127946401989455D0,
     *            .57189564620263404D0, .61115535517239325D0,
     *            .64896547125465734D0, .68523631305423324D0,
     *            .71988185017161083D0, .75281990726053190D0,
     *            .78397235894334141D0, .81326531512279756D0,
     *            .84062929625258036D0, .86599939815409282D0,
     *            .88931544599511411D0, .91052213707850281D0,
     *            .92956917213193958D0, .94641137485840282D0,
     *            .96100879965205372D0, .97332682778991097D0,
     *            .98333625388462596D0, .99101337147674432D0,
     *            .99634011677195528D0, .99930504173577214D0/
      DATA WT64
     *
     *          / .04869095700913972D0, .04857546744150343D0,
     *            .04834476223480296D0, .04799938859645831D0,
     *            .04754016571483031D0, .04696818281621002D0,
     *            .04628479658131442D0, .04549162792741815D0,
     *            .04459055816375657D0, .04358372452932346D0,
     *            .04247351512365359D0, .04126256324262353D0,
     *            .03995374113272034D0, .03855015317861563D0,
     *            .03705512854024005D0, .03547221325688239D0,
     *            .03380516183714161D0, .03205792835485155D0,
     *            .03023465707240248D0, .02833967261425948D0,
     *            .02637746971505466D0, .02435270256871087D0,
     *            .02227017380838325D0, .02013482315353021D0,
     *            .01795171577569734D0, .01572603047602472D0,
     *            .01346304789671864D0, .01116813946013112D0,
     *            .00884675982636395D0, .00650445796897837D0,
     *            .00414703326056246D0, .00178328072169639D0/
C
      MINX=10000
      MINY=10000
C
      DO I=1,6
C
         M=IABS(INDEX(I)-N1POIN)
C
         IF (M.LE.MINX) THEN
             MINX=M
             NX=I
         END IF
C
      END DO
C
      IF (NX.GT.6) NX=6
C
      DO I=1,6
C
         M=IABS(INDEX(I)-N2POIN)
C
         IF (M.LE.MINY) THEN
             MINY=M
             NY=I
         END IF
C
      END DO
C
      IF (NY.GT.6) NY=6
C
C=======================================================================
C=======================================================================
C     NX = 1,2,3,4,5,6 CORRESPONDS TO 4,8,12,16,32,64 - POINT PROCEDURE
C=======================================================================
C=======================================================================
C
      GO TO  (10,20,30,40,50,60) NX
C
   10 NNX=2
C
      DO I=1,2
         XPOINT( I )=-XG4(3-I)
         XWEIGH( I )=+WT4(3-I)
         XPOINT(2+I)=XG4(I)
         XWEIGH(2+I)=WT4(I)
      END DO
C
      GO TO 100
C
   20 NNX=4
C
      DO I=1,4
         XPOINT(I)=-XG8(5-I)
         XWEIGH(I)=+WT8(5-I)
         XPOINT(4+I)=XG8(I)
         XWEIGH(4+I)=WT8(I)
      END DO
C
      GO TO 100
C
   30 NNX=6
C
      DO I=1,6
         XPOINT(I)=-XG12(7-I)
         XWEIGH(I)=+WT12(7-I)
         XPOINT(6+I)=XG12(I)
         XWEIGH(6+I)=WT12(I)
      END DO
C
      GO TO 100
C
   40 NNX=8
C
      DO I=1,8
         XPOINT(I)=-XG16(9-I)
         XWEIGH(I)=+WT16(9-I)
         XPOINT(8+I)=XG16(I)
         XWEIGH(8+I)=WT16(I)
      END DO
C
      GO TO 100
C
   50 NNX=16
C
      DO I=1,16
         XPOINT(I)=-XG32(17-I)
         XWEIGH(I)=+WT32(17-I)
         XPOINT(16+I)=XG32(I)
         XWEIGH(16+I)=WT32(I)
      END DO
C
      GO TO 100
C
   60 NNX=32
C
      DO I=1,32
         XPOINT(I)=-XG64(33-I)
         XWEIGH(I)=+WT64(33-I)
         XPOINT(32+I)=XG64(I)
         XWEIGH(32+I)=WT64(I)
      END DO
C
C=======================================================================
C=======================================================================
C     NY = 1,2,3,4,5,6 CORRESPONDS TO 4,8,12,16,32,64 - POINT PROCEDURE
C=======================================================================
C=======================================================================
C
  100 GO TO  (110,120,130,140,150,160) NY
C
  110 NNY=2
C
      DO I=1,2
      YPOINT(I)=-XG4(3-I)
      YWEIGH(I)=+WT4(3-I)
      YPOINT(2+I)=XG4(I)
      YWEIGH(2+I)=WT4(I)
      END DO
C
      GO TO 200
C
  120 NNY=4
C
      DO I=1,4
      YPOINT(I)=-XG8(5-I)
      YWEIGH(I)=+WT8(5-I)
      YPOINT(4+I)=XG8(I)
      YWEIGH(4+I)=WT8(I)
      END DO
C
      GO TO 200
C
  130 NNY=6
C
      DO I=1,6
         YPOINT(I)=-XG12(7-I)
         YWEIGH(I)=+WT12(7-I)
         YPOINT(6+I)=XG12(I)
         YWEIGH(6+I)=WT12(I)
      END DO
C
      GO TO 200
C
  140 NNY=8
C
      DO I=1,8
         YPOINT(I)=-XG16(9-I)
         YWEIGH(I)=+WT16(9-I)
         YPOINT(8+I)=XG16(I)
         YWEIGH(8+I)=WT16(I)
      END DO
C
      GO TO 200
C
  150 NNY=16
C
      DO I=1,16
         YPOINT(I)=-XG32(17-I)
         YWEIGH(I)=+WT32(17-I)
         YPOINT(16+I)=XG32(I)
         YWEIGH(16+I)=WT32(I)
      END DO
C
      GO TO 200
C
  160 NNY=32
C
      DO I=1,32
         YPOINT(I)=-XG64(33-I)
         YWEIGH(I)=+WT64(33-I)
         YPOINT(32+I)=XG64(I)
         YWEIGH(32+I)=WT64(I)
      END DO
C
  200 CONTINUE
C
      AX=(XL+XU)/2.0D0
      AY=(YL+YU)/2.0D0
C
      BX=(XU-XL)/2.0D0
      BY=(YU-YL)/2.0D0
C
      SUM=0.0D0
C
      DO IX=1,2*NNX
C
         XX=AX+XPOINT(IX)*BX
C
         S=0.0D0
C
         DO IY=1,2*NNY
C
            YY=AY+YPOINT(IY)*BY
C
            S=S+YWEIGH(IY)*F(XX,YY)
C
         END DO
C
         SUM=SUM+S*XWEIGH(IX)
C
      END DO
C
      RESULT=SUM*BX*BY
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZEROYL(YLM,YLMT,YLMF,YLMTT,YLMTF,YLMFF,LAMMAX,LEVEL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          YLM  (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMT (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMF (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMTT(0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMTF(0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMFF(0:NDLAMB,-NDLAMB:+NDLAMB)
      COMPLEX
     *          C_ZERO
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      DO LAMBDA=0,LAMMAX
         DO MIU=-LAMBDA,+LAMBDA
            YLM(LAMBDA,MIU)=C_ZERO
         END DO
      END DO
C
      IF (LEVEL.EQ.0) RETURN
C
      DO LAMBDA=0,LAMMAX
         DO MIU=-LAMBDA,+LAMBDA
            YLMT(LAMBDA,MIU)=C_ZERO
            YLMF(LAMBDA,MIU)=C_ZERO
         END DO
      END DO
C
      IF (LEVEL.EQ.1) RETURN
C
      DO LAMBDA=0,LAMMAX
         DO MIU=-LAMBDA,+LAMBDA
            YLMTT(LAMBDA,MIU)=C_ZERO
            YLMTF(LAMBDA,MIU)=C_ZERO
            YLMFF(LAMBDA,MIU)=C_ZERO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LIMITY(ALPHAC,LAMMAX)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          ALPHAC(0:NDLAMB,-NDLAMB:+NDLAMB)
      COMMON
     *       /ALINFO/ LAMACT(0:NDLAMB),MIUACT(0:NDLAMB,-NDLAMB:+NDLAMB)
C
C=======================================================================
C         THIS SUBROUTINE DETERMINES THE  LAMBDA  AND  MIU VALUES
C         FOR WHICH THE SPHERICAL HARMONICS AND THEIR DERIVATIVES
C         ARE NEEDED IN THE PROGRAM
C=======================================================================
C
      LAMMAX=0
C
      DO LAMBDA=0,NDLAMB
         LAMACT(LAMBDA)=-100
         DO MIU=-LAMBDA,+LAMBDA
            MIUACT(LAMBDA,MIU)=-100
         END DO
      END DO
C
      DO LAMBDA=0,NDLAMB
         DO MIU=-LAMBDA,+LAMBDA
            IF (ABS(ALPHAC(LAMBDA,MIU)).GT.0.0000001) THEN
                LAMMAX=LAMBDA
                LAMACT(LAMBDA)=LAMBDA
                MIUACT(LAMBDA,MIU)=MIU
            END IF
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFPRI(LAMMAX,INNUMB,IZNUMB)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PRIMOM(0:NDLAMB)*15
C
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE DEFORMATION PARAMETERS IN THE NUCLEAR
C       SURFACE FORMULA AS DEFINED TYPICALLY IN THE WOODS-SAXON PROGRAMS
C=======================================================================
C
      IF (INPOME.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,             1H*,77X,1H*,/,
     *          1H*,2X,''FREQUENCIES OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                          1H*,77X,1H*,/,79(1H*))')
          RETURN
C
      END IF
C
C
      IF (INPOME.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''THE LENGTHS OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          RETURN
C
      END IF
C
      IF (INPOME.EQ.3) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''THE CNSTNTS OF THE HARMONIC-OSCILLATOR '',
     *                 ''BASIS HAVE BEEN READ FROM THE DATA'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          RETURN
C
      END IF
C
      IF (INPOME.EQ.5) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *          1H*,2X,''FREQUENCIES OF THE H-O BASIS HAVE BEEN '',
     *                 ''CALCULATED FROM QUADR. CONSTRAINTS'',2X,1H*,/,
     *                                                   1H*,77X,1H*)')
C
          RETURN
C
      END IF
C
      WRITE(NFIPRI,'(79(1H*),/,             1H*,77X,1H*,/,
     *             1H*,2X,''CLASSICAL NUCLEAR SURFACE DEFINED FOR:'',
     *             20X,''N ='',I3,3X,''Z ='',I3,2X,1H*,/,
     *                                    1H*,77X,1H*,/,79(1H*))')
     *
     *                                              INNUMB,IZNUMB
C
      DO MIU=0,NDLAMB
         PRIMOM(MIU)='  .............'
      END DO
C
      DO LAMBDA=1,MIN(LAMMAX,NDLAMB)
C
         DO MIU=0,LAMBDA
C
            IF (ABS(ALPHAR(LAMBDA,MIU)).LT.1.0E-10) THEN
C
                WRITE(PRIMOM(MIU),'(''  AL'',2I1,'' ='',3X,''ZERO'')')
     *                                                     LAMBDA,MIU
            ELSE
C
               IF (ABS(ALPHAR(LAMBDA,MIU)).LT.1.0E-3) THEN
C
                   WRITE(PRIMOM(MIU),'(''  AL'',2I1,'' ='',1PE7.0)')
     *                          LAMBDA,MIU,ALPHAR(LAMBDA,MIU)
               ELSE
C
                   WRITE(PRIMOM(MIU),'(''  AL'',2I1,'' ='',F7.3)')
     *                          LAMBDA,MIU,ALPHAR(LAMBDA,MIU)
               END IF
C
            END IF
C
            IF (PRIMOM(MIU)(11:12).EQ.' .') PRIMOM(MIU)(11:12)='0.'
C
         END DO
C
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,5A15,2X,1H*)')
     *                                             (PRIMOM(MIU),MIU=0,4)
C
         IF (LAMBDA.EQ.5)
     *   WRITE(NFIPRI,'(1H*,      60X,A15,2X,1H*)')
     *                                             (PRIMOM(MIU),MIU=5,5)
C
      END DO
C
      IF (LAMMAX.EQ.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                   1H*,2X,''SPHERICAL SHAPE REQUESTED FOR '',
     *                     ''THE SURFACE'',34X,1H*)')
C
      END IF
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LOADIN(LAMMAX)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /COEFAB/ ALMS00(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                ALMSS0(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                ALMSSS(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *
     *                BLMS00(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                BLMSS0(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                BLMSSS(0:NDLAMB,0:NDLAMB,0:NDLAMB)
     *
     *       /FACTRS/ FACTOR(0:NDFACT),FACT_2(0:NDFACT+1)
     *
     *       /NORMNG/ XNORM(0:NDLAMB,-NDLAMB:+NDLAMB),PHASE(0:NDFACT)
C
C=======================================================================
C        C A L C U L A T I N G   T H E   F A C T O R I A L
C=======================================================================
C
      FACTOR(0)=1.0D0
      FACTOR(1)=1.0D0
C
      DO I=2,NDFACT
         FACTOR(I)=I*FACTOR(I-1)
      END DO
C
C=======================================================================
C         CALCULATING THE NORMALIZATION FACTORS FOR THE YLM FUNCTIONS
C=======================================================================
C
      PI_4=16.0D0*ATAN(1.0D0)
C
      DO LAMBDA=0,LAMMAX
         DO MIU=0,LAMBDA
C
            XNORM(LAMBDA,MIU)=(2.0D0*LAMBDA+1.000000D0)
     *                       / FACTOR(LAMBDA-IABS(MIU))
     *                       / FACTOR(LAMBDA+IABS(MIU))/PI_4
C
            XNORM(LAMBDA,MIU)=SQRT(XNORM(LAMBDA,MIU))
C
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE COEFFICIENTS FOR THE SUMMATIONS IN SPHERICAL
C        HARMONICS
C=======================================================================
C         C A L C U L A T I N G  THE  D O U B L E   F A C T O R I A L S
C=======================================================================
C
      FACT_2(0)=1.0D0
      FACT_2(1)=1.0D0
C
      DO I=2,NDFACT,2
         FACT_2(I)=I*FACT_2(I-2)
      END DO
C
      DO I=3,NDFACT,2
         FACT_2(I)=I*FACT_2(I-2)
      END DO
C
C=======================================================================
C        C A L C U L A T I N G    T H E    P H A S E    F A C T O R S
C=======================================================================
C
      PHASE(0)=1.0D0
      DO I=1,NDFACT
         PHASE(I)=-PHASE(I-1)
      END DO
C
C=======================================================================
C        CALCULATING THE COEFFICIENTS FOR THE YLM SUMMATIONS (L-M)-EVEN
C=======================================================================
C
      DO LAMBDA=0,LAMMAX
         DO MIU=LAMBDA,0,-2
C
            ZNORMA=XNORM(LAMBDA,MIU)
C
            DO IS=MIU,LAMBDA,2
               ALMS00(LAMBDA,MIU,IS)=ZNORMA*PHASE((MIU+IS)/2)
     *                              *FACT_2(LAMBDA+MIU)
     *                              /FACT_2(LAMBDA+ IS)
     *                              *FACT_2(LAMBDA-MIU)
     *                              /FACT_2(LAMBDA- IS)
     *                              *FACTOR(LAMBDA+IS)
     *                              /FACT_2(IS  +  MIU)
     *                              /FACT_2(IS  -  MIU)
            END DO
C
            DO IS=MIU,LAMBDA,2
               ALMSS0(LAMBDA,MIU,IS)=ALMS00(LAMBDA,MIU,IS)*IS
               ALMSSS(LAMBDA,MIU,IS)=ALMS00(LAMBDA,MIU,IS)*IS*(IS-1)
            END DO
C
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE COEFFICIENTS FOR THE YLM SUMMATIONS (L-M)-ODD
C=======================================================================
C
      DO LAMBDA=0,LAMMAX
         DO MIU=LAMBDA-1,0,-2
C
            ZNORMA=XNORM(LAMBDA,MIU)
C
            DO IS=MIU,LAMBDA-1,2
               BLMS00(LAMBDA,MIU,IS)=ZNORMA*PHASE((MIU+IS)/2)
     *                              *FACT_2(LAMBDA+MIU-1)
     *                              /FACT_2(LAMBDA+ IS-1)
     *                              *FACT_2(LAMBDA-MIU-1)
     *                              /FACT_2(LAMBDA- IS-1)
     *                              *FACTOR(LAMBDA+IS)
     *                              /FACT_2(IS  +  MIU)
     *                              /FACT_2(IS  -  MIU)
            END DO
C
            DO IS=MIU,LAMBDA-1,2
               BLMSS0(LAMBDA,MIU,IS)=BLMS00(LAMBDA,MIU,IS)*IS
               BLMSSS(LAMBDA,MIU,IS)=BLMS00(LAMBDA,MIU,IS)*IS*(IS-1)
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE YL_MIU(YLM,YLMT,YLMF,YLMTT,YLMTF,YLMFF,
     *                       LAMBDA,MIU,THETA,PHI,LEVEL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          YLM  (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMT (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMF (0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMTT(0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMTF(0:NDLAMB,-NDLAMB:+NDLAMB),
     *          YLMFF(0:NDLAMB,-NDLAMB:+NDLAMB)
      COMPLEX
     *          YLMCCC,YLMTCC,YLMFCC,YLMTTC,YLMTFC,YLMFFC,
     *                                      EXPPHI,UNITY
      DIMENSION
     *          SINUS (-2:NDLAMB)
C
      COMMON
     *       /COEFAB/ ALMS00(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                ALMSS0(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                ALMSSS(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *
     *                BLMS00(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                BLMSS0(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                BLMSSS(0:NDLAMB,0:NDLAMB,0:NDLAMB)
     *
     *       /NORMNG/ XNORM(0:NDLAMB,-NDLAMB:+NDLAMB),PHASE(0:NDFACT)
C
      UNITY=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C        CALCULATING THE SPHERICAL HARMONICS FOR (LAMBDA-MIU)-EVEN
C=======================================================================
C
      SINTHT=SIN(THETA)
      COSTHT=COS(THETA)
C
      COST_2=COSTHT*COSTHT
C
      ANGLE=MIU*PHI
C
      EXPPHI=CMPLX(COS(ANGLE),SIN(ANGLE))
C
      SINUS(-2)=0.0D0
      SINUS(-1)=0.0D0
      SINUS( 0)=1.0D0
C
      SINUS(+1)=SINTHT
      DO I=2,LAMBDA
         SINUS(I)=SINUS(I-1)*SINTHT
      END DO
C
      IF (MOD((LAMBDA-MIU),2).EQ.0) THEN
C
          SUM=0.0D0
C
          DO IS=MIU,LAMBDA,2
             SUM=SUM+ALMS00(LAMBDA,MIU,IS)*SINUS(IS)
          END DO
C
          YLMCCC=SUM*EXPPHI
C
          IF (LEVEL.EQ.0) GO TO 1
C
          YLMFCC=YLMCCC*UNITY*MIU
C
          SUM=0.0D0
          DO IS=MIU,LAMBDA,2
             SUM=SUM+ALMSS0(LAMBDA,MIU,IS)*SINUS(IS-1)
          END DO
C
          YLMTCC=SUM*COSTHT*EXPPHI
C
          IF (LEVEL.EQ.1) GO TO 2
C
          YLMFFC=-MIU*MIU*YLMCCC
          YLMTFC=+MIU*UNITY*YLMTCC
C
          SUM1=0.0D0
          SUM2=0.0D0
C
          DO IS=MIU,LAMBDA,2
             SUM1=SUM1+ALMSS0(LAMBDA,MIU,IS)*SINUS( IS )
             SUM2=SUM2+ALMSSS(LAMBDA,MIU,IS)*SINUS(IS-2)
          END DO
C
          YLMTTC=EXPPHI*(COST_2*SUM2-SUM1)
C
          GO TO 3
C
      ELSE
C
C=======================================================================
C         CALCULATING THE SPHERICAL HARMONICS FOR (LAMBDA-MIU)-ODD
C=======================================================================
C
          SUM=0.0D0
C
          DO IS=MIU,LAMBDA-1,2
             SUM=SUM+BLMS00(LAMBDA,MIU,IS)*SINUS(IS)
          END DO
C
          SUM_TH=SUM*COSTHT
C
          YLMCCC=SUM_TH*EXPPHI
C
          IF (LEVEL.EQ.0) GO TO 1
C
          YLMFCC=YLMCCC*UNITY*MIU
C
          SUM1=0.0D0
          DO IS=MIU,LAMBDA-1,2
             SUM1=SUM1+BLMSS0(LAMBDA,MIU,IS)*SINUS(IS-1)
          END DO
C
          YLMTCC=EXPPHI*(COST_2*SUM1-SINTHT*SUM)
C
          IF (LEVEL.EQ.1) GO TO 2
C
          YLMFFC=-MIU*MIU*YLMCCC
          YLMTFC=+MIU*UNITY*YLMTCC
C
C         SUM1=0.0D0
          SUM2=0.0D0
C
          DO IS=MIU,LAMBDA-1,2
C            SUM1=SUM1+BLMSS0(LAMBDA,MIU,IS)*SINUS(IS-1)
             SUM2=SUM2+BLMSSS(LAMBDA,MIU,IS)*SINUS(IS-2)
          END DO
C
          YLMTTC=EXPPHI*(COST_2*COSTHT*SUM2-SUM_TH
     *              -3.0D0*SINTHT*COSTHT*SUM1)
C
          GO TO 3
C
      END IF
C
   1  CONTINUE
C
      YLM(LAMBDA,+MIU)=YLMCCC
      YLM(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMCCC)
C
      RETURN
C
   2  CONTINUE
C
      YLM(LAMBDA,+MIU)=YLMCCC
      YLM(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMCCC)
C
      YLMT(LAMBDA,+MIU)=YLMTCC
      YLMF(LAMBDA,+MIU)=YLMFCC
C
      YLMT(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMTCC)
      YLMF(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMFCC)
C
      RETURN
C
   3  CONTINUE
C
      YLM(LAMBDA,+MIU)=YLMCCC
      YLM(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMCCC)
C
      YLMT(LAMBDA,+MIU)=YLMTCC
      YLMF(LAMBDA,+MIU)=YLMFCC
C
      YLMT(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMTCC)
      YLMF(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMFCC)
C
      YLMTT(LAMBDA,+MIU)=YLMTTC
      YLMTF(LAMBDA,+MIU)=YLMTFC
      YLMFF(LAMBDA,+MIU)=YLMFFC
C
      YLMTT(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMTTC)
      YLMTF(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMTFC)
      YLMFF(LAMBDA,-MIU)=PHASE(MIU)*CONJG(YLMFFC)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SOLHAR(HARMON,LAMBDA,MIU,POSTIO,IMAREA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          POSTIO(NDKART)
C
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
C
C=======================================================================
C
C     CALL CPUTIM('SOLHAR',1)
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE   S O L I D   H A R M O N I C S
C                        (SPHERICAL HARMONICS  *  R**LAMBDA).
C=======================================================================
C
      IF (MIU.LT.0)
     *
     *   STOP 'FOR MIU<0 ONE CANNOT CALCULATE SOLID HARMONICS IN SOLHAR'
C
      IF (MIU.EQ.0.AND.IMAREA.EQ.-1)
     *
     *   STOP 'FOR MIU=0 NO IMAGINARY PART OF SOLID HARMONICS IN SOLHAR'
C
C=======================================================================
C
      HARMON=0.0D0
C
      IF (IMAREA.EQ.1) THEN
C
C=======================================================================
C        CALCULATING THE REAL PART OF THE SOLID HARMONIC
C=======================================================================
C
         DO NUTERM=1,NREYLM(LAMBDA,MIU)
C
            RESULT=KREYLM(LAMBDA,MIU,NUTERM,0)
C
            DO KARTEZ=1,NDKART
C
               DO IPOWER=1,KREYLM(LAMBDA,MIU,NUTERM,KARTEZ)
C
                  RESULT=RESULT*POSTIO(KARTEZ)
C
               END DO
C
            END DO
C
            HARMON=HARMON+RESULT
C
         END DO
C
         HARMON=HARMON*COEYLM(LAMBDA,MIU)
C
      ELSE
C
C=======================================================================
C        CALCULATING THE IMAGINARY PART OF THE SOLID HARMONIC
C=======================================================================
C
         DO NUTERM=1,NIMYLM(LAMBDA,MIU)
C
            RESULT=KIMYLM(LAMBDA,MIU,NUTERM,0)
C
            DO KARTEZ=1,NDKART
C
               DO IPOWER=1,KIMYLM(LAMBDA,MIU,NUTERM,KARTEZ)
C
                  RESULT=RESULT*POSTIO(KARTEZ)
C
               END DO
C
            END DO
C
            HARMON=HARMON+RESULT
C
         END DO
C
         HARMON=HARMON*COEYLM(LAMBDA,MIU)
C
      END IF
C
C=======================================================================
C
C     CALL CPUTIM('SOLHAR',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFYLM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          KOELOC(0:NDMULT,0:NDMULT,1:3),
     *
     *          NRELOC(0:NDMULT,0:NDMULT),
     *          KRELOC(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *          NIMLOC(0:NDMULT,1:NDMULT),
     *          KIMLOC(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
C
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
C
      DATA
     *        MULMAX / 9 /
C
C=======================================================================
C
C         THIS SUBROUTINE DEFINES THE TERMS APPEARING IN THE
C
C                   S O L I D    H A R M O N I C S
C
C         (SPHERICAL HARMONICS  *  R**LAMBDA).  THE NUMBER OF
C         TERMS IS STORED IN  "NREYLM" AND "NIMYLM" FOR  REAL
C         AND IMAGINARY PARTS, RESPECTIVELY.  EVERY  TERM  IS
C         DEFINED BY ITS INTEGER COEFFICIENT  (STORED  IN THE
C         KARTEZ = 0 COMPONENT  OF "KREYLM" AND "KIMYLM") AND
C         BY POWERS OF COORDINATES  (KARTEZ= 1,2,3 COMPONENTS
C         OF THESE SAME ARRAYS),  WHILE  THE  OVERALL  COMMON
C         FACTORS ARE STORED IN "COEYLM".
C
C         KOELOC: INTEGER  ARRAY STORING THE STRUCTURE OF THE
C                 OVERALL COMMON FACTORS  "COEYLM"  ACCORDING
C                 TO THE FOLLOWING CONVENTION:
C
C                 COEYLM = INT1 * SQRT(INT2/INT3) / SQRT(4PI)
C
C                 KOELOC(,,1) = INT1
C                 KOELOC(,,2) = INT2
C                 KOELOC(,,3) = INT3
C
C=======================================================================
C
C         THIS SUBROUTINE DEFINES MULTIPOLES UP TO THE VALUE
C         OF "MULMAX" DEFINED ABOVE. THIS VALUE MUST NOT  BE
C         SMALLER THAN ANY OF THE FOLLOWING INPUT PARAMETERS:
C
C                      NMUCON   <= MULMAX
C                      NMUCOU   <= MULMAX
C                      NMUPRI   <= MULMAX
C                      NMACON+1 <= MULMAX
C                      NMAPRI+1 <= MULMAX
C                      NASCON+1 <= MULMAX
C                      NASPRI+1 <= MULMAX
C
C         AS A SAFETY MEASURE,  THE  CODE REQUIRES THAT THE
C         DIMENSION  DECLARATION  "NDMULT"  IS  NECESSARILY
C         EQUAL TO "MULMAX".
C
C         AT THE SAME TIME THE DIMENSION DECLARATIONS "NDPOLS" HAVE
C         TO BE ADJUSTED IN FUNCTION OF "NDMULT"="MULMAX" ACCORDING
C         TO THE TABLE GIVEN IN "MULCOU"
C
C         AND "NDTERM"  HAS  TO  TAKE  THE FOLLOWING VALUES:
C                       MULMAX = NDMULT<=5  ==>>  NDTERM= 6;
C                       MULMAX = NDMULT<=7  ==>>  NDTERM=10;
C                       MULMAX = NDMULT<=9  ==>>  NDTERM=15;
C                       MULMAX = NDMULT =10 ==>>  NDTERM=21;
C
C=======================================================================
C         HERE START DEFINITIONS FOR THE GIVEN LAMBDA AND MIU VALUES:
C=======================================================================
C                        LAMBDA=0  MIU=0  YLM=C
C                               C=1/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  0,  0,      K), K= 1, 3) /  1,  1,  1/
C
C=======================================================================
C          Y00 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  0,  0,  1,  K), K= 0, 3) /  1,  0,  0,  0/
C
      DATA  NRELOC(  0,  0) /1/
C
C=======================================================================
C          LAMBDA=1  MIU=0  YLM=C * Z
C          C=SQRT(3)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  1,  0,      K), K= 1, 3) /  1,  3,  1/
C
C=======================================================================
C          Y10 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  1,  0,  1,  K), K= 0, 3) /  1,  0,  0,  1/
C
      DATA  NRELOC(  1,  0) /1/
C
C=======================================================================
C          LAMBDA=1  MIU=1  YLM=C * ( X + I*Y )
C          C=-SQRT(3/2)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  1,  1,      K), K= 1, 3) / -1,  3,  2/
C
C=======================================================================
C          Y11 REAL PART
C=======================================================================
C
      DATA (KRELOC(  1,  1,  1,  K), K= 0, 3) /  1,  1,  0,  0/
C
      DATA  NRELOC(  1,  1) /1/
C
C=======================================================================
C          Y11 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  1,  1,  1,  K), K= 0, 3) /  1,  0,  1,  0/
C
      DATA  NIMLOC(  1,  1) /1/
C
C=======================================================================
C          LAMBDA=2  MIU=0  YLM=C * (2Z**2 - X**2 - Y**2)
C          C=SQRT(5/4)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  2,  0,      K), K= 1, 3) /  1,  5,  4/
C
C=======================================================================
C          Y20 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  2,  0,  1,  K), K= 0, 3) /  2,  0,  0,  2/
      DATA (KRELOC(  2,  0,  2,  K), K= 0, 3) / -1,  2,  0,  0/
      DATA (KRELOC(  2,  0,  3,  K), K= 0, 3) / -1,  0,  2,  0/
C
      DATA  NRELOC(  2,  0) /3/
C
C=======================================================================
C          LAMBDA=2  MIU=1  YLM=C * ( X + I*Y ) * Z
C          C=-SQRT(15/2)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  2,  1,      K), K= 1, 3) / -1, 15,  2/
C
C=======================================================================
C          Y21 REAL PART
C=======================================================================
C
      DATA (KRELOC(  2,  1,  1,  K), K= 0, 3) /  1,  1,  0,  1/
C
      DATA  NRELOC(  2,  1) /1/
C
C=======================================================================
C          Y21 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  2,  1,  1,  K), K= 0, 3) /  1,  0,  1,  1/
C
      DATA  NIMLOC(  2,  1) /1/
C
C=======================================================================
C          LAMBDA=2  MIU=2  YLM=C * ( X**2 + 2I X*Y - Y**2 )
C          C=SQRT(15/8)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  2,  2,      K), K= 1, 3) /  1, 15,  8/
C
C=======================================================================
C          Y22 REAL PART
C=======================================================================
C
      DATA (KRELOC(  2,  2,  1,  K), K= 0, 3) /  1,  2,  0,  0/
      DATA (KRELOC(  2,  2,  2,  K), K= 0, 3) / -1,  0,  2,  0/
C
      DATA  NRELOC(  2,  2) /2/
C
C=======================================================================
C          Y22 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  2,  2,  1,  K), K= 0, 3) /  2,  1,  1,  0/
C
      DATA  NIMLOC(  2,  2) /1/
C
C=======================================================================
C          LAMBDA=3  MIU=0  YLM=C * (2Z**2 - 3X**2 - 3Y**2) * Z
C          C=SQRT(7/4)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  3,  0,      K), K= 1, 3) /  1,  7,  4/
C
C=======================================================================
C          Y30 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  3,  0,  1,  K), K= 0, 3) /  2,  0,  0,  3/
      DATA (KRELOC(  3,  0,  2,  K), K= 0, 3) / -3,  2,  0,  1/
      DATA (KRELOC(  3,  0,  3,  K), K= 0, 3) / -3,  0,  2,  1/
C
      DATA  NRELOC(  3,  0) /3/
C
C=======================================================================
C          LAMBDA=3  MIU=1  YLM= C * ( X + I*Y )*( 4Z**2 - X**2 - Y**2 )
C          C=-SQRT(21/16)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  3,  1,      K), K= 1, 3) / -1, 21, 16/
C
C=======================================================================
C          Y31 REAL PART
C=======================================================================
C
      DATA (KRELOC(  3,  1,  1,  K), K= 0, 3) /  4,  1,  0,  2/
      DATA (KRELOC(  3,  1,  2,  K), K= 0, 3) / -1,  3,  0,  0/
      DATA (KRELOC(  3,  1,  3,  K), K= 0, 3) / -1,  1,  2,  0/
C
      DATA  NRELOC(  3,  1) /3/
C
C=======================================================================
C          Y31 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  3,  1,  1,  K), K= 0, 3) /  4,  0,  1,  2/
      DATA (KIMLOC(  3,  1,  2,  K), K= 0, 3) / -1,  2,  1,  0/
      DATA (KIMLOC(  3,  1,  3,  K), K= 0, 3) / -1,  0,  3,  0/
C
      DATA  NIMLOC(  3,  1) /3/
C
C=======================================================================
C          LAMBDA=3  MIU=2  YLM=C * ( X**2 + 2*I*X*Y - Y**2 ) * Z
C          C=SQRT(105/8)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  3,  2,      K), K= 1, 3) /  1,105,  8/
C
C=======================================================================
C          Y32 REAL PART
C=======================================================================
C
      DATA (KRELOC(  3,  2,  1,  K), K= 0, 3) /  1,  2,  0,  1/
      DATA (KRELOC(  3,  2,  2,  K), K= 0, 3) / -1,  0,  2,  1/
C
      DATA  NRELOC(  3,  2) /2/
C
C=======================================================================
C          Y32 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  3,  2,  1,  K), K= 0, 3) /  2,  1,  1,  1/
C
      DATA  NIMLOC(  3,  2) /1/
C
C=======================================================================
C          LAMBDA=3  MIU=3  YLM=C*(X**3 + 3I X**2*Y - 3 X*Y**2 - I Y**3)
C          C=-SQRT(35/16)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  3,  3,      K), K= 1, 3) / -1, 35, 16/
C
C=======================================================================
C          Y33 REAL PART
C=======================================================================
C
      DATA (KRELOC(  3,  3,  1,  K), K= 0, 3) /  1,  3,  0,  0/
      DATA (KRELOC(  3,  3,  2,  K), K= 0, 3) / -3,  1,  2,  0/
C
      DATA  NRELOC(  3,  3) /2/
C
C=======================================================================
C          Y33 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  3,  3,  1,  K), K= 0, 3) /  3,  2,  1,  0/
      DATA (KIMLOC(  3,  3,  2,  K), K= 0, 3) / -1,  0,  3,  0/
C
      DATA  NIMLOC(  3,  3) /2/
C
C=======================================================================
C          LAMBDA=4  MIU=0  YLM=C * ( 8Z**4 + 3X**4 + 3Y**4
C                            -24 X**2 Z**2 -24 Y**2 Z**2 + 6 X**2 Y**2 )
C          C=3/8/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  4,  0,      K), K= 1, 3) /  1,  9, 64/
C
C=======================================================================
C          Y40 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  4,  0,  1,  K), K= 0, 3) /  8,  0,  0,  4/
      DATA (KRELOC(  4,  0,  2,  K), K= 0, 3) /  3,  4,  0,  0/
      DATA (KRELOC(  4,  0,  3,  K), K= 0, 3) /  3,  0,  4,  0/
      DATA (KRELOC(  4,  0,  4,  K), K= 0, 3) /-24,  2,  0,  2/
      DATA (KRELOC(  4,  0,  5,  K), K= 0, 3) /-24,  0,  2,  2/
      DATA (KRELOC(  4,  0,  6,  K), K= 0, 3) /  6,  2,  2,  0/
C
      DATA  NRELOC(  4,  0) /6/
C
C=======================================================================
C          LAMBDA=4  MIU=1  YLM=C *(X + I*Y)*(4Z**2 - 3X**2 - 3Y**2) * Z
C          C=-SQRT(45/16)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  4,  1,      K), K= 1, 3) / -1, 45, 16/
C
C=======================================================================
C          Y41 REAL PART
C=======================================================================
C
      DATA (KRELOC(  4,  1,  1,  K), K= 0, 3) /  4,  1,  0,  3/
      DATA (KRELOC(  4,  1,  2,  K), K= 0, 3) / -3,  3,  0,  1/
      DATA (KRELOC(  4,  1,  3,  K), K= 0, 3) / -3,  1,  2,  1/
C
      DATA  NRELOC(  4,  1) /3/
C
C=======================================================================
C          Y41 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  4,  1,  1,  K), K= 0, 3) /  4,  0,  1,  3/
      DATA (KIMLOC(  4,  1,  2,  K), K= 0, 3) / -3,  2,  1,  1/
      DATA (KIMLOC(  4,  1,  3,  K), K= 0, 3) / -3,  0,  3,  1/
C
      DATA  NIMLOC(  4,  1) /3/
C
C=======================================================================
C          LAMBDA=4  MIU=2  YLM=C * (   X**2 + 2*I*X*Y - Y**2 ) *
C                                  ( 6*Z**2 -   X**2  - Y**2 )
C          C=SQRT(90/64)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  4,  2,      K), K= 1, 3) /  1, 90, 64/
C
C=======================================================================
C          Y42 REAL PART
C=======================================================================
C
      DATA (KRELOC(  4,  2,  1,  K), K= 0, 3) /  6,  2,  0,  2/
      DATA (KRELOC(  4,  2,  2,  K), K= 0, 3) / -6,  0,  2,  2/
      DATA (KRELOC(  4,  2,  3,  K), K= 0, 3) / -1,  4,  0,  0/
      DATA (KRELOC(  4,  2,  4,  K), K= 0, 3) /  1,  0,  4,  0/
C
      DATA  NRELOC(  4,  2) /4/
C
C=======================================================================
C          Y42 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  4,  2,  1,  K), K= 0, 3) / 12,  1,  1,  2/
      DATA (KIMLOC(  4,  2,  2,  K), K= 0, 3) / -2,  3,  1,  0/
      DATA (KIMLOC(  4,  2,  3,  K), K= 0, 3) / -2,  1,  3,  0/
C
      DATA  NIMLOC(  4,  2) /3/
C
C=======================================================================
C          LAMBDA=4  MIU=3  YLM=C*(X**3 + 3I X**2*Y - 3X*Y**2 - IY**3)*Z
C          C=-SQRT(315/16)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  4,  3,      K), K= 1, 3) / -1,315, 16/
C
C=======================================================================
C          Y43 REAL PART
C=======================================================================
C
      DATA (KRELOC(  4,  3,  1,  K), K= 0, 3) /  1,  3,  0,  1/
      DATA (KRELOC(  4,  3,  2,  K), K= 0, 3) / -3,  1,  2,  1/
C
      DATA  NRELOC(  4,  3) /2/
C
C=======================================================================
C          Y43 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  4,  3,  1,  K), K= 0, 3) /  3,  2,  1,  1/
      DATA (KIMLOC(  4,  3,  2,  K), K= 0, 3) / -1,  0,  3,  1/
C
      DATA  NIMLOC(  4,  3) /2/
C
C=======================================================================
C          LAMBDA=4  MIU=4  YLM=C * ( X**4 + 4I X**3*Y - 6 X**2*Y**2
C                                          - 4I X*Y**3 + Y**4 )
C          C=SQRT(630/256)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  4,  4,      K), K= 1, 3) /  1,630,256/
C
C=======================================================================
C          Y44 REAL PART
C=======================================================================
C
      DATA (KRELOC(  4,  4,  1,  K), K= 0, 3) /  1,  4,  0,  0/
      DATA (KRELOC(  4,  4,  2,  K), K= 0, 3) / -6,  2,  2,  0/
      DATA (KRELOC(  4,  4,  3,  K), K= 0, 3) /  1,  0,  4,  0/
C
      DATA  NRELOC(  4,  4) /3/
C
C=======================================================================
C          Y44 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  4,  4,  1,  K), K= 0, 3) /  4,  3,  1,  0/
      DATA (KIMLOC(  4,  4,  2,  K), K= 0, 3) / -4,  1,  3,  0/
C
      DATA  NIMLOC(  4,  4) /2/
C
C=======================================================================
C          LAMBDA=5  MIU=0  YLM=C * (8Z**5 - 40X**2*Z**3 - 40Y**2*Z**3
C                                +15X**4*Z + 15Y**4*Z + 30X**2*Y**2*Z)
C          C=SQRT(11/64)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  5,  0,      K), K= 1, 3) /  1,  11, 64/
C
C=======================================================================
C          Y50 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  5,  0,  1,  K), K= 0, 3) /  8,  0,  0,  5/
      DATA (KRELOC(  5,  0,  2,  K), K= 0, 3) /-40,  2,  0,  3/
      DATA (KRELOC(  5,  0,  3,  K), K= 0, 3) /-40,  0,  2,  3/
      DATA (KRELOC(  5,  0,  4,  K), K= 0, 3) / 15,  4,  0,  1/
      DATA (KRELOC(  5,  0,  5,  K), K= 0, 3) / 15,  0,  4,  1/
      DATA (KRELOC(  5,  0,  6,  K), K= 0, 3) / 30,  2,  2,  1/
C
      DATA  NRELOC(  5,  0) /6/
C
C=======================================================================
C          LAMBDA=5  MIU=1  YLM=C * (X + IY)( X**4 + Y**4 + 8Z**4
C                             + 2X**2*Y**2 - 12*X**2*Z**2 - 12Y**2*Z**2)
C          C=-SQRT(165/128)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  5,  1,      K), K= 1, 3) / -1,165,128/
C
C=======================================================================
C          Y51 REAL PART
C=======================================================================
C
      DATA (KRELOC(  5,  1,  1,  K), K= 0, 3) /  8,  1,  0,  4/
      DATA (KRELOC(  5,  1,  2,  K), K= 0, 3) /  1,  5,  0,  0/
      DATA (KRELOC(  5,  1,  3,  K), K= 0, 3) /  1,  1,  4,  0/
      DATA (KRELOC(  5,  1,  4,  K), K= 0, 3) /  2,  3,  2,  0/
      DATA (KRELOC(  5,  1,  5,  K), K= 0, 3) /-12,  3,  0,  2/
      DATA (KRELOC(  5,  1,  6,  K), K= 0, 3) /-12,  1,  2,  2/
C
      DATA  NRELOC(  5,  1) /6/
C
C=======================================================================
C          Y51 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  5,  1,  1,  K), K= 0, 3) /  8,  0,  1,  4/
      DATA (KIMLOC(  5,  1,  2,  K), K= 0, 3) /  1,  4,  1,  0/
      DATA (KIMLOC(  5,  1,  3,  K), K= 0, 3) /  1,  0,  5,  0/
      DATA (KIMLOC(  5,  1,  4,  K), K= 0, 3) /  2,  2,  3,  0/
      DATA (KIMLOC(  5,  1,  5,  K), K= 0, 3) /-12,  2,  1,  2/
      DATA (KIMLOC(  5,  1,  6,  K), K= 0, 3) /-12,  0,  3,  2/
C
      DATA  NIMLOC(  5,  1) /6/
C
C=======================================================================
C          LAMBDA=5  MIU=2  YLM=C * (X **2 - Y**2 + I 2*X*Y)
C                                   ( 2Z**2 - X**2 - Y**2)*Z
C          C=SQRT(1155/32)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  5,  2,      K), K= 1, 3) / 1,1155,32/
C
C=======================================================================
C          Y52 REAL PART
C=======================================================================
C
      DATA (KRELOC(  5,  2,  1,  K), K= 0, 3) /  2,  2,  0,  3/
      DATA (KRELOC(  5,  2,  2,  K), K= 0, 3) / -1,  4,  0,  1/
      DATA (KRELOC(  5,  2,  3,  K), K= 0, 3) / -2,  0,  2,  3/
      DATA (KRELOC(  5,  2,  4,  K), K= 0, 3) /  1,  0,  4,  1/
C
      DATA  NRELOC(  5,  2) /4/
C
C=======================================================================
C          Y52 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  5,  2,  1,  K), K= 0, 3) /  4,  1,  1,  3/
      DATA (KIMLOC(  5,  2,  2,  K), K= 0, 3) / -2,  3,  1,  1/
      DATA (KIMLOC(  5,  2,  3,  K), K= 0, 3) / -2,  1,  3,  1/
C
      DATA  NIMLOC(  5,  2) /3/
C
C=======================================================================
C          LAMBDA=5  MIU=3  YLM=C *
C          C=-SQRT(385/256)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  5,  3,      K), K= 1, 3) / -1,385,256/
C
C=======================================================================
C          Y53 REAL PART
C=======================================================================
C
      DATA (KRELOC(  5,  3,  1,  K), K= 0, 3) / -1,  5,  0,  0/
      DATA (KRELOC(  5,  3,  2,  K), K= 0, 3) /  8,  3,  0,  2/
      DATA (KRELOC(  5,  3,  3,  K), K= 0, 3) /  2,  3,  2,  0/
      DATA (KRELOC(  5,  3,  4,  K), K= 0, 3) /-24,  1,  2,  2/
      DATA (KRELOC(  5,  3,  5,  K), K= 0, 3) /  3,  1,  4,  0/
C
      DATA  NRELOC(  5,  3) /5/
C
C=======================================================================
C          Y53 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  5,  3,  1,  K), K= 0, 3) / -3,  4,  1,  0/
      DATA (KIMLOC(  5,  3,  2,  K), K= 0, 3) / 24,  2,  1,  2/
      DATA (KIMLOC(  5,  3,  3,  K), K= 0, 3) / -8,  0,  3,  2/
      DATA (KIMLOC(  5,  3,  4,  K), K= 0, 3) /  1,  0,  5,  0/
      DATA (KIMLOC(  5,  3,  5,  K), K= 0, 3) / -2,  2,  3,  0/
C
      DATA  NIMLOC(  5,  3) /5/
C
C=======================================================================
C          LAMBDA=5  MIU=4  YLM=C *
C          C=3*SQRT(385/128)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  5,  4,      K), K= 1, 3) /  3,385,128/
C
C=======================================================================
C          Y54 REAL PART
C=======================================================================
C
      DATA (KRELOC(  5,  4,  1,  K), K= 0, 3) /  1,  4,  0,  1/
      DATA (KRELOC(  5,  4,  2,  K), K= 0, 3) /  1,  0,  4,  1/
      DATA (KRELOC(  5,  4,  3,  K), K= 0, 3) / -6,  2,  2,  1/
C
      DATA  NRELOC(  5,  4) /3/
C
C=======================================================================
C          Y54 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  5,  4,  1,  K), K= 0, 3) /  4,  3,  1,  1/
      DATA (KIMLOC(  5,  4,  2,  K), K= 0, 3) / -4,  1,  3,  1/
C
      DATA  NIMLOC(  5,  4) /2/
C
C=======================================================================
C          LAMBDA=5  MIU=5  YLM=C *
C          C=-3*SQRT(77/256)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  5,  5,      K), K= 1, 3) /  -3, 77,256/
C
C=======================================================================
C          Y55 REAL PART
C=======================================================================
C
      DATA (KRELOC(  5,  5,  1,  K), K= 0, 3) /  1,  5,  0,  0/
      DATA (KRELOC(  5,  5,  2,  K), K= 0, 3) /  5,  1,  4,  0/
      DATA (KRELOC(  5,  5,  3,  K), K= 0, 3) /-10,  3,  2,  0/
C
      DATA  NRELOC(  5,  5) /3/
C
C=======================================================================
C          Y55 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  5,  5,  1,  K), K= 0, 3) /  1,  0,  5,  0/
      DATA (KIMLOC(  5,  5,  2,  K), K= 0, 3) /  5,  4,  1,  0/
      DATA (KIMLOC(  5,  5,  3,  K), K= 0, 3) /-10,  2,  3,  0/
C
      DATA  NIMLOC(  5,  5) /3/
C
C=======================================================================
C          LAMBDA=6  MIU=0  YLM=C *
C          C=SQRT(11/64)/SQR4PI
C=======================================================================
C
      DATA (KOELOC(  6,  0,      K), K= 1, 3) / -1,  13, 256/
C
C=======================================================================
C          Y60 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  6,  0,  1,  K), K= 0, 3) /   5,  6,  0,  0/
      DATA (KRELOC(  6,  0,  2,  K), K= 0, 3) /  15,  4,  2,  0/
      DATA (KRELOC(  6,  0,  3,  K), K= 0, 3) / -90,  4,  0,  2/
      DATA (KRELOC(  6,  0,  4,  K), K= 0, 3) /  15,  2,  4,  0/
      DATA (KRELOC(  6,  0,  5,  K), K= 0, 3) /-180,  2,  2,  2/
      DATA (KRELOC(  6,  0,  6,  K), K= 0, 3) / 120,  2,  0,  4/
      DATA (KRELOC(  6,  0,  7,  K), K= 0, 3) /   5,  0,  6,  0/
      DATA (KRELOC(  6,  0,  8,  K), K= 0, 3) / -90,  0,  4,  2/
      DATA (KRELOC(  6,  0,  9,  K), K= 0, 3) / 120,  0,  2,  4/
      DATA (KRELOC(  6,  0, 10,  K), K= 0, 3) / -16,  0,  0,  6/
C
      DATA  NRELOC(  6,  0) /10/
C
C=======================================================================
C          LAMBDA=6  MIU=1  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  6,  1,      K), K= 1, 3) / -1,273,128/
C
C=======================================================================
C          Y61 REAL PART
C=======================================================================
C
      DATA (KRELOC(  6,  1,  1,  K), K= 0, 3) /  5,  5,  0,  1/
      DATA (KRELOC(  6,  1,  2,  K), K= 0, 3) / 10,  3,  2,  1/
      DATA (KRELOC(  6,  1,  3,  K), K= 0, 3) /-20,  3,  0,  3/
      DATA (KRELOC(  6,  1,  4,  K), K= 0, 3) /  5,  1,  4,  1/
      DATA (KRELOC(  6,  1,  5,  K), K= 0, 3) /-20,  1,  2,  3/
      DATA (KRELOC(  6,  1,  6,  K), K= 0, 3) /  8,  1,  0,  5/
C
      DATA  NRELOC(  6,  1) /6/
C
C=======================================================================
C          Y61 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  6,  1,  1,  K), K= 0, 3) /  5,  4,  1,  1/
      DATA (KIMLOC(  6,  1,  2,  K), K= 0, 3) / 10,  2,  3,  1/
      DATA (KIMLOC(  6,  1,  3,  K), K= 0, 3) /-20,  2,  1,  3/
      DATA (KIMLOC(  6,  1,  4,  K), K= 0, 3) /  5,  0,  5,  1/
      DATA (KIMLOC(  6,  1,  5,  K), K= 0, 3) /-20,  0,  3,  3/
      DATA (KIMLOC(  6,  1,  6,  K), K= 0, 3) /  8,  0,  1,  5/
C
      DATA  NIMLOC(  6,  1) /6/
C
C=======================================================================
C          LAMBDA=6  MIU=2  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  6,  2,      K), K= 1, 3) / 1,1365,1024/
C
C=======================================================================
C          Y62 REAL PART
C=======================================================================
C
      DATA (KRELOC(  6,  2,  1,  K), K= 0, 3) /  1,  6,  0,  0/
      DATA (KRELOC(  6,  2,  2,  K), K= 0, 3) /  1,  4,  2,  0/
      DATA (KRELOC(  6,  2,  3,  K), K= 0, 3) /-16,  4,  0,  2/
      DATA (KRELOC(  6,  2,  4,  K), K= 0, 3) / -1,  2,  4,  0/
      DATA (KRELOC(  6,  2,  5,  K), K= 0, 3) / 16,  2,  0,  4/
      DATA (KRELOC(  6,  2,  6,  K), K= 0, 3) / -1,  0,  6,  0/
      DATA (KRELOC(  6,  2,  7,  K), K= 0, 3) / 16,  0,  4,  2/
      DATA (KRELOC(  6,  2,  8,  K), K= 0, 3) /-16,  0,  2,  4/
C
      DATA  NRELOC(  6,  2) /8/
C
C=======================================================================
C          Y62 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  6,  2,  1,  K), K= 0, 3) /  2,  5,  1,  0/
      DATA (KIMLOC(  6,  2,  2,  K), K= 0, 3) /  4,  3,  3,  0/
      DATA (KIMLOC(  6,  2,  3,  K), K= 0, 3) /-32,  3,  1,  2/
      DATA (KIMLOC(  6,  2,  4,  K), K= 0, 3) /  2,  1,  5,  0/
      DATA (KIMLOC(  6,  2,  5,  K), K= 0, 3) /-32,  1,  3,  2/
      DATA (KIMLOC(  6,  2,  6,  K), K= 0, 3) / 32,  1,  1,  4/
C
      DATA  NIMLOC(  6,  2) /6/
C
C=======================================================================
C          LAMBDA=6  MIU=3  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  6,  3,      K), K= 1, 3) /  1,1365,256/
C
C=======================================================================
C          Y63 REAL PART
C=======================================================================
C
      DATA (KRELOC(  6,  3,  1,  K), K= 0, 3) /  3,  5,  0,  1/
      DATA (KRELOC(  6,  3,  2,  K), K= 0, 3) / -6,  3,  2,  1/
      DATA (KRELOC(  6,  3,  3,  K), K= 0, 3) / -8,  3,  0,  3/
      DATA (KRELOC(  6,  3,  4,  K), K= 0, 3) / -9,  1,  4,  1/
      DATA (KRELOC(  6,  3,  5,  K), K= 0, 3) / 24,  1,  2,  3/
C
      DATA  NRELOC(  6,  3) /5/
C
C=======================================================================
C          Y63 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  6,  3,  1,  K), K= 0, 3) /  9,  4,  1,  1/
      DATA (KIMLOC(  6,  3,  2,  K), K= 0, 3) /  6,  2,  3,  1/
      DATA (KIMLOC(  6,  3,  3,  K), K= 0, 3) /-24,  2,  1,  3/
      DATA (KIMLOC(  6,  3,  4,  K), K= 0, 3) / -3,  0,  5,  1/
      DATA (KIMLOC(  6,  3,  5,  K), K= 0, 3) /  8,  0,  3,  3/
C
      DATA  NIMLOC(  6,  3) /5/
C
C=======================================================================
C          LAMBDA=6  MIU=4  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  6,  4,      K), K= 1, 3) /  -1,819,512/
C
C=======================================================================
C          Y64 REAL PART
C=======================================================================
C
      DATA (KRELOC(  6,  4,  1,  K), K= 0, 3) /  1,  6,  0,  0/
      DATA (KRELOC(  6,  4,  2,  K), K= 0, 3) / -5,  4,  2,  0/
      DATA (KRELOC(  6,  4,  3,  K), K= 0, 3) /-10,  4,  0,  2/
      DATA (KRELOC(  6,  4,  4,  K), K= 0, 3) / -5,  2,  4,  0/
      DATA (KRELOC(  6,  4,  5,  K), K= 0, 3) / 60,  2,  2,  2/
      DATA (KRELOC(  6,  4,  6,  K), K= 0, 3) /  1,  0,  6,  0/
      DATA (KRELOC(  6,  4,  7,  K), K= 0, 3) /-10,  0,  4,  2/
C
      DATA  NRELOC(  6,  4) /7/
C
C=======================================================================
C          Y64 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  6,  4,  1,  K), K= 0, 3) /  4,  5,  1,  0/
      DATA (KIMLOC(  6,  4,  2,  K), K= 0, 3) /-40,  3,  1,  2/
      DATA (KIMLOC(  6,  4,  3,  K), K= 0, 3) / -4,  1,  5,  0/
      DATA (KIMLOC(  6,  4,  4,  K), K= 0, 3) / 40,  1,  3,  2/
C
      DATA  NIMLOC(  6,  4) /4/
C
C=======================================================================
C          LAMBDA=6  MIU=5  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  6,  5,      K), K= 1, 3) /  -1, 9009,256/
C
C=======================================================================
C          Y65 REAL PART
C=======================================================================
C
      DATA (KRELOC(  6,  5,  1,  K), K= 0, 3) /  1,  5,  0,  1/
      DATA (KRELOC(  6,  5,  2,  K), K= 0, 3) /-10,  3,  2,  1/
      DATA (KRELOC(  6,  5,  3,  K), K= 0, 3) /  5,  1,  4,  1/
C
      DATA  NRELOC(  6,  5) /3/
C
C=======================================================================
C          Y65 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  6,  5,  1,  K), K= 0, 3) /  5,  4,  1,  1/
      DATA (KIMLOC(  6,  5,  2,  K), K= 0, 3) /-10,  2,  3,  1/
      DATA (KIMLOC(  6,  5,  3,  K), K= 0, 3) /  1,  0,  5,  1/
C
      DATA  NIMLOC(  6,  5) /3/
C
C=======================================================================
C          LAMBDA=6  MIU=6  YLM=C *
C
C          C=
C=======================================================================
C
      DATA (KOELOC(  6,  6,      K), K= 1, 3) /   1, 3003,1024/
C
C=======================================================================
C          Y66 REAL PART
C=======================================================================
C
      DATA (KRELOC(  6,  6,  1,  K), K= 0, 3) /  1,  6,  0,  0/
      DATA (KRELOC(  6,  6,  2,  K), K= 0, 3) /-15,  4,  2,  0/
      DATA (KRELOC(  6,  6,  3,  K), K= 0, 3) / 15,  2,  4,  0/
      DATA (KRELOC(  6,  6,  4,  K), K= 0, 3) / -1,  0,  6,  0/
C
      DATA  NRELOC(  6,  6) /4/
C
C=======================================================================
C          Y65 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  6,  6,  1,  K), K= 0, 3) /  6,  5,  1,  0/
      DATA (KIMLOC(  6,  6,  2,  K), K= 0, 3) /-20,  3,  3,  0/
      DATA (KIMLOC(  6,  6,  3,  K), K= 0, 3) /  6,  1,  5,  0/
C
      DATA  NIMLOC(  6,  6) /3/
C
C=======================================================================
C          LAMBDA=7  MIU=0  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  7,  0,      K), K= 1, 3) / -1,  15, 256/
C
C=======================================================================
C          Y70 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  7,  0,  1,  K), K= 0, 3) /  35,  6,  0,  1/
      DATA (KRELOC(  7,  0,  2,  K), K= 0, 3) / 105,  4,  2,  1/
      DATA (KRELOC(  7,  0,  3,  K), K= 0, 3) /-210,  4,  0,  3/
      DATA (KRELOC(  7,  0,  4,  K), K= 0, 3) / 105,  2,  4,  1/
      DATA (KRELOC(  7,  0,  5,  K), K= 0, 3) /-420,  2,  2,  3/
      DATA (KRELOC(  7,  0,  6,  K), K= 0, 3) / 168,  2,  0,  5/
      DATA (KRELOC(  7,  0,  7,  K), K= 0, 3) /  35,  0,  6,  1/
      DATA (KRELOC(  7,  0,  8,  K), K= 0, 3) /-210,  0,  4,  3/
      DATA (KRELOC(  7,  0,  9,  K), K= 0, 3) / 168,  0,  2,  5/
      DATA (KRELOC(  7,  0, 10,  K), K= 0, 3) / -16,  0,  0,  7/
C
      DATA  NRELOC(  7,  0) /10/
C
C=======================================================================
C          LAMBDA=7  MIU=1  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  7,  1,      K), K= 1, 3) /  1,105,2048/
C
C=======================================================================
C          Y71 REAL PART
C=======================================================================
C
      DATA (KRELOC(  7,  1,  1,  K), K= 0, 3) /   5,  7,  0,  0/
      DATA (KRELOC(  7,  1,  2,  K), K= 0, 3) /  15,  5,  2,  0/
      DATA (KRELOC(  7,  1,  3,  K), K= 0, 3) /-120,  5,  0,  2/
      DATA (KRELOC(  7,  1,  4,  K), K= 0, 3) /  15,  3,  4,  0/
      DATA (KRELOC(  7,  1,  5,  K), K= 0, 3) /-240,  3,  2,  2/
      DATA (KRELOC(  7,  1,  6,  K), K= 0, 3) / 240,  3,  0,  4/
      DATA (KRELOC(  7,  1,  7,  K), K= 0, 3) /   5,  1,  6,  0/
      DATA (KRELOC(  7,  1,  8,  K), K= 0, 3) /-120,  1,  4,  2/
      DATA (KRELOC(  7,  1,  9,  K), K= 0, 3) / 240,  1,  2,  4/
      DATA (KRELOC(  7,  1, 10,  K), K= 0, 3) / -64,  1,  0,  6/
C
      DATA  NRELOC(  7,  1) /10/
C
C=======================================================================
C          Y71 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  7,  1,  1,  K), K= 0, 3) /   5,  6,  1,  0/
      DATA (KIMLOC(  7,  1,  2,  K), K= 0, 3) /  15,  4,  3,  0/
      DATA (KIMLOC(  7,  1,  3,  K), K= 0, 3) /-120,  4,  1,  2/
      DATA (KIMLOC(  7,  1,  4,  K), K= 0, 3) /  15,  2,  5,  0/
      DATA (KIMLOC(  7,  1,  5,  K), K= 0, 3) /-240,  2,  3,  2/
      DATA (KIMLOC(  7,  1,  6,  K), K= 0, 3) / 240,  2,  1,  4/
      DATA (KIMLOC(  7,  1,  7,  K), K= 0, 3) /   5,  0,  7,  0/
      DATA (KIMLOC(  7,  1,  8,  K), K= 0, 3) /-120,  0,  5,  2/
      DATA (KIMLOC(  7,  1,  9,  K), K= 0, 3) / 240,  0,  3,  4/
      DATA (KIMLOC(  7,  1, 10,  K), K= 0, 3) / -64,  0,  1,  6/
C
      DATA  NIMLOC(  7,  1) /10/
C
C=======================================================================
C          LAMBDA=7  MIU=2  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  7,  2,      K), K= 1, 3) / 1, 315, 1024/
C
C=======================================================================
C          Y72 REAL PART
C=======================================================================
C
      DATA (KRELOC(  7,  2,  1,  K), K= 0, 3) / 15,  6,  0,  1/
      DATA (KRELOC(  7,  2,  2,  K), K= 0, 3) / 15,  4,  2,  1/
      DATA (KRELOC(  7,  2,  3,  K), K= 0, 3) /-80,  4,  0,  3/
      DATA (KRELOC(  7,  2,  4,  K), K= 0, 3) /-15,  2,  4,  1/
      DATA (KRELOC(  7,  2,  5,  K), K= 0, 3) / 48,  2,  0,  5/
      DATA (KRELOC(  7,  2,  6,  K), K= 0, 3) /-15,  0,  6,  1/
      DATA (KRELOC(  7,  2,  7,  K), K= 0, 3) / 80,  0,  4,  3/
      DATA (KRELOC(  7,  2,  8,  K), K= 0, 3) /-48,  0,  2,  5/
C
      DATA  NRELOC(  7,  2) /8/
C
C=======================================================================
C          Y72 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  7,  2,  1,  K), K= 0, 3) /  30,  5,  1,  1/
      DATA (KIMLOC(  7,  2,  2,  K), K= 0, 3) /  60,  3,  3,  1/
      DATA (KIMLOC(  7,  2,  3,  K), K= 0, 3) /-160,  3,  1,  3/
      DATA (KIMLOC(  7,  2,  4,  K), K= 0, 3) /  30,  1,  5,  1/
      DATA (KIMLOC(  7,  2,  5,  K), K= 0, 3) /-160,  1,  3,  3/
      DATA (KIMLOC(  7,  2,  6,  K), K= 0, 3) /  96,  1,  1,  5/
C
      DATA  NIMLOC(  7,  2) /6/
C
C=======================================================================
C          LAMBDA=7  MIU=3  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  7,  3,      K), K= 1, 3) /  -1, 315, 2048/
C
C=======================================================================
C          Y73 REAL PART
C=======================================================================
C
      DATA (KRELOC(  7,  3,  1,  K), K= 0, 3) /   3,  7,  0,  0/
      DATA (KRELOC(  7,  3,  2,  K), K= 0, 3) /  -3,  5,  2,  0/
      DATA (KRELOC(  7,  3,  3,  K), K= 0, 3) / -60,  5,  0,  2/
      DATA (KRELOC(  7,  3,  4,  K), K= 0, 3) / -15,  3,  4,  0/
      DATA (KRELOC(  7,  3,  5,  K), K= 0, 3) / 120,  3,  2,  2/
      DATA (KRELOC(  7,  3,  6,  K), K= 0, 3) /  80,  3,  0,  4/
      DATA (KRELOC(  7,  3,  7,  K), K= 0, 3) /  -9,  1,  6,  0/
      DATA (KRELOC(  7,  3,  8,  K), K= 0, 3) / 180,  1,  4,  2/
      DATA (KRELOC(  7,  3,  9,  K), K= 0, 3) /-240,  1,  2,  4/
C
      DATA  NRELOC(  7,  3) /9/
C
C=======================================================================
C          Y73 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  7,  3,  1,  K), K= 0, 3) /   9,  6,  1,  0/
      DATA (KIMLOC(  7,  3,  2,  K), K= 0, 3) /  15,  4,  3,  0/
      DATA (KIMLOC(  7,  3,  3,  K), K= 0, 3) /-180,  4,  1,  2/
      DATA (KIMLOC(  7,  3,  4,  K), K= 0, 3) /   3,  2,  5,  0/
      DATA (KIMLOC(  7,  3,  5,  K), K= 0, 3) /-120,  2,  3,  2/
      DATA (KIMLOC(  7,  3,  6,  K), K= 0, 3) / 240,  2,  1,  4/
      DATA (KIMLOC(  7,  3,  7,  K), K= 0, 3) /  -3,  0,  7,  0/
      DATA (KIMLOC(  7,  3,  8,  K), K= 0, 3) /  60,  0,  5,  2/
      DATA (KIMLOC(  7,  3,  9,  K), K= 0, 3) / -80,  0,  3,  4/
C
      DATA  NIMLOC(  7,  3) /9/
C
C=======================================================================
C          LAMBDA=7  MIU=4  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  7,  4,      K), K= 1, 3) /  -1,3465,512/
C
C=======================================================================
C          Y74 REAL PART
C=======================================================================
C
      DATA (KRELOC(  7,  4,  1,  K), K= 0, 3) /  3,  6,  0,  1/
      DATA (KRELOC(  7,  4,  2,  K), K= 0, 3) /-15,  4,  2,  1/
      DATA (KRELOC(  7,  4,  3,  K), K= 0, 3) /-10,  4,  0,  3/
      DATA (KRELOC(  7,  4,  4,  K), K= 0, 3) /-15,  2,  4,  1/
      DATA (KRELOC(  7,  4,  5,  K), K= 0, 3) / 60,  2,  2,  3/
      DATA (KRELOC(  7,  4,  6,  K), K= 0, 3) /  3,  0,  6,  1/
      DATA (KRELOC(  7,  4,  7,  K), K= 0, 3) /-10,  0,  4,  3/
C
      DATA  NRELOC(  7,  4) /7/
C
C=======================================================================
C          Y74 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  7,  4,  1,  K), K= 0, 3) / 12,  5,  1,  1/
      DATA (KIMLOC(  7,  4,  2,  K), K= 0, 3) /-40,  3,  1,  3/
      DATA (KIMLOC(  7,  4,  3,  K), K= 0, 3) /-12,  1,  5,  1/
      DATA (KIMLOC(  7,  4,  4,  K), K= 0, 3) / 40,  1,  3,  3/
C
      DATA  NIMLOC(  7,  4) /4/
C
C=======================================================================
C          LAMBDA=7  MIU=5  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  7,  5,      K), K= 1, 3) /  1, 3465, 2048/
C
C=======================================================================
C          Y75 REAL PART
C=======================================================================
C
      DATA (KRELOC(  7,  5,  1,  K), K= 0, 3) /  1,  7,  0,  0/
      DATA (KRELOC(  7,  5,  2,  K), K= 0, 3) / -9,  5,  2,  0/
      DATA (KRELOC(  7,  5,  3,  K), K= 0, 3) /-12,  5,  0,  2/
      DATA (KRELOC(  7,  5,  4,  K), K= 0, 3) / -5,  3,  4,  0/
      DATA (KRELOC(  7,  5,  5,  K), K= 0, 3) /120,  3,  2,  2/
      DATA (KRELOC(  7,  5,  6,  K), K= 0, 3) /  5,  1,  6,  0/
      DATA (KRELOC(  7,  5,  7,  K), K= 0, 3) /-60,  1,  4,  2/
C
      DATA  NRELOC(  7,  5) /7/
C
C=======================================================================
C          Y75 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  7,  5,  1,  K), K= 0, 3) /  5,  6,  1,  0/
      DATA (KIMLOC(  7,  5,  2,  K), K= 0, 3) / -5,  4,  3,  0/
      DATA (KIMLOC(  7,  5,  3,  K), K= 0, 3) /-60,  4,  1,  2/
      DATA (KIMLOC(  7,  5,  4,  K), K= 0, 3) / -9,  2,  5,  0/
      DATA (KIMLOC(  7,  5,  5,  K), K= 0, 3) /120,  2,  3,  2/
      DATA (KIMLOC(  7,  5,  6,  K), K= 0, 3) /  1,  0,  7,  0/
      DATA (KIMLOC(  7,  5,  7,  K), K= 0, 3) /-12,  0,  5,  2/
C
      DATA  NIMLOC(  7,  5) /7/
C
C=======================================================================
C          LAMBDA=7  MIU=6  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  7,  6,      K), K= 1, 3) /   1, 45045, 1024/
C
C=======================================================================
C          Y76 REAL PART
C=======================================================================
C
      DATA (KRELOC(  7,  6,  1,  K), K= 0, 3) /  1,  6,  0,  1/
      DATA (KRELOC(  7,  6,  2,  K), K= 0, 3) /-15,  4,  2,  1/
      DATA (KRELOC(  7,  6,  3,  K), K= 0, 3) / 15,  2,  4,  1/
      DATA (KRELOC(  7,  6,  4,  K), K= 0, 3) / -1,  0,  6,  1/
C
      DATA  NRELOC(  7,  6) /4/
C
C=======================================================================
C          Y76 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  7,  6,  1,  K), K= 0, 3) /  6,  5,  1,  1/
      DATA (KIMLOC(  7,  6,  2,  K), K= 0, 3) /-20,  3,  3,  1/
      DATA (KIMLOC(  7,  6,  3,  K), K= 0, 3) /  6,  1,  5,  1/
C
      DATA  NIMLOC(  7,  6) /3/
C
C=======================================================================
C          LAMBDA=7  MIU=7  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  7,  7,      K), K= 1, 3) /  -1, 6435, 2048/
C
C=======================================================================
C          Y77 REAL PART
C=======================================================================
C
      DATA (KRELOC(  7,  7,  1,  K), K= 0, 3) /  1,  7,  0,  0/
      DATA (KRELOC(  7,  7,  2,  K), K= 0, 3) /-21,  5,  2,  0/
      DATA (KRELOC(  7,  7,  3,  K), K= 0, 3) / 35,  3,  4,  0/
      DATA (KRELOC(  7,  7,  4,  K), K= 0, 3) / -7,  1,  6,  0/
C
      DATA  NRELOC(  7,  7) /4/
C
C=======================================================================
C          Y77 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  7,  7,  1,  K), K= 0, 3) /  7,  6,  1,  0/
      DATA (KIMLOC(  7,  7,  2,  K), K= 0, 3) /-35,  4,  3,  0/
      DATA (KIMLOC(  7,  7,  3,  K), K= 0, 3) / 21,  2,  5,  0/
      DATA (KIMLOC(  7,  7,  4,  K), K= 0, 3) / -1,  0,  7,  0/
C
      DATA  NIMLOC(  7,  7) /4/
C
C
C=======================================================================
C          LAMBDA=8  MIU=0  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  0,      K), K= 1, 3) /  1,  17, 16384/
C
C=======================================================================
C          Y80 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  8,  0,  1,  K), K= 0, 3) /   35,  8,  0,  0/
      DATA (KRELOC(  8,  0,  2,  K), K= 0, 3) /  140,  6,  2,  0/
      DATA (KRELOC(  8,  0,  3,  K), K= 0, 3) /-1120,  6,  0,  2/
      DATA (KRELOC(  8,  0,  4,  K), K= 0, 3) /  210,  4,  4,  0/
      DATA (KRELOC(  8,  0,  5,  K), K= 0, 3) /-3360,  4,  2,  2/
      DATA (KRELOC(  8,  0,  6,  K), K= 0, 3) / 3360,  4,  0,  4/
      DATA (KRELOC(  8,  0,  7,  K), K= 0, 3) /  140,  2,  6,  0/
      DATA (KRELOC(  8,  0,  8,  K), K= 0, 3) /-3360,  2,  4,  2/
      DATA (KRELOC(  8,  0,  9,  K), K= 0, 3) / 6720,  2,  2,  4/
      DATA (KRELOC(  8,  0, 10,  K), K= 0, 3) /-1792,  2,  0,  6/
      DATA (KRELOC(  8,  0, 11,  K), K= 0, 3) /   35,  0,  8,  0/
      DATA (KRELOC(  8,  0, 12,  K), K= 0, 3) /-1120,  0,  6,  2/
      DATA (KRELOC(  8,  0, 13,  K), K= 0, 3) / 3360,  0,  4,  4/
      DATA (KRELOC(  8,  0, 14,  K), K= 0, 3) /-1792,  0,  2,  6/
      DATA (KRELOC(  8,  0, 15,  K), K= 0, 3) /  128,  0,  0,  8/
C
      DATA  NRELOC(  8,  0) /15/
C
C=======================================================================
C          LAMBDA=8  MIU=1  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  1,      K), K= 1, 3) /  1,153,2048/
C
C=======================================================================
C          Y81 REAL PART
C=======================================================================
C
      DATA (KRELOC(  8,  1,  1,  K), K= 0, 3) /  35,  7,  0,  1/
      DATA (KRELOC(  8,  1,  2,  K), K= 0, 3) / 105,  5,  2,  1/
      DATA (KRELOC(  8,  1,  3,  K), K= 0, 3) /-280,  5,  0,  3/
      DATA (KRELOC(  8,  1,  4,  K), K= 0, 3) / 105,  3,  4,  1/
      DATA (KRELOC(  8,  1,  5,  K), K= 0, 3) /-560,  3,  2,  3/
      DATA (KRELOC(  8,  1,  6,  K), K= 0, 3) / 336,  3,  0,  5/
      DATA (KRELOC(  8,  1,  7,  K), K= 0, 3) /  35,  1,  6,  1/
      DATA (KRELOC(  8,  1,  8,  K), K= 0, 3) /-280,  1,  4,  3/
      DATA (KRELOC(  8,  1,  9,  K), K= 0, 3) / 336,  1,  2,  5/
      DATA (KRELOC(  8,  1, 10,  K), K= 0, 3) / -64,  1,  0,  7/
C
      DATA  NRELOC(  8,  1) /10/
C
C=======================================================================
C          Y81 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  8,  1,  1,  K), K= 0, 3) /  35,  6,  1,  1/
      DATA (KIMLOC(  8,  1,  2,  K), K= 0, 3) / 105,  4,  3,  1/
      DATA (KIMLOC(  8,  1,  3,  K), K= 0, 3) /-280,  4,  1,  3/
      DATA (KIMLOC(  8,  1,  4,  K), K= 0, 3) / 105,  2,  5,  1/
      DATA (KIMLOC(  8,  1,  5,  K), K= 0, 3) /-560,  2,  3,  3/
      DATA (KIMLOC(  8,  1,  6,  K), K= 0, 3) / 336,  2,  1,  5/
      DATA (KIMLOC(  8,  1,  7,  K), K= 0, 3) /  35,  0,  7,  1/
      DATA (KIMLOC(  8,  1,  8,  K), K= 0, 3) /-280,  0,  5,  3/
      DATA (KIMLOC(  8,  1,  9,  K), K= 0, 3) / 336,  0,  3,  5/
      DATA (KIMLOC(  8,  1, 10,  K), K= 0, 3) / -64,  0,  1,  7/
C
      DATA  NIMLOC(  8,  1) /10/
C
C=======================================================================
C          LAMBDA=8  MIU=2  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  2,      K), K= 1, 3) /-1, 5355, 4096/
C
C=======================================================================
C          Y82 REAL PART
C=======================================================================
C
      DATA (KRELOC(  8,  2,  1,  K), K= 0, 3) /  1,  8,  0,  0/
      DATA (KRELOC(  8,  2,  2,  K), K= 0, 3) /  2,  6,  2,  0/
      DATA (KRELOC(  8,  2,  3,  K), K= 0, 3) /-30,  6,  0,  2/
      DATA (KRELOC(  8,  2,  4,  K), K= 0, 3) /-30,  4,  2,  2/
      DATA (KRELOC(  8,  2,  5,  K), K= 0, 3) / 80,  4,  0,  4/
      DATA (KRELOC(  8,  2,  6,  K), K= 0, 3) / -2,  2,  6,  0/
      DATA (KRELOC(  8,  2,  7,  K), K= 0, 3) / 30,  2,  4,  2/
      DATA (KRELOC(  8,  2,  8,  K), K= 0, 3) /-32,  2,  0,  6/
      DATA (KRELOC(  8,  2,  9,  K), K= 0, 3) / -1,  0,  8,  0/
      DATA (KRELOC(  8,  2, 10,  K), K= 0, 3) / 30,  0,  6,  2/
      DATA (KRELOC(  8,  2, 11,  K), K= 0, 3) /-80,  0,  4,  4/
      DATA (KRELOC(  8,  2, 12,  K), K= 0, 3) / 32,  0,  2,  6/
C
      DATA  NRELOC(  8,  2) /12/
C
C=======================================================================
C          Y82 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  8,  2,  1,  K), K= 0, 3) /   2,  7,  1,  0/
      DATA (KIMLOC(  8,  2,  2,  K), K= 0, 3) /   6,  5,  3,  0/
      DATA (KIMLOC(  8,  2,  3,  K), K= 0, 3) / -60,  5,  1,  2/
      DATA (KIMLOC(  8,  2,  4,  K), K= 0, 3) /   6,  3,  5,  0/
      DATA (KIMLOC(  8,  2,  5,  K), K= 0, 3) /-120,  3,  3,  2/
      DATA (KIMLOC(  8,  2,  6,  K), K= 0, 3) / 160,  3,  1,  4/
      DATA (KIMLOC(  8,  2,  7,  K), K= 0, 3) /   2,  1,  7,  0/
      DATA (KIMLOC(  8,  2,  8,  K), K= 0, 3) / -60,  1,  5,  2/
      DATA (KIMLOC(  8,  2,  9,  K), K= 0, 3) / 160,  1,  3,  4/
      DATA (KIMLOC(  8,  2, 10,  K), K= 0, 3) / -64,  1,  1,  6/
C
      DATA  NIMLOC(  8,  2) /10/
C
C=======================================================================
C          LAMBDA=8  MIU=3  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  3,      K), K= 1, 3) /  -1, 19635, 2048/
C
C=======================================================================
C          Y83 REAL PART
C=======================================================================
C
      DATA (KRELOC(  8,  3,  1,  K), K= 0, 3) /   3,  7,  0,  1/
      DATA (KRELOC(  8,  3,  2,  K), K= 0, 3) /  -3,  5,  2,  1/
      DATA (KRELOC(  8,  3,  3,  K), K= 0, 3) / -20,  5,  0,  3/
      DATA (KRELOC(  8,  3,  4,  K), K= 0, 3) / -15,  3,  4,  1/
      DATA (KRELOC(  8,  3,  5,  K), K= 0, 3) /  40,  3,  2,  3/
      DATA (KRELOC(  8,  3,  6,  K), K= 0, 3) /  16,  3,  0,  5/
      DATA (KRELOC(  8,  3,  7,  K), K= 0, 3) /  -9,  1,  6,  1/
      DATA (KRELOC(  8,  3,  8,  K), K= 0, 3) /  60,  1,  4,  3/
      DATA (KRELOC(  8,  3,  9,  K), K= 0, 3) / -48,  1,  2,  5/
C
      DATA  NRELOC(  8,  3) /9/
C
C=======================================================================
C          Y83 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  8,  3,  1,  K), K= 0, 3) /   9,  6,  1,  1/
      DATA (KIMLOC(  8,  3,  2,  K), K= 0, 3) /  15,  4,  3,  1/
      DATA (KIMLOC(  8,  3,  3,  K), K= 0, 3) / -60,  4,  1,  3/
      DATA (KIMLOC(  8,  3,  4,  K), K= 0, 3) /   3,  2,  5,  1/
      DATA (KIMLOC(  8,  3,  5,  K), K= 0, 3) / -40,  2,  3,  3/
      DATA (KIMLOC(  8,  3,  6,  K), K= 0, 3) /  48,  2,  1,  5/
      DATA (KIMLOC(  8,  3,  7,  K), K= 0, 3) /  -3,  0,  7,  1/
      DATA (KIMLOC(  8,  3,  8,  K), K= 0, 3) /  20,  0,  5,  3/
      DATA (KIMLOC(  8,  3,  9,  K), K= 0, 3) / -16,  0,  3,  5/
C
      DATA  NIMLOC(  8,  3) /9/
C
C=======================================================================
C          LAMBDA=8  MIU=4  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  4,      K), K= 1, 3) /   1,11781,8192/
C
C=======================================================================
C          Y84 REAL PART
C=======================================================================
C
      DATA (KRELOC(  8,  4,  1,  K), K= 0, 3) /   1,  8,  0,  0/
      DATA (KRELOC(  8,  4,  2,  K), K= 0, 3) /  -4,  6,  2,  0/
      DATA (KRELOC(  8,  4,  3,  K), K= 0, 3) / -24,  6,  0,  2/
      DATA (KRELOC(  8,  4,  4,  K), K= 0, 3) / -10,  4,  4,  0/
      DATA (KRELOC(  8,  4,  5,  K), K= 0, 3) / 120,  4,  2,  2/
      DATA (KRELOC(  8,  4,  6,  K), K= 0, 3) /  40,  4,  0,  4/
      DATA (KRELOC(  8,  4,  7,  K), K= 0, 3) /  -4,  2,  6,  0/
      DATA (KRELOC(  8,  4,  8,  K), K= 0, 3) / 120,  2,  4,  2/
      DATA (KRELOC(  8,  4,  9,  K), K= 0, 3) /-240,  2,  2,  4/
      DATA (KRELOC(  8,  4, 10,  K), K= 0, 3) /   1,  0,  8,  0/
      DATA (KRELOC(  8,  4, 11,  K), K= 0, 3) / -24,  0,  6,  2/
      DATA (KRELOC(  8,  4, 12,  K), K= 0, 3) /  40,  0,  4,  4/
C
      DATA  NRELOC(  8,  4) /12/
C
C=======================================================================
C          Y84 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  8,  4,  1,  K), K= 0, 3) /   4,  7,  1,  0/
      DATA (KIMLOC(  8,  4,  2,  K), K= 0, 3) /   4,  5,  3,  0/
      DATA (KIMLOC(  8,  4,  3,  K), K= 0, 3) / -96,  5,  1,  2/
      DATA (KIMLOC(  8,  4,  4,  K), K= 0, 3) /  -4,  3,  5,  0/
      DATA (KIMLOC(  8,  4,  5,  K), K= 0, 3) / 160,  3,  1,  4/
      DATA (KIMLOC(  8,  4,  6,  K), K= 0, 3) /  -4,  1,  7,  0/
      DATA (KIMLOC(  8,  4,  7,  K), K= 0, 3) /  96,  1,  5,  2/
      DATA (KIMLOC(  8,  4,  8,  K), K= 0, 3) /-160,  1,  3,  4/
C
      DATA  NIMLOC(  8,  4) /8/
C
C=======================================================================
C          LAMBDA=8  MIU=5  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  5,      K), K= 1, 3) /  1, 153153, 2048/
C
C=======================================================================
C          Y85 REAL PART
C=======================================================================
C
      DATA (KRELOC(  8,  5,  1,  K), K= 0, 3) /  1,  7,  0,  1/
      DATA (KRELOC(  8,  5,  2,  K), K= 0, 3) / -9,  5,  2,  1/
      DATA (KRELOC(  8,  5,  3,  K), K= 0, 3) / -4,  5,  0,  3/
      DATA (KRELOC(  8,  5,  4,  K), K= 0, 3) / -5,  3,  4,  1/
      DATA (KRELOC(  8,  5,  5,  K), K= 0, 3) / 40,  3,  2,  3/
      DATA (KRELOC(  8,  5,  6,  K), K= 0, 3) /  5,  1,  6,  1/
      DATA (KRELOC(  8,  5,  7,  K), K= 0, 3) /-20,  1,  4,  3/
C
      DATA  NRELOC(  8,  5) /7/
C
C=======================================================================
C          Y85 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  8,  5,  1,  K), K= 0, 3) /  5,  6,  1,  1/
      DATA (KIMLOC(  8,  5,  2,  K), K= 0, 3) / -5,  4,  3,  1/
      DATA (KIMLOC(  8,  5,  3,  K), K= 0, 3) /-20,  4,  1,  3/
      DATA (KIMLOC(  8,  5,  4,  K), K= 0, 3) / -9,  2,  5,  1/
      DATA (KIMLOC(  8,  5,  5,  K), K= 0, 3) / 40,  2,  3,  3/
      DATA (KIMLOC(  8,  5,  6,  K), K= 0, 3) /  1,  0,  7,  1/
      DATA (KIMLOC(  8,  5,  7,  K), K= 0, 3) / -4,  0,  5,  3/
C
      DATA  NIMLOC(  8,  5) /7/
C
C=======================================================================
C          LAMBDA=8  MIU=6  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  6,      K), K= 1, 3) /  -1,  7293, 4096/
C
C=======================================================================
C          Y86 REAL PART
C=======================================================================
C
      DATA (KRELOC(  8,  6,  1,  K), K= 0, 3) /   1,  8,  0,  0/
      DATA (KRELOC(  8,  6,  2,  K), K= 0, 3) / -14,  6,  2,  0/
      DATA (KRELOC(  8,  6,  3,  K), K= 0, 3) / -14,  6,  0,  2/
      DATA (KRELOC(  8,  6,  4,  K), K= 0, 3) / 210,  4,  2,  2/
      DATA (KRELOC(  8,  6,  5,  K), K= 0, 3) /  14,  2,  6,  0/
      DATA (KRELOC(  8,  6,  6,  K), K= 0, 3) /-210,  2,  4,  2/
      DATA (KRELOC(  8,  6,  7,  K), K= 0, 3) /  -1,  0,  8,  0/
      DATA (KRELOC(  8,  6,  8,  K), K= 0, 3) /  14,  0,  6,  2/
C
      DATA  NRELOC(  8,  6) /8/
C
C=======================================================================
C          Y86 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  8,  6,  1,  K), K= 0, 3) /  6,  7,  1,  0/
      DATA (KIMLOC(  8,  6,  2,  K), K= 0, 3) /-14,  5,  3,  0/
      DATA (KIMLOC(  8,  6,  3,  K), K= 0, 3) /-84,  5,  1,  2/
      DATA (KIMLOC(  8,  6,  4,  K), K= 0, 3) /-14,  3,  5,  0/
      DATA (KIMLOC(  8,  6,  5,  K), K= 0, 3) /280,  3,  3,  2/
      DATA (KIMLOC(  8,  6,  6,  K), K= 0, 3) /  6,  1,  7,  0/
      DATA (KIMLOC(  8,  6,  7,  K), K= 0, 3) /-84,  1,  5,  2/
C
      DATA  NIMLOC(  8,  6) /7/
C
C=======================================================================
C          LAMBDA=8  MIU=7  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  7,      K), K= 1, 3) /  -1, 109395, 2048/
C
C=======================================================================
C          Y87 REAL PART
C=======================================================================
C
      DATA (KRELOC(  8,  7,  1,  K), K= 0, 3) /  1,  7,  0,  1/
      DATA (KRELOC(  8,  7,  2,  K), K= 0, 3) /-21,  5,  2,  1/
      DATA (KRELOC(  8,  7,  3,  K), K= 0, 3) / 35,  3,  4,  1/
      DATA (KRELOC(  8,  7,  4,  K), K= 0, 3) / -7,  1,  6,  1/
C
      DATA  NRELOC(  8,  7) /4/
C
C=======================================================================
C          Y87 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  8,  7,  1,  K), K= 0, 3) /  7,  6,  1,  1/
      DATA (KIMLOC(  8,  7,  2,  K), K= 0, 3) /-35,  4,  3,  1/
      DATA (KIMLOC(  8,  7,  3,  K), K= 0, 3) / 21,  2,  5,  1/
      DATA (KIMLOC(  8,  7,  4,  K), K= 0, 3) / -1,  0,  7,  1/
C
      DATA  NIMLOC(  8,  7) /4/
C
C=======================================================================
C          LAMBDA=8  MIU=8  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  8,  8,      K), K= 1, 3) /  1, 109395, 32768/
C
C=======================================================================
C          Y88 REAL PART
C=======================================================================
C
      DATA (KRELOC(  8,  8,  1,  K), K= 0, 3) /  1,  8,  0,  0/
      DATA (KRELOC(  8,  8,  2,  K), K= 0, 3) /-28,  6,  2,  0/
      DATA (KRELOC(  8,  8,  3,  K), K= 0, 3) / 70,  4,  4,  0/
      DATA (KRELOC(  8,  8,  4,  K), K= 0, 3) /-28,  2,  6,  0/
      DATA (KRELOC(  8,  8,  5,  K), K= 0, 3) /  1,  0,  8,  0/
C
      DATA  NRELOC(  8,  8) /5/
C
C=======================================================================
C          Y88 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  8,  8,  1,  K), K= 0, 3) /  8,  7,  1,  0/
      DATA (KIMLOC(  8,  8,  2,  K), K= 0, 3) /-56,  5,  3,  0/
      DATA (KIMLOC(  8,  8,  3,  K), K= 0, 3) / 56,  3,  5,  0/
      DATA (KIMLOC(  8,  8,  4,  K), K= 0, 3) / -8,  1,  7,  0/
C
      DATA  NIMLOC(  8,  8) /4/
C=======================================================================
C          LAMBDA=9  MIU=0  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  0,      K), K= 1, 3) /  1,  19, 16384/
C
C=======================================================================
C          Y90 REAL PART ONLY
C=======================================================================
C
      DATA (KRELOC(  9,  0,  1,  K), K= 0, 3) /   315,  8,  0,  1/
      DATA (KRELOC(  9,  0,  2,  K), K= 0, 3) /  1260,  6,  2,  1/
      DATA (KRELOC(  9,  0,  3,  K), K= 0, 3) / -3360,  6,  0,  3/
      DATA (KRELOC(  9,  0,  4,  K), K= 0, 3) /  1890,  4,  4,  1/
      DATA (KRELOC(  9,  0,  5,  K), K= 0, 3) /-10080,  4,  2,  3/
      DATA (KRELOC(  9,  0,  6,  K), K= 0, 3) /  6048,  4,  0,  5/
      DATA (KRELOC(  9,  0,  7,  K), K= 0, 3) /  1260,  2,  6,  1/
      DATA (KRELOC(  9,  0,  8,  K), K= 0, 3) /-10080,  2,  4,  3/
      DATA (KRELOC(  9,  0,  9,  K), K= 0, 3) / 12096,  2,  2,  5/
      DATA (KRELOC(  9,  0, 10,  K), K= 0, 3) / -2304,  2,  0,  7/
      DATA (KRELOC(  9,  0, 11,  K), K= 0, 3) /   315,  0,  8,  1/
      DATA (KRELOC(  9,  0, 12,  K), K= 0, 3) / -3360,  0,  6,  3/
      DATA (KRELOC(  9,  0, 13,  K), K= 0, 3) /  6048,  0,  4,  5/
      DATA (KRELOC(  9,  0, 14,  K), K= 0, 3) / -2304,  0,  2,  7/
      DATA (KRELOC(  9,  0, 15,  K), K= 0, 3) /   128,  0,  0,  9/
C
      DATA  NRELOC(  9,  0) /15/
C
C=======================================================================
C          LAMBDA=9  MIU=1  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  1,      K), K= 1, 3) /  -1, 855, 32768/
C
C=======================================================================
C          Y91 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  1,  1,  K), K= 0, 3) /   7,  9,  0,  0/
      DATA (KRELOC(  9,  1,  2,  K), K= 0, 3) /  28,  7,  2,  0/
      DATA (KRELOC(  9,  1,  3,  K), K= 0, 3) /-280,  7,  0,  2/
      DATA (KRELOC(  9,  1,  4,  K), K= 0, 3) /  42,  5,  4,  0/
      DATA (KRELOC(  9,  1,  5,  K), K= 0, 3) /-840,  5,  2,  2/
      DATA (KRELOC(  9,  1,  6,  K), K= 0, 3) /1120,  5,  0,  4/
      DATA (KRELOC(  9,  1,  7,  K), K= 0, 3) /  28,  3,  6,  0/
      DATA (KRELOC(  9,  1,  8,  K), K= 0, 3) /-840,  3,  4,  2/
      DATA (KRELOC(  9,  1,  9,  K), K= 0, 3) /2240,  3,  2,  4/
      DATA (KRELOC(  9,  1, 10,  K), K= 0, 3) /-896,  3,  0,  6/
      DATA (KRELOC(  9,  1, 11,  K), K= 0, 3) /   7,  1,  8,  0/
      DATA (KRELOC(  9,  1, 12,  K), K= 0, 3) /-280,  1,  6,  2/
      DATA (KRELOC(  9,  1, 13,  K), K= 0, 3) /1120,  1,  4,  4/
      DATA (KRELOC(  9,  1, 14,  K), K= 0, 3) /-896,  1,  2,  6/
      DATA (KRELOC(  9,  1, 15,  K), K= 0, 3) / 128,  1,  0,  8/
C
      DATA  NRELOC(  9,  1) /15/
C
C=======================================================================
C          Y91 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  1,  1,  K), K= 0, 3) /   7,  8,  1,  0/
      DATA (KIMLOC(  9,  1,  2,  K), K= 0, 3) /  28,  6,  3,  0/
      DATA (KIMLOC(  9,  1,  3,  K), K= 0, 3) /-280,  6,  1,  2/
      DATA (KIMLOC(  9,  1,  4,  K), K= 0, 3) /  42,  4,  5,  0/
      DATA (KIMLOC(  9,  1,  5,  K), K= 0, 3) /-840,  4,  3,  2/
      DATA (KIMLOC(  9,  1,  6,  K), K= 0, 3) /1120,  4,  1,  4/
      DATA (KIMLOC(  9,  1,  7,  K), K= 0, 3) /  28,  2,  7,  0/
      DATA (KIMLOC(  9,  1,  8,  K), K= 0, 3) /-840,  2,  5,  2/
      DATA (KIMLOC(  9,  1,  9,  K), K= 0, 3) /2240,  2,  3,  4/
      DATA (KIMLOC(  9,  1, 10,  K), K= 0, 3) /-896,  2,  1,  6/
      DATA (KIMLOC(  9,  1, 11,  K), K= 0, 3) /   7,  0,  9,  0/
      DATA (KIMLOC(  9,  1, 12,  K), K= 0, 3) /-280,  0,  7,  2/
      DATA (KIMLOC(  9,  1, 13,  K), K= 0, 3) /1120,  0,  5,  4/
      DATA (KIMLOC(  9,  1, 14,  K), K= 0, 3) /-896,  0,  3,  6/
      DATA (KIMLOC(  9,  1, 15,  K), K= 0, 3) / 128,  0,  1,  8/
C
      DATA  NIMLOC(  9,  1) /15/
C
C=======================================================================
C          LAMBDA=9  MIU=2  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  2,      K), K= 1, 3) /-1, 9405, 4096/
C
C=======================================================================
C          Y92 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  2,  1,  K), K= 0, 3) /   7,  8,  0,  1/
      DATA (KRELOC(  9,  2,  2,  K), K= 0, 3) /  14,  6,  2,  1/
      DATA (KRELOC(  9,  2,  3,  K), K= 0, 3) / -70,  6,  0,  3/
      DATA (KRELOC(  9,  2,  4,  K), K= 0, 3) / -70,  4,  2,  3/
      DATA (KRELOC(  9,  2,  5,  K), K= 0, 3) / 112,  4,  0,  5/
      DATA (KRELOC(  9,  2,  6,  K), K= 0, 3) / -14,  2,  6,  1/
      DATA (KRELOC(  9,  2,  7,  K), K= 0, 3) /  70,  2,  4,  3/
      DATA (KRELOC(  9,  2,  8,  K), K= 0, 3) / -32,  2,  0,  7/
      DATA (KRELOC(  9,  2,  9,  K), K= 0, 3) /  -7,  0,  8,  1/
      DATA (KRELOC(  9,  2, 10,  K), K= 0, 3) /  70,  0,  6,  3/
      DATA (KRELOC(  9,  2, 11,  K), K= 0, 3) /-112,  0,  4,  5/
      DATA (KRELOC(  9,  2, 12,  K), K= 0, 3) /  32,  0,  2,  7/
C
      DATA  NRELOC(  9,  2) /12/
C
C=======================================================================
C          Y92 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  2,  1,  K), K= 0, 3) /  14,  7,  1,  1/
      DATA (KIMLOC(  9,  2,  2,  K), K= 0, 3) /  42,  5,  3,  1/
      DATA (KIMLOC(  9,  2,  3,  K), K= 0, 3) /-140,  5,  1,  3/
      DATA (KIMLOC(  9,  2,  4,  K), K= 0, 3) /  42,  3,  5,  1/
      DATA (KIMLOC(  9,  2,  5,  K), K= 0, 3) /-280,  3,  3,  3/
      DATA (KIMLOC(  9,  2,  6,  K), K= 0, 3) / 224,  3,  1,  5/
      DATA (KIMLOC(  9,  2,  7,  K), K= 0, 3) /  14,  1,  7,  1/
      DATA (KIMLOC(  9,  2,  8,  K), K= 0, 3) /-140,  1,  5,  3/
      DATA (KIMLOC(  9,  2,  9,  K), K= 0, 3) / 224,  1,  3,  5/
      DATA (KIMLOC(  9,  2, 10,  K), K= 0, 3) / -64,  1,  1,  7/
C
      DATA  NIMLOC(  9,  2) /10/
C
C=======================================================================
C          LAMBDA=9  MIU=3  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  3,      K), K= 1, 3) /  1, 21945, 16384/
C
C=======================================================================
C          Y93 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  3,  1,  K), K= 0, 3) /   1,  9,  0,  0/
      DATA (KRELOC(  9,  3,  2,  K), K= 0, 3) / -36,  7,  0,  2/
      DATA (KRELOC(  9,  3,  3,  K), K= 0, 3) /  -6,  5,  4,  0/
      DATA (KRELOC(  9,  3,  4,  K), K= 0, 3) /  36,  5,  2,  2/
      DATA (KRELOC(  9,  3,  5,  K), K= 0, 3) / 120,  5,  0,  4/
      DATA (KRELOC(  9,  3,  6,  K), K= 0, 3) /  -8,  3,  6,  0/
      DATA (KRELOC(  9,  3,  7,  K), K= 0, 3) / 180,  3,  4,  2/
      DATA (KRELOC(  9,  3,  8,  K), K= 0, 3) /-240,  3,  2,  4/
      DATA (KRELOC(  9,  3,  9,  K), K= 0, 3) / -64,  3,  0,  6/
      DATA (KRELOC(  9,  3, 10,  K), K= 0, 3) /  -3,  1,  8,  0/
      DATA (KRELOC(  9,  3, 11,  K), K= 0, 3) / 108,  1,  6,  2/
      DATA (KRELOC(  9,  3, 12,  K), K= 0, 3) /-360,  1,  4,  4/
      DATA (KRELOC(  9,  3, 13,  K), K= 0, 3) / 192,  1,  2,  6/
C
      DATA  NRELOC(  9,  3) /13/
C
C=======================================================================
C          Y93 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  3,  1,  K), K= 0, 3) /   3,  8,  1,  0/
      DATA (KIMLOC(  9,  3,  2,  K), K= 0, 3) /   8,  6,  3,  0/
      DATA (KIMLOC(  9,  3,  3,  K), K= 0, 3) /-108,  6,  1,  2/
      DATA (KIMLOC(  9,  3,  4,  K), K= 0, 3) /   6,  4,  5,  0/
      DATA (KIMLOC(  9,  3,  5,  K), K= 0, 3) /-180,  4,  3,  2/
      DATA (KIMLOC(  9,  3,  6,  K), K= 0, 3) / 360,  4,  1,  4/
      DATA (KIMLOC(  9,  3,  7,  K), K= 0, 3) / -36,  2,  5,  2/
      DATA (KIMLOC(  9,  3,  8,  K), K= 0, 3) / 240,  2,  3,  4/
      DATA (KIMLOC(  9,  3,  9,  K), K= 0, 3) /-192,  2,  1,  6/
      DATA (KIMLOC(  9,  3, 10,  K), K= 0, 3) /  -1,  0,  9,  0/
      DATA (KIMLOC(  9,  3, 11,  K), K= 0, 3) /  36,  0,  7,  2/
      DATA (KIMLOC(  9,  3, 12,  K), K= 0, 3) /-120,  0,  5,  4/
      DATA (KIMLOC(  9,  3, 13,  K), K= 0, 3) /  64,  0,  3,  6/
C
      DATA  NIMLOC(  9,  3) /13/
C
C=======================================================================
C          LAMBDA=9  MIU=4  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  4,      K), K= 1, 3) /   1,855855,8192/
C
C=======================================================================
C          Y94 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  4,  1,  K), K= 0, 3) /  1,  8,  0,  1/
      DATA (KRELOC(  9,  4,  2,  K), K= 0, 3) / -4,  6,  2,  1/
      DATA (KRELOC(  9,  4,  3,  K), K= 0, 3) / -8,  6,  0,  3/
      DATA (KRELOC(  9,  4,  4,  K), K= 0, 3) /-10,  4,  4,  1/
      DATA (KRELOC(  9,  4,  5,  K), K= 0, 3) / 40,  4,  2,  3/
      DATA (KRELOC(  9,  4,  6,  K), K= 0, 3) /  8,  4,  0,  5/
      DATA (KRELOC(  9,  4,  7,  K), K= 0, 3) / -4,  2,  6,  1/
      DATA (KRELOC(  9,  4,  8,  K), K= 0, 3) / 40,  2,  4,  3/
      DATA (KRELOC(  9,  4,  9,  K), K= 0, 3) /-48,  2,  2,  5/
      DATA (KRELOC(  9,  4, 10,  K), K= 0, 3) /  1,  0,  8,  1/
      DATA (KRELOC(  9,  4, 11,  K), K= 0, 3) / -8,  0,  6,  3/
      DATA (KRELOC(  9,  4, 12,  K), K= 0, 3) /  8,  0,  4,  5/
C
      DATA  NRELOC(  9,  4) /12/
C
C=======================================================================
C          Y94 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  4,  1,  K), K= 0, 3) /   4,  7,  1,  1/
      DATA (KIMLOC(  9,  4,  2,  K), K= 0, 3) /   4,  5,  3,  1/
      DATA (KIMLOC(  9,  4,  3,  K), K= 0, 3) / -32,  5,  1,  3/
      DATA (KIMLOC(  9,  4,  4,  K), K= 0, 3) /  -4,  3,  5,  1/
      DATA (KIMLOC(  9,  4,  5,  K), K= 0, 3) /  32,  3,  1,  5/
      DATA (KIMLOC(  9,  4,  6,  K), K= 0, 3) /  -4,  1,  7,  1/
      DATA (KIMLOC(  9,  4,  7,  K), K= 0, 3) /  32,  1,  5,  3/
      DATA (KIMLOC(  9,  4,  8,  K), K= 0, 3) / -32,  1,  3,  5/
C
      DATA  NIMLOC(  9,  4) /8/
C
C=======================================================================
C          LAMBDA=9  MIU=5  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  5,      K), K= 1, 3) / -1, 24453, 16384/
C
C=======================================================================
C          Y95 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  5,  1,  K), K= 0, 3) /   1,  9,  0,  0/
      DATA (KRELOC(  9,  5,  2,  K), K= 0, 3) /  -8,  7,  2,  0/
      DATA (KRELOC(  9,  5,  3,  K), K= 0, 3) / -28,  7,  0,  2/
      DATA (KRELOC(  9,  5,  4,  K), K= 0, 3) / -14,  5,  4,  0/
      DATA (KRELOC(  9,  5,  5,  K), K= 0, 3) / 252,  5,  2,  2/
      DATA (KRELOC(  9,  5,  6,  K), K= 0, 3) /  56,  5,  0,  4/
      DATA (KRELOC(  9,  5,  7,  K), K= 0, 3) / 140,  3,  4,  2/
      DATA (KRELOC(  9,  5,  8,  K), K= 0, 3) /-560,  3,  2,  4/
      DATA (KRELOC(  9,  5,  9,  K), K= 0, 3) /   5,  1,  8,  0/
      DATA (KRELOC(  9,  5, 10,  K), K= 0, 3) /-140,  1,  6,  2/
      DATA (KRELOC(  9,  5, 11,  K), K= 0, 3) / 280,  1,  4,  4/
C
      DATA  NRELOC(  9,  5) /11/
C
C=======================================================================
C          Y95 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  5,  1,  K), K= 0, 3) /   5,  8,  1,  0/
      DATA (KIMLOC(  9,  5,  2,  K), K= 0, 3) /-140,  6,  1,  2/
      DATA (KIMLOC(  9,  5,  3,  K), K= 0, 3) / -14,  4,  5,  0/
      DATA (KIMLOC(  9,  5,  4,  K), K= 0, 3) / 140,  4,  3,  2/
      DATA (KIMLOC(  9,  5,  5,  K), K= 0, 3) / 280,  4,  1,  4/
      DATA (KIMLOC(  9,  5,  6,  K), K= 0, 3) /  -8,  2,  7,  0/
      DATA (KIMLOC(  9,  5,  7,  K), K= 0, 3) / 252,  2,  5,  2/
      DATA (KIMLOC(  9,  5,  8,  K), K= 0, 3) /-560,  2,  3,  4/
      DATA (KIMLOC(  9,  5,  9,  K), K= 0, 3) /   1,  0,  9,  0/
      DATA (KIMLOC(  9,  5, 10,  K), K= 0, 3) / -28,  0,  7,  2/
      DATA (KIMLOC(  9,  5, 11,  K), K= 0, 3) /  56,  0,  5,  4/
C
      DATA  NIMLOC(  9,  5) /11/
C
C=======================================================================
C          LAMBDA=9  MIU=6  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  6,      K), K= 1, 3) /  -1,  40755, 4096/
C
C=======================================================================
C          Y96 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  6,  1,  K), K= 0, 3) /   3,  8,  0,  1/
      DATA (KRELOC(  9,  6,  2,  K), K= 0, 3) / -42,  6,  2,  1/
      DATA (KRELOC(  9,  6,  3,  K), K= 0, 3) / -14,  6,  0,  3/
      DATA (KRELOC(  9,  6,  4,  K), K= 0, 3) / 210,  4,  2,  3/
      DATA (KRELOC(  9,  6,  5,  K), K= 0, 3) /  42,  2,  6,  1/
      DATA (KRELOC(  9,  6,  6,  K), K= 0, 3) /-210,  2,  4,  3/
      DATA (KRELOC(  9,  6,  7,  K), K= 0, 3) /  -3,  0,  8,  1/
      DATA (KRELOC(  9,  6,  8,  K), K= 0, 3) /  14,  0,  6,  3/
C
      DATA  NRELOC(  9,  6) /8/
C
C=======================================================================
C          Y96 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  6,  1,  K), K= 0, 3) / 18,  7,  1,  1/
      DATA (KIMLOC(  9,  6,  2,  K), K= 0, 3) /-42,  5,  3,  1/
      DATA (KIMLOC(  9,  6,  3,  K), K= 0, 3) /-84,  5,  1,  3/
      DATA (KIMLOC(  9,  6,  4,  K), K= 0, 3) /-42,  3,  5,  1/
      DATA (KIMLOC(  9,  6,  5,  K), K= 0, 3) /280,  3,  3,  3/
      DATA (KIMLOC(  9,  6,  6,  K), K= 0, 3) / 18,  1,  7,  1/
      DATA (KIMLOC(  9,  6,  7,  K), K= 0, 3) /-84,  1,  5,  3/
C
      DATA  NIMLOC(  9,  6) /7/
C
C=======================================================================
C          LAMBDA=9  MIU=7  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  7,      K), K= 1, 3) /  1, 122265, 65536/
C
C=======================================================================
C          Y97 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  7,  1,  K), K= 0, 3) /   1,  9,  0,  0/
      DATA (KRELOC(  9,  7,  2,  K), K= 0, 3) / -20,  7,  2,  0/
      DATA (KRELOC(  9,  7,  3,  K), K= 0, 3) / -16,  7,  0,  2/
      DATA (KRELOC(  9,  7,  4,  K), K= 0, 3) /  14,  5,  4,  0/
      DATA (KRELOC(  9,  7,  5,  K), K= 0, 3) / 336,  5,  2,  2/
      DATA (KRELOC(  9,  7,  6,  K), K= 0, 3) /  28,  3,  6,  0/
      DATA (KRELOC(  9,  7,  7,  K), K= 0, 3) /-560,  3,  4,  2/
      DATA (KRELOC(  9,  7,  8,  K), K= 0, 3) /  -7,  1,  8,  0/
      DATA (KRELOC(  9,  7,  9,  K), K= 0, 3) / 112,  1,  6,  2/
C
      DATA  NRELOC(  9,  7) /9/
C
C=======================================================================
C          Y97 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  7,  1,  K), K= 0, 3) /   7,  8,  1,  0/
      DATA (KIMLOC(  9,  7,  2,  K), K= 0, 3) / -28,  6,  3,  0/
      DATA (KIMLOC(  9,  7,  3,  K), K= 0, 3) /-112,  6,  1,  2/
      DATA (KIMLOC(  9,  7,  4,  K), K= 0, 3) / -14,  4,  5,  0/
      DATA (KIMLOC(  9,  7,  5,  K), K= 0, 3) / 560,  4,  3,  2/
      DATA (KIMLOC(  9,  7,  6,  K), K= 0, 3) /  20,  2,  7,  0/
      DATA (KIMLOC(  9,  7,  7,  K), K= 0, 3) /-336,  2,  5,  2/
      DATA (KIMLOC(  9,  7,  8,  K), K= 0, 3) /  -1,  0,  9,  0/
      DATA (KIMLOC(  9,  7,  9,  K), K= 0, 3) /  16,  0,  7,  2/
C
      DATA  NIMLOC(  9,  7) /9/
C
C=======================================================================
C          LAMBDA=9  MIU=8  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  8,      K), K= 1, 3) /  1, 2078505, 32768/
C
C=======================================================================
C          Y98 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  8,  1,  K), K= 0, 3) /  1,  8,  0,  1/
      DATA (KRELOC(  9,  8,  2,  K), K= 0, 3) /-28,  6,  2,  1/
      DATA (KRELOC(  9,  8,  3,  K), K= 0, 3) / 70,  4,  4,  1/
      DATA (KRELOC(  9,  8,  4,  K), K= 0, 3) /-28,  2,  6,  1/
      DATA (KRELOC(  9,  8,  5,  K), K= 0, 3) /  1,  0,  8,  1/
C
      DATA  NRELOC(  9,  8) /5/
C
C=======================================================================
C          Y98 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  8,  1,  K), K= 0, 3) /  8,  7,  1,  1/
      DATA (KIMLOC(  9,  8,  2,  K), K= 0, 3) /-56,  5,  3,  1/
      DATA (KIMLOC(  9,  8,  3,  K), K= 0, 3) / 56,  3,  5,  1/
      DATA (KIMLOC(  9,  8,  4,  K), K= 0, 3) / -8,  1,  7,  1/
C
      DATA  NIMLOC(  9,  8) /4/
C
C=======================================================================
C          LAMBDA=9  MIU=9  YLM=C *
C          C=
C=======================================================================
C
      DATA (KOELOC(  9,  9,      K), K= 1, 3) / -1, 230945, 65536/
C
C=======================================================================
C          Y99 REAL PART
C=======================================================================
C
      DATA (KRELOC(  9,  9,  1,  K), K= 0, 3) /  1,  9,  0,  0/
      DATA (KRELOC(  9,  9,  2,  K), K= 0, 3) /-36,  7,  2,  0/
      DATA (KRELOC(  9,  9,  3,  K), K= 0, 3) /126,  5,  4,  0/
      DATA (KRELOC(  9,  9,  4,  K), K= 0, 3) /-84,  3,  6,  0/
      DATA (KRELOC(  9,  9,  5,  K), K= 0, 3) /  9,  1,  8,  0/
C
      DATA  NRELOC(  9,  9) /5/
C
C=======================================================================
C          Y99 IMAGINARY PART
C=======================================================================
C
      DATA (KIMLOC(  9,  9,  1,  K), K= 0, 3) /  9,  8,  1,  0/
      DATA (KIMLOC(  9,  9,  2,  K), K= 0, 3) /-84,  6,  3,  0/
      DATA (KIMLOC(  9,  9,  3,  K), K= 0, 3) /126,  4,  5,  0/
      DATA (KIMLOC(  9,  9,  4,  K), K= 0, 3) /-36,  2,  7,  0/
      DATA (KIMLOC(  9,  9,  5,  K), K= 0, 3) /  1,  0,  9,  0/
C
      DATA  NIMLOC(  9,  9) /5/
C
C=======================================================================
C          DETERMINING THE CONSTANT FACTORS AND REWRITING THE LOCAL
C          VARIABLES DEFINED IN  THE  DATA  STATEMENTS INTO COMMONS
C=======================================================================
C
      IF (MULMAX.NE.NDMULT) STOP 'MULMAX.NE.NDMULT IN DEFYLM'
C
      SQR4PI=SQRT(16.0D0*ATAN(1.0D0))
C
      DO LAMBDA=0,MULMAX
         DO MIU=0,LAMBDA
C
            COEYLM(LAMBDA,MIU) =           KOELOC(LAMBDA,MIU,1)
     *                         * SQRT(REAL(KOELOC(LAMBDA,MIU,2))
     *                               /REAL(KOELOC(LAMBDA,MIU,3)))
     *                               /SQR4PI
C
            NREYLM(LAMBDA,MIU) = NRELOC(LAMBDA,MIU)
C
            DO NUTERM=1,NREYLM(LAMBDA,MIU)
               DO KARTEZ=0,NDKART
C
                  KREYLM(LAMBDA,MIU,NUTERM,KARTEZ)=
     *            KRELOC(LAMBDA,MIU,NUTERM,KARTEZ)
C
               END DO
            END DO
C
            IF (MIU.GT.0) THEN
C
               NIMYLM(LAMBDA,MIU) = NIMLOC(LAMBDA,MIU)
C
               DO NUTERM=1,NIMYLM(LAMBDA,MIU)
                  DO KARTEZ=0,NDKART
C
                     KIMYLM(LAMBDA,MIU,NUTERM,KARTEZ)=
     *               KIMLOC(LAMBDA,MIU,NUTERM,KARTEZ)
C
                  END DO
               END DO
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFSLM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
C
      COMMON
     *       /DATSLM/ COESLM(0:NDMULT,0:NDMULT),
     *
     *                NRESLM(0:NDMULT,0:NDMULT),
     *                KRESLM(0:NDMULT,0:NDMULT,NDTERM*NDKART,0:NDKART),
     *
     *                NIMSLM(0:NDMULT,1:NDMULT),
     *                KIMSLM(0:NDMULT,1:NDMULT,NDTERM*NDKART,0:NDKART)
      DATA
     *        MULMAX / 9 /
C
C=======================================================================
C
C         THIS SUBROUTINE DEFINES THE TERMS APPEARING IN THE
C
C                   S U R F A C E    H A R M O N I C S
C
C         (SPHERICAL HARMONICS  *  R**(LAMBDA+2)).  THE CONVENTIONS USED
C         TO STORE THEM ARE EXACTLY THE SAME AS USED IN "DEFYLM" --- SEE
C         THE COMMENTS THERE. EACH TERM OF THE SOLID HARMONICS  IS  HERE
C         MULTIPLIED BY  R^2=X^2+Y^2+Z^2. HENCE THE NUMBER OF TERMS  NOW
C         BECOMES THREE TIMES LARGER. WE DO NOT CARE ABOUT THE FACT THAT
C         SOME OF THESE TERMS MIGHT HAVE THE SAME POWERS OF COORDINATES.
C
C=======================================================================
C
C         THIS SUBROUTINE DEFINES MULTIPOLES UP TO THE VALUE
C         OF "MULMAX" DEFINED ABOVE. THIS VALUE MUST NOT  BE
C         SMALLER THAN:
C
C                      NSIMAX < OR =  MULMAX
C
C         AS A SAFETY MEASURE,  THE  CODE REQUIRES THAT THE
C         DIMENSION  DECLARATION  "NDMULT"  IS  NECESSARILY
C         EQUAL TO "MULMAX".
C
C=======================================================================
C
      IF (MULMAX.NE.NDMULT) STOP 'MULMAX.NE.NDMULT IN DEFSLM'
C
C=======================================================================
C
      DO LAMBDA=0,MULMAX
         DO MIU=0,LAMBDA
C
            DO NUTERM=1,NREYLM(LAMBDA,MIU)
               DO KARTEZ=0,NDKART
                  DO KARTER=1,NDKART
C
                    KRESLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)=
     *              KREYLM(LAMBDA,MIU,NUTERM,                  KARTEZ)
C
                    IF (KARTER.EQ.KARTEZ)
     *
     *              KRESLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)=
     *              KRESLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)+2
C
                  END DO
               END DO
            END DO
C
            COESLM(LAMBDA,MIU)=       COEYLM(LAMBDA,MIU)
            NRESLM(LAMBDA,MIU)=NDKART*NREYLM(LAMBDA,MIU)
C
            IF (MIU.GT.0) THEN
C
            DO NUTERM=1,NIMYLM(LAMBDA,MIU)
               DO KARTEZ=0,NDKART
                  DO KARTER=1,NDKART
C
                    KIMSLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)=
     *              KIMYLM(LAMBDA,MIU,NUTERM,                  KARTEZ)
C
                    IF (KARTER.EQ.KARTEZ)
     *
     *              KIMSLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)=
     *              KIMSLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)+2
C
                  END DO
               END DO
            END DO
C
            NIMSLM(LAMBDA,MIU)=NDKART*NIMYLM(LAMBDA,MIU)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFPLM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DATSLM/ COESLM(0:NDMULT,0:NDMULT),
     *
     *                NRESLM(0:NDMULT,0:NDMULT),
     *                KRESLM(0:NDMULT,0:NDMULT,NDTERM*NDKART,0:NDKART),
     *
     *                NIMSLM(0:NDMULT,1:NDMULT),
     *                KIMSLM(0:NDMULT,1:NDMULT,NDTERM*NDKART,0:NDKART)
C
      COMMON
     *       /DATPLM/ COEPLM(0:NDMULT,0:NDMULT),
     *
     *                NREPLM(0:NDMULT,0:NDMULT),
     *                KREPLM(0:NDMULT,0:NDMULT,NDTERM*NDKART*NDKART,
     *                                                     0:NDKART),
     *
     *                NIMPLM(0:NDMULT,1:NDMULT),
     *                KIMPLM(0:NDMULT,1:NDMULT,NDTERM*NDKART*NDKART,
     *                                                     0:NDKART)
      DATA
     *        MULMAX / 9 /
C
C=======================================================================
C
C         THIS SUBROUTINE DEFINES THE TERMS APPEARING IN THE
C
C                   P E N S U R F A C E    H A R M O N I C S
C
C         (SPHERICAL HARMONICS  *  R**(LAMBDA+4)).  THE CONVENTIONS USED
C         TO STORE THEM ARE EXACTLY THE SAME AS USED IN "DEFYLM" --- SEE
C         THE COMMENTS THERE. EACH TERM OF THE SURFACE HARMONICS IS HERE
C         MULTIPLIED BY  R^2=X^2+Y^2+Z^2. HENCE THE NUMBER OF TERMS  NOW
C         BECOMES THREE TIMES LARGER THAN FOR THE SURFACE HARMONICS  AND
C         NINE TIMES LARGER THAN FOR THE SOLID HARMONICS. WE DO NOT CARE
C         ABOUT THE FACT THAT SOME OF THESE TERMS MIGHT  HAVE  THE  SAME
C         POWERS OF COORDINATES.
C
C=======================================================================
C
C         THIS SUBROUTINE DEFINES MULTIPOLES UP TO THE VALUE
C         OF "MULMAX" DEFINED ABOVE. THIS VALUE MUST NOT  BE
C         SMALLER THAN:
C
C                      NSIMAX < OR =  MULMAX
C
C         AS A SAFETY MEASURE,  THE  CODE REQUIRES THAT THE
C         DIMENSION  DECLARATION  "NDMULT"  IS  NECESSARILY
C         EQUAL TO "MULMAX".
C
C=======================================================================
C
      IF (MULMAX.NE.NDMULT) STOP 'MULMAX.NE.NDMULT IN DEFPLM'
C
C=======================================================================
C
      DO LAMBDA=0,MULMAX
         DO MIU=0,LAMBDA
C
            DO NUTERM=1,NRESLM(LAMBDA,MIU)
               DO KARTEZ=0,NDKART
                  DO KARTER=1,NDKART
C
                    KREPLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)=
     *              KRESLM(LAMBDA,MIU,NUTERM,                  KARTEZ)
C
                    IF (KARTER.EQ.KARTEZ)
     *
     *              KREPLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)=
     *              KREPLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)+2
C
                  END DO
               END DO
            END DO
C
            COEPLM(LAMBDA,MIU)=       COESLM(LAMBDA,MIU)
            NREPLM(LAMBDA,MIU)=NDKART*NRESLM(LAMBDA,MIU)
C
            IF (MIU.GT.0) THEN
C
            DO NUTERM=1,NIMSLM(LAMBDA,MIU)
               DO KARTEZ=0,NDKART
                  DO KARTER=1,NDKART
C
                    KIMPLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)=
     *              KIMSLM(LAMBDA,MIU,NUTERM,                  KARTEZ)
C
                    IF (KARTER.EQ.KARTEZ)
     *
     *              KIMPLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)=
     *              KIMPLM(LAMBDA,MIU,NDKART*(NUTERM-1)+KARTER,KARTEZ)+2
C
                  END DO
               END DO
            END DO
C
            NIMPLM(LAMBDA,MIU)=NDKART*NIMSLM(LAMBDA,MIU)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFVLM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
C
      COMMON
     *       /DATVLM/ COEVLM(0:NDMULT,0:NDMULT),
     *
     *                NREVLM(0:NDMULT,0:NDMULT),
     *                KREVLM(0:NDMULT,0:NDMULT,NDTERM,NDKART,0:NDKART),
     *
     *                NIMVLM(0:NDMULT,1:NDMULT),
     *                KIMVLM(0:NDMULT,1:NDMULT,NDTERM,NDKART,0:NDKART)
      DATA
     *        MULMAX / 9 /
C
C=======================================================================
C
C         THIS SUBROUTINE DEFINES THE TERMS APPEARING IN THE
C
C                   V E C T O R    H A R M O N I C S
C
C         =SPHERICAL HARMONICS*R**(LAMBDA)*(X,Y,Z). THE CONVENTIONS USED
C         TO STORE THEM ARE EXACTLY THE SAME AS USED IN "DEFYLM" --- SEE
C         THE COMMENTS THERE. EACH TERM OF THE SOLID HARMONICS  IS  HERE
C         MULTIPLIED BY  X  OR  Y  OR  Z. HENCE THE NUMBER OF TERMS  NOW
C         BECOMES THREE TIMES LARGER. THE ADDITIONAL INDEX  IS  USED  TO
C         INDICATE ONE OF THE THREE CARTESIAN COORDINATES.
C
C=======================================================================
C
C         THIS SUBROUTINE DEFINES MULTIPOLES UP TO THE VALUE
C         OF "MULMAX" DEFINED ABOVE. THIS VALUE MUST NOT  BE
C         SMALLER THAN:
C
C                      NSIMAX < OR =  MULMAX
C
C         AS A SAFETY MEASURE,  THE  CODE REQUIRES THAT THE
C         DIMENSION  DECLARATION  "NDMULT"  IS  NECESSARILY
C         EQUAL TO "MULMAX".
C
C=======================================================================
C
      IF (MULMAX.NE.NDMULT) STOP 'MULMAX.NE.NDMULT IN DEFVLM'
C
C=======================================================================
C
      DO LAMBDA=0,MULMAX
         DO MIU=0,LAMBDA
C
            DO NUTERM=1,NREYLM(LAMBDA,MIU)
               DO KARTEZ=0,NDKART
                  DO KARTER=1,NDKART
C
                    KREVLM(LAMBDA,MIU,NUTERM,KARTER,KARTEZ)=
     *              KREYLM(LAMBDA,MIU,NUTERM,       KARTEZ)
C
                    IF (KARTER.EQ.KARTEZ)
     *
     *              KREVLM(LAMBDA,MIU,NUTERM,KARTER,KARTEZ)=
     *              KREVLM(LAMBDA,MIU,NUTERM,KARTER,KARTEZ)+1
C
                  END DO
               END DO
            END DO
C
            COEVLM(LAMBDA,MIU)=COEYLM(LAMBDA,MIU)
            NREVLM(LAMBDA,MIU)=NREYLM(LAMBDA,MIU)
C
            IF (MIU.GT.0) THEN
C
            DO NUTERM=1,NIMYLM(LAMBDA,MIU)
               DO KARTEZ=0,NDKART
                  DO KARTER=1,NDKART
C
                    KIMVLM(LAMBDA,MIU,NUTERM,KARTER,KARTEZ)=
     *              KIMYLM(LAMBDA,MIU,NUTERM,       KARTEZ)
C
                    IF (KARTER.EQ.KARTEZ)
     *
     *              KIMVLM(LAMBDA,MIU,NUTERM,KARTER,KARTEZ)=
     *              KIMVLM(LAMBDA,MIU,NUTERM,KARTER,KARTEZ)+1
C
                  END DO
               END DO
            END DO
C
            NIMVLM(LAMBDA,MIU)=NIMYLM(LAMBDA,MIU)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTMUL(IPHASE,ELEMUL,COFMUL,LAMBDA,MIU,IMAREA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          ELEMUL(1:NDBASE,1:NDBASE)
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C
      CALL CPUTIM('INTMUL',1)
C
C=======================================================================
C      THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF MULTIPOLE OPERATORS
C                     R**LAMBDA*CONJG(Y(LAMBDA,MIU))
C
C      SEE J.D. JACKSON, CLASSICAL ELECTRODYNAMICS,  EQ. (4.3)
C
C      IMAREA = 1 (-1) REQUESTS CALCULATION OF THE REAL (IMAGINARY) PART
C=======================================================================
C
      NIU=IABS(MIU)
C
      IF (MIU.GE.0) THEN
          JPHASE=IMAREA
      ELSE
          JPHASE=(-1)**MIU
      END IF
C
C=======================================================================
C      1) FOR NON-NEGATIVE VALUES OF "MIU", THE MATRIX  ELEMENTS
C      OF Y(L,MIU) ( W I T H O U T  THE COMPLEX CONJUGATION) ARE
C      CALCULATED EXPLICITLY USING NIU=IABS(MIU)=+MIU. NEXT, THE
C      REAL PARTS ARE NOT CHANGED, WHILE THE IMAGINARY PARTS ARE
C      MULTIPLIED BY -1. THIS AMOUNTS TO MULTIPLYING THE  RESULT
C      BY JPHASE=IMAREA.
C=======================================================================
C      2) FOR     NEGATIVE VALUES OF "MIU", THE MATRIX  ELEMENTS
C      OF Y(L,MIU) ( W I T H O U T  THE COMPLEX CONJUGATION) ARE
C      CALCULATED EXPLICITLY USING NIU=IABS(MIU)=-MIU. NEXT, THE
C      FORMULA     Y(L,MIU)=(-1)**MIU*CONJG(Y(L,-MIU))  IS USED.
C      THIS AMOUNTS TO MULTIPLYING THE REAL AND IMAGINARY PARTS
C      BY JPHASE=(-1)**MIU
C=======================================================================
C
      ELEMUL(:,:)=0.0D0
C
      IF (IMAREA.EQ.1) THEN
C
C=======================================================================
C         CALCULATING THE REAL PART
C=======================================================================
C
          DO NUTERM=1,NREYLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   ELEMUL(IBRA,IKET) =
     *             ELEMUL(IBRA,IKET) + KREYLM(LAMBDA,NIU,NUTERM,0)
     *
     *           * COFMUL(KREYLM(LAMBDA,NIU,NUTERM,1),NX_BRA,NX_KET,1)
     *           * COFMUL(KREYLM(LAMBDA,NIU,NUTERM,2),NY_BRA,NY_KET,2)
     *           * COFMUL(KREYLM(LAMBDA,NIU,NUTERM,3),NZ_BRA,NZ_KET,3)
     *
     *           * JPHASE
C
                END DO
             END DO
C
          END DO
C
      ELSE
C
          IF (MIU.EQ.0) STOP 'NO IMAGINARY PART FOR MIU=0 IN INTMUL'
C
C=======================================================================
C         CALCULATING THE IMAGINARY PART
C=======================================================================
C
          DO NUTERM=1,NIMYLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   ELEMUL(IBRA,IKET) =
     *             ELEMUL(IBRA,IKET) + KIMYLM(LAMBDA,NIU,NUTERM,0)
     *
     *           * COFMUL(KIMYLM(LAMBDA,NIU,NUTERM,1),NX_BRA,NX_KET,1)
     *           * COFMUL(KIMYLM(LAMBDA,NIU,NUTERM,2),NY_BRA,NY_KET,2)
     *           * COFMUL(KIMYLM(LAMBDA,NIU,NUTERM,3),NZ_BRA,NZ_KET,3)
     *
     *           * JPHASE
C
                END DO
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C        NORMALIZATION FACTOR AND PHASE
C=======================================================================
C
      DO IKET=1,LDBASE
         NY_KET=NYVECT(IKET,1)
         DO IBRA=1,LDBASE
            NY_BRA=NYVECT(IBRA,1)
C
            ELEMUL(IBRA,IKET) = ELEMUL(IBRA,IKET)
     *
     *                        * COEYLM(LAMBDA,NIU)
     *
     *                        * IPHASE(NY_BRA,NY_KET)
C
         END DO
      END DO
C
C=======================================================================
C        FOLLOWS MULTIPLICATION BY THE UNITS DEFINED ONCE FOR ALL IN THE
C        SUBROUTINE "DEFUNI".  THE  SAME  UNITS ARE IMPLIED FOR POSITIVE
C        AND NEGATIVE VALUES OF "MIU".
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            ELEMUL(IBRA,IKET)=ELEMUL(IBRA,IKET)*QUNITS(LAMBDA,NIU)
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTMUL',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTSIF(IPHASE,ELEMUL,COFMUL,LAMBDA,MIU,IMAREA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          ELEMUL(1:NDBASE,1:NDBASE)
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DATSLM/ COESLM(0:NDMULT,0:NDMULT),
     *
     *                NRESLM(0:NDMULT,0:NDMULT),
     *                KRESLM(0:NDMULT,0:NDMULT,NDTERM*NDKART,0:NDKART),
     *
     *                NIMSLM(0:NDMULT,1:NDMULT),
     *                KIMSLM(0:NDMULT,1:NDMULT,NDTERM*NDKART,0:NDKART)
      COMMON
     *       /SIFUNI/ SUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C
      CALL CPUTIM('INTSIF',1)
C
C=======================================================================
C      THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF SURFACE OPERATORS
C                   R**(LAMBDA+2)*CONJG(Y(LAMBDA,MIU))
C
C      IMAREA = 1 (-1) REQUESTS CALCULATION OF THE REAL (IMAGINARY) PART
C=======================================================================
C       THE STRUCTURE OF THIS SUBROUTINE IS EXACTLY THE SAME  AS
C       THE STRUCTURE OF SUBROUTINE "INTMUL"; SEE COMMENTS THERE
C       FOR MORE DETAILS.
C=======================================================================
C
      NIU=IABS(MIU)
C
      IF (MIU.GE.0) THEN
          JPHASE=IMAREA
      ELSE
          JPHASE=(-1)**MIU
      END IF
C
      ELEMUL(:,:)=0.0D0
C
      IF (IMAREA.EQ.1) THEN
C
C=======================================================================
C         CALCULATING THE REAL PART
C=======================================================================
C
          DO NUTERM=1,NRESLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   ELEMUL(IBRA,IKET) =
     *             ELEMUL(IBRA,IKET) + KRESLM(LAMBDA,NIU,NUTERM,0)
     *
     *           * COFMUL(KRESLM(LAMBDA,NIU,NUTERM,1)
     *                                     ,NX_BRA,NX_KET,1)
     *
     *           * COFMUL(KRESLM(LAMBDA,NIU,NUTERM,2)
     *                                     ,NY_BRA,NY_KET,2)
     *
     *           * COFMUL(KRESLM(LAMBDA,NIU,NUTERM,3)
     *                                     ,NZ_BRA,NZ_KET,3)
     *
     *           * JPHASE
C
                END DO
             END DO
          END DO
C
      ELSE
C
          IF (MIU.EQ.0) STOP 'NO IMAGINARY PART FOR MIU=0 IN INTSIF'
C
C=======================================================================
C         CALCULATING THE IMAGINARY PART
C=======================================================================
C
          DO NUTERM=1,NIMSLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   ELEMUL(IBRA,IKET) =
     *             ELEMUL(IBRA,IKET) + KIMSLM(LAMBDA,NIU,NUTERM,0)
     *
     *           * COFMUL(KIMSLM(LAMBDA,NIU,NUTERM,1)
     *                                     ,NX_BRA,NX_KET,1)
     *
     *           * COFMUL(KIMSLM(LAMBDA,NIU,NUTERM,2)
     *                                     ,NY_BRA,NY_KET,2)
     *
     *           * COFMUL(KIMSLM(LAMBDA,NIU,NUTERM,3)
     *                                     ,NZ_BRA,NZ_KET,3)
     *
     *           * JPHASE
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C        NORMALIZATION FACTOR AND PHASE
C=======================================================================
C
      DO IKET=1,LDBASE
         NY_KET=NYVECT(IKET,1)
         DO IBRA=1,LDBASE
            NY_BRA=NYVECT(IBRA,1)
C
            ELEMUL(IBRA,IKET) = ELEMUL(IBRA,IKET)
     *
     *                        * COESLM(LAMBDA,NIU)
     *
     *                        * IPHASE(NY_BRA,NY_KET)
C
         END DO
      END DO
C
C=======================================================================
C        FOLLOWS MULTIPLICATION BY THE UNITS DEFINED ONCE FOR ALL IN THE
C        SUBROUTINE "DEFUNI".  THE  SAME  UNITS ARE IMPLIED FOR POSITIVE
C        AND NEGATIVE VALUES OF "MIU".
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            ELEMUL(IBRA,IKET)=ELEMUL(IBRA,IKET)*SUNITS(LAMBDA,NIU)
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTSIF',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTPLM(IPHASE,ELEMUL,COFMUL,LAMBDA,MIU,IMAREA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          ELEMUL(1:NDBASE,1:NDBASE)
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DATPLM/ COEPLM(0:NDMULT,0:NDMULT),
     *
     *                NREPLM(0:NDMULT,0:NDMULT),
     *                KREPLM(0:NDMULT,0:NDMULT,NDTERM*NDKART*NDKART,
     *                                                     0:NDKART),
     *
     *                NIMPLM(0:NDMULT,1:NDMULT),
     *                KIMPLM(0:NDMULT,1:NDMULT,NDTERM*NDKART*NDKART,
     *                                                     0:NDKART)
      COMMON
     *       /PLMUNI/ PUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C
      CALL CPUTIM('INTPLM',1)
C
C=======================================================================
C      THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF PENSURFACE OPERATOR
C                   R**(LAMBDA+4)*CONJG(Y(LAMBDA,MIU))
C
C      IMAREA = 1 (-1) REQUESTS CALCULATION OF THE REAL (IMAGINARY) PART
C=======================================================================
C       THE STRUCTURE OF THIS SUBROUTINE IS EXACTLY THE SAME  AS
C       THE STRUCTURE OF SUBROUTINE "INTMUL"; SEE COMMENTS THERE
C       FOR MORE DETAILS.
C=======================================================================
C
      NIU=IABS(MIU)
C
      IF (MIU.GE.0) THEN
          JPHASE=IMAREA
      ELSE
          JPHASE=(-1)**MIU
      END IF
C
      ELEMUL(:,:)=0.0D0
C
      IF (IMAREA.EQ.1) THEN
C
C=======================================================================
C         CALCULATING THE REAL PART
C=======================================================================
C
          DO NUTERM=1,NREPLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   ELEMUL(IBRA,IKET) =
     *             ELEMUL(IBRA,IKET) + KREPLM(LAMBDA,NIU,NUTERM,0)
     *
     *           * COFMUL(KREPLM(LAMBDA,NIU,NUTERM,1)
     *                                     ,NX_BRA,NX_KET,1)
     *
     *           * COFMUL(KREPLM(LAMBDA,NIU,NUTERM,2)
     *                                     ,NY_BRA,NY_KET,2)
     *
     *           * COFMUL(KREPLM(LAMBDA,NIU,NUTERM,3)
     *                                     ,NZ_BRA,NZ_KET,3)
     *
     *           * JPHASE
C
                END DO
             END DO
          END DO
C
      ELSE
C
          IF (MIU.EQ.0) STOP 'NO IMAGINARY PART FOR MIU=0 IN INTPLM'
C
C=======================================================================
C         CALCULATING THE IMAGINARY PART
C=======================================================================
C
          DO NUTERM=1,NIMPLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   ELEMUL(IBRA,IKET) =
     *             ELEMUL(IBRA,IKET) + KIMPLM(LAMBDA,NIU,NUTERM,0)
     *
     *           * COFMUL(KIMPLM(LAMBDA,NIU,NUTERM,1)
     *                                     ,NX_BRA,NX_KET,1)
     *
     *           * COFMUL(KIMPLM(LAMBDA,NIU,NUTERM,2)
     *                                     ,NY_BRA,NY_KET,2)
     *
     *           * COFMUL(KIMPLM(LAMBDA,NIU,NUTERM,3)
     *                                     ,NZ_BRA,NZ_KET,3)
     *
     *           * JPHASE
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C        NORMALIZATION FACTOR AND PHASE
C=======================================================================
C
      DO IKET=1,LDBASE
         NY_KET=NYVECT(IKET,1)
         DO IBRA=1,LDBASE
            NY_BRA=NYVECT(IBRA,1)
C
            ELEMUL(IBRA,IKET) = ELEMUL(IBRA,IKET)
     *
     *                        * COEPLM(LAMBDA,NIU)
     *
     *                        * IPHASE(NY_BRA,NY_KET)
C
         END DO
      END DO
C
C=======================================================================
C        FOLLOWS MULTIPLICATION BY THE UNITS DEFINED ONCE FOR ALL IN THE
C        SUBROUTINE "DEFUNI".  THE  SAME  UNITS ARE IMPLIED FOR POSITIVE
C        AND NEGATIVE VALUES OF "MIU".
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            ELEMUL(IBRA,IKET)=ELEMUL(IBRA,IKET)*PUNITS(LAMBDA,NIU)
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTPLM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTVMU(IPHASE,ELEMUL,COFMUL,LAMBDA,MIU,KARTEZ,IMAREA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          ELEMUL(1:NDBASE,1:NDBASE)
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DATVLM/ COEVLM(0:NDMULT,0:NDMULT),
     *
     *                NREVLM(0:NDMULT,0:NDMULT),
     *                KREVLM(0:NDMULT,0:NDMULT,NDTERM,NDKART,0:NDKART),
     *
     *                NIMVLM(0:NDMULT,1:NDMULT),
     *                KIMVLM(0:NDMULT,1:NDMULT,NDTERM,NDKART,0:NDKART)
      COMMON
     *       /VMUUNI/ VUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C
      CALL CPUTIM('INTVMU',1)
C
C=======================================================================
C      THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF VECTOR MULTIPOLE
C      OPERATORS:
C                   R**(LAMBDA)*CONJG(Y(LAMBDA,MIU))*(X,Y,Z)
C
C      IMAREA = 1 (-1) REQUESTS CALCULATION OF THE REAL (IMAGINARY) PART
C=======================================================================
C       THE STRUCTURE OF THIS SUBROUTINE IS EXACTLY THE SAME  AS
C       THE STRUCTURE OF SUBROUTINE "INTMUL"; SEE COMMENTS THERE
C       FOR MORE DETAILS.
C=======================================================================
C
      NIU=IABS(MIU)
C
      IF (MIU.GE.0) THEN
          JPHASE=IMAREA
      ELSE
          JPHASE=(-1)**MIU
      END IF
C
      ELEMUL(:,:)=0.0D0
C
      IF (IMAREA.EQ.1) THEN
C
C=======================================================================
C         CALCULATING THE REAL PART
C=======================================================================
C
          DO NUTERM=1,NREVLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   ELEMUL(IBRA,IKET)=
     *             ELEMUL(IBRA,IKET)+ KREVLM(LAMBDA,NIU,NUTERM,KARTEZ,0)
     *
     *           * COFMUL(KREVLM(LAMBDA,NIU,NUTERM,KARTEZ,1)
     *                                     ,NX_BRA,NX_KET,1)
     *
     *           * COFMUL(KREVLM(LAMBDA,NIU,NUTERM,KARTEZ,2)
     *                                     ,NY_BRA,NY_KET,2)
     *
     *           * COFMUL(KREVLM(LAMBDA,NIU,NUTERM,KARTEZ,3)
     *                                     ,NZ_BRA,NZ_KET,3)
     *
     *           * JPHASE
C
                END DO
             END DO
          END DO
C
      ELSE
C
          IF (MIU.EQ.0) STOP 'NO IMAGINARY PART FOR MIU=0 IN INTVMU'
C
C=======================================================================
C         CALCULATING THE IMAGINARY PART
C=======================================================================
C
          DO NUTERM=1,NIMVLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   ELEMUL(IBRA,IKET)=
     *             ELEMUL(IBRA,IKET)+ KIMVLM(LAMBDA,NIU,NUTERM,KARTEZ,0)
     *
     *           * COFMUL(KIMVLM(LAMBDA,NIU,NUTERM,KARTEZ,1)
     *                                     ,NX_BRA,NX_KET,1)
     *
     *           * COFMUL(KIMVLM(LAMBDA,NIU,NUTERM,KARTEZ,2)
     *                                     ,NY_BRA,NY_KET,2)
     *
     *           * COFMUL(KIMVLM(LAMBDA,NIU,NUTERM,KARTEZ,3)
     *                                     ,NZ_BRA,NZ_KET,3)
     *
     *           * JPHASE
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C        NORMALIZATION FACTOR AND PHASE
C=======================================================================
C
      DO IKET=1,LDBASE
         NY_KET=NYVECT(IKET,1)
         DO IBRA=1,LDBASE
            NY_BRA=NYVECT(IBRA,1)
C
            ELEMUL(IBRA,IKET) = ELEMUL(IBRA,IKET)
     *
     *                        * COEVLM(LAMBDA,NIU)
     *
     *                        * IPHASE(NY_BRA,NY_KET)
C
         END DO
      END DO
C
C=======================================================================
C        FOLLOWS MULTIPLICATION BY THE UNITS DEFINED ONCE FOR ALL IN THE
C        SUBROUTINE "DEFUNI".  THE  SAME  UNITS ARE IMPLIED FOR POSITIVE
C        AND NEGATIVE VALUES OF "MIU".
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            ELEMUL(IBRA,IKET)=ELEMUL(IBRA,IKET)*VUNITS(LAMBDA,NIU)
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTVMU',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTRAD(HAMRAD,KARTEZ,NUMORD)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3,NDTORD=10)
C=======================================================================
      DIMENSION
     *          HAMRAD(1:NDBASE,1:NDBASE)
      DIMENSION
     *          N_KART(1:NDKART)
C
      COMMON
     *       /MATORD/ NUTORD(0:NDMORD),
     *                MUTORD(1:NDTORD,0:NDMORD),
     *                IUTORD(1:NDTORD,0:NDMORD,1:NDKART)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /RADUNI/ RUNITS(0:NDMORD)
C
C=======================================================================
C      THIS SUBROUTINE CALCULATES:
C      FOR KARTEZ>0, MATRIX ELEMENTS OF X**2, Y**2, OR Z**2
C      FOR KARTEZ=0, MATRIX ELEMENTS OF R**(2*NUMORD)
C=======================================================================
C
      HAMRAD(:,:)=0.0D0
C
      IF (KARTEZ.GT.0) THEN
C
          N_KART(1)=0
          N_KART(2)=0
          N_KART(3)=0
          N_KART(KARTEZ)=2
C
C=======================================================================
C        CALCULATING THE MATRIX ELEMENT MULTIPLIED BY THE UNITS DEFINED
C        ONCE FOR ALL IN THE SUBROUTINE "DEFUNI" AND BY THE PHASE.
C=======================================================================
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                HAMRAD(IBRA,IKET) =
     *
     *             COMULT(N_KART(1),NXVECT(IBRA,1),NXVECT(IKET,1),1)
     *           * COMULT(N_KART(2),NYVECT(IBRA,1),NYVECT(IKET,1),2)
     *           * COMULT(N_KART(3),NZVECT(IBRA,1),NZVECT(IKET,1),3)
     *           * RUNITS(1)
     *           * IPHAPP(NYVECT(IBRA,1),NYVECT(IKET,1),0)
C
             END DO
          END DO
C
      ELSE
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                DO LUTORD=1,NUTORD(NUMORD)
C
                   HAMRAD(IBRA,IKET) = HAMRAD(IBRA,IKET)
     *           + MUTORD(       LUTORD,NUMORD  )
     *           * COMULT(IUTORD(LUTORD,NUMORD,1),NXVECT(IBRA,1),
     *                                            NXVECT(IKET,1),1)
     *           * COMULT(IUTORD(LUTORD,NUMORD,2),NYVECT(IBRA,1),
     *                                            NYVECT(IKET,1),2)
     *           * COMULT(IUTORD(LUTORD,NUMORD,3),NZVECT(IBRA,1),
     *                                            NZVECT(IKET,1),3)
     *           * RUNITS(NUMORD)
     *           * IPHAPP(NYVECT(IBRA,1),NYVECT(IKET,1),0)
C
                END DO
C
             END DO
          END DO
C
      END IF
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEVHER(NOSACT,KARTEZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      IMPLICIT REAL*16 (A-H,O-Z)
      REAL
     * COEF00,
     * COEF01,
     * COEF11,
     * COEF02,
     *
     * COEF10,
     *
     * COEF12,
     * COEF03,
     *
     * COEF22,
     * COEF13,
     * COEF04,
     *
     * COEF23,
     * COEF14,
     * COEF05,
     *
     * COEF33,
     * COEF24,
     * COEF15,
     * COEF06,
     *
     * COUL00,
     *
     * HOMSCA
C=======================================================================
      DIMENSION
     *          PHERMI(2*NOSACT+6+1),DHERMI(2*NOSACT+6+1)
      DIMENSION
     *          XHERMI(2*NOSACT+7),WHERMI(2*NOSACT+7)
      DIMENSION
     *          HERPLN(0:2*NOSACT+6,1:2*NOSACT+7)
      DIMENSION
     *          DH1PLN(0:NOSACT,1:2*NOSACT+7),
     *          DH2PLN(0:NOSACT,1:2*NOSACT+7),
     *          DH3PLN(0:NOSACT,1:2*NOSACT+7),
     *          DH4PLN(0:NOSACT,1:2*NOSACT+7),
     *          DH5PLN(0:NOSACT,1:2*NOSACT+7),
     *          DH6PLN(0:NOSACT,1:2*NOSACT+7)
      DIMENSION
     *          HERSQ2(0:NOSACT,1:2*NOSACT+7)
      DIMENSION
     *          HERFAQ(0:2*NOSACT+6)
      COMMON
     *       /QOEXYZ/ QOEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEAUX/ COEF10(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO3XYZ/ COEF12(0:ND2MAX+1,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF03(0:ND2MAX+1,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO4XYZ/ COEF22(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF13(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF04(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO5XYZ/ COEF23(0:ND2MAX+3,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF14(0:ND2MAX+3,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF05(0:ND2MAX+3,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO6XYZ/ COEF33(0:ND2MAX+4,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF24(0:ND2MAX+4,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF15(0:ND2MAX+4,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF06(0:ND2MAX+4,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COUDEV/ COUL00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('DEVHER',1)
C
C=======================================================================
C
C         THIS ROUTINE PERFORMS INTEGRATION OF THE HERMITE POLYNOMIALS
C         TO FIND THE EXPANSION COEFFICIENTS IN THE FORMULAE:
C
C         H (M,X)  *  H  (N,X) = SUM_K COEF00(K,M,N) * H(K,X)
C         H (M,X)  *  H' (N,X) = SUM_K COEF01(K,M,N) * H(K,X)
C         H'(M,X)  *  H' (N,X) = SUM_K COEF11(K,M,N) * H(K,X)
C         H (M,X)  *  H''(N,X) = SUM_K COEF02(K,M,N) * H(K,X)
C
C         AND UP TO ORDER I=<J=<6
C
C         H^(I)(M,X)* H^(J)(N,X) = SUM_K COEFIJ(K,M,N) * H(K,X)
C
C         AND FOR SQ2=SQRT(2):
C
C         H (M,X)  *  H  (N,X) = SUM_K COUL00(K,M,N) * H(K,SQ2*X) * SQ2
C
C         WHERE:
C
C         H  (M,X) IS THE HERMITE POLYNOMIAL OF THE ORDER  M  AT POINT X
C                  ASSUMED TO BE NORMALIZED TO   O N E   WHEN ITS SQUARE
C                  IS INTEGRATED WITH EXP(-X**2).
C         H' (M,X) IS THE DERIVATIVE OF              H(M,X)*EXP(-X**2/2)
C                  MULTIPLIED BY EXP(X**2/2)
C         H''(M,X) IS THE SECOND DERIVATIVE OF       H(M,X)*EXP(-X**2/2)
C                  MULTIPLIED BY EXP(X**2/2)
C         H^(I)(M,X) IS THE I-TH DERIVATIVE OF       H(M,X)*EXP(-X**2/2)
C                  MULTIPLIED BY EXP(X**2/2)
C
C         "NOSACT"  IS THE MAXIMUM ORDER OF THE HERMITE POLYNOMIALS USED
C         IN THE CODE. THEREFORE:
C
C         H  (M,X)   HAS THE MAXIMUM ORDER  NOSACT
C         H' (M,X)   HAS THE MAXIMUM ORDER  NOSACT + 1
C         H''(M,X)   HAS THE MAXIMUM ORDER  NOSACT + 2
C         H^(I)(M,X) HAS THE MAXIMUM ORDER  NOSACT + I
C
C         THE MAXIMUM ORDER OF PRODUCTS ON THE  LEFT-HAND-SIDES  OF  THE
C         ABOVE FORMULAE IS  THEREFORE:
C
C=======================================================================
C
      NMAIN6=2*NOSACT+6
C
      IF (NMAIN6.GT.ND2MAX+4) THEN
C
         WRITE(NFIPRI,'(//,1X,''NMAIN6='',I2,'' .GT. ND2MAX+4='',I2,
     *                       ''   STOP IN DEVHER'',//)') NMAIN6,ND2MAX+4
         STOP ' NMAIN6.GT.ND2MAX+4 IN DEVHER'
C
      END IF
C
C=======================================================================
C
      CALL NORFAQ(HERFAQ,NMAIN6)
C
C=======================================================================
C         ZEROING THE COEF__ AND COUL00 ARRAYS
C=======================================================================
C
      QOEF00(:,:,:,KARTEZ)=0
C
      COEF00(:,:,:,KARTEZ)=0
      COEF01(:,:,:,KARTEZ)=0
      COEF10(:,:,:,KARTEZ)=0
      COEF11(:,:,:,KARTEZ)=0
      COEF02(:,:,:,KARTEZ)=0
      COEF12(:,:,:,KARTEZ)=0
      COEF03(:,:,:,KARTEZ)=0
      COEF22(:,:,:,KARTEZ)=0
      COEF13(:,:,:,KARTEZ)=0
      COEF04(:,:,:,KARTEZ)=0
      COEF23(:,:,:,KARTEZ)=0
      COEF14(:,:,:,KARTEZ)=0
      COEF05(:,:,:,KARTEZ)=0
      COEF33(:,:,:,KARTEZ)=0
      COEF24(:,:,:,KARTEZ)=0
      COEF15(:,:,:,KARTEZ)=0
      COEF06(:,:,:,KARTEZ)=0
      COUL00(:,:,:,KARTEZ)=0
C
C=======================================================================
C
C         THE COEFFICIENTS  COEF__   AND   COUL00  ARE FOUND BY EXPLICIT
C         NUMERICAL            G A U S S - H E R M I T E
C         INTEGRATION OF PRODUCTS APPEARING ON THE ABOVE LEFT-HAND-SIDES
C         WITH HERMITE  POLYNOMIALS.  THE MAXIMUM ORDER OF INTEGRANDS IS
C         THEN FOR I,J=<6 EQUAL TO 4*NOSACT+12, AND THEREFORE ONE HAS TO
C         USE THE NUMBER OF GAUSS-HERMITE INTEGRATION POINTS EQUAL TO:
C
C=======================================================================
C
      NGAUSS=2*NOSACT+7
C
C=======================================================================
C          DEFINING ZEROS AND WEIGHTS FOR THE GAUSS-HERMITE  INTEGRATION
C=======================================================================
C
      CALL HERMIQ(NGAUSS,XHERMI,WHERMI,2*NOSACT+7)
C
C=======================================================================
C        DEFINING THE VALUES OF THE HERMITE POLYNOMIALS AT GAUSS ZEROS
C=======================================================================
C
      TWO=2
      SQ2=SQRT(TWO)
C
      DO IZEROS = 1,NGAUSS
C
         XZER = XHERMI(IZEROS)
C
         CALL D_HERQ(XZER,NMAIN6,PHERMI,DHERMI,2*NOSACT+6+1)
C
         DO NOSCIL = 0,NMAIN6
C
            HERPLN(NOSCIL,IZEROS)= PHERMI(NOSCIL+1)/HERFAQ(NOSCIL)
C
         END DO
C
         DO NOSCIL = 0,NOSACT
C
            DH1PLN(NOSCIL,IZEROS)=(DHERMI(NOSCIL+1)
     *                           - XZER*PHERMI(NOSCIL+1))
     *                                             /HERFAQ(NOSCIL)
C
            DH2PLN(NOSCIL,IZEROS)=(XZER**2-2*NOSCIL-1)
     *                           * PHERMI(NOSCIL+1)/HERFAQ(NOSCIL)
C
            DH3PLN(NOSCIL,IZEROS)=((-XZER**3+(2*NOSCIL+3)*XZER)
     *                           * PHERMI(NOSCIL+1)
     *                           +(XZER*XZER-2*NOSCIL-1)
     *                           * DHERMI(NOSCIL+1))
     *                                             /HERFAQ(NOSCIL)
C
            DH4PLN(NOSCIL,IZEROS)=((XZER**4-(4*NOSCIL+6)*XZER**2
     *                              +4*NOSCIL**2+4*NOSCIL+3)
     *                           * PHERMI(NOSCIL+1)
     *                           + 4*XZER
     *                           * DHERMI(NOSCIL+1))
     *                                             /HERFAQ(NOSCIL)
C
            DH5PLN(NOSCIL,IZEROS)=0
            DH6PLN(NOSCIL,IZEROS)=0
C
         END DO
C
         XZER = XHERMI(IZEROS) / SQ2
C
         CALL D_HERQ(XZER,NOSACT,PHERMI,DHERMI,NOSACT+1)
C
         DO NOSCIL = 0,NOSACT
C
            HERSQ2(NOSCIL,IZEROS)= PHERMI(NOSCIL+1)/HERFAQ(NOSCIL)
C
         END DO
C
      END DO
C
C=======================================================================
C        CALCULATING THE EXPANSION COEFFICIENTS FOR THE POLYNOMIALS
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=M+N,0,-2
C
               RESULT=0
               RESCOU=0
C
               DO IGAUSS=1,NGAUSS
C
                  RESULT=RESULT+WHERMI(IGAUSS)*HERPLN(N,IGAUSS)
     *                                        *HERPLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
C
                  RESCOU=RESCOU+WHERMI(IGAUSS)*HERSQ2(N,IGAUSS)
     *                                        *HERSQ2(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               QOEF00(K,M,N,KARTEZ)=RESULT
               COEF00(K,M,N,KARTEZ)=RESULT
               COUL00(K,M,N,KARTEZ)=RESCOU / SQ2
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        TESTING THE EXPANSION COEFFICIENTS
C=======================================================================
C
      ITESCO=0
C
      IF (ITESCO.EQ.1) THEN
C
          WRITE (*,'(/,''TESTING THE EXPANSION COEFFICIENTS '',
     *                 ''FOR KARTEZ='',I2)') KARTEZ
C
          DIFMAX=0
          DIFMAY=0
C
          DO N=0,NOSACT
             DO M=0,NOSACT
                DO K=M+N,0,-2
C
                   IF (K.EQ.M+N) WRITE (*,'(/,21X,6X,''COEFF00'')')
C
                   WRITE (*,'('' N='',I4,'' M='',I4,'' K='',I4,D18.10)')
     *                    N,M,K,QOEF00(K,M,N,KARTEZ)
C
                END DO
C
                DO IGAUSS=1,NGAUSS
C
                   RESULT=0
C
                   DO K=M+N,0,-2
C
                     RESULT=RESULT+QOEF00(K,M,N,KARTEZ)*HERPLN(K,IGAUSS)
C
                   END DO
C
                   IF (IGAUSS.EQ.1)
     *                 WRITE (*,'(/,26X,'' H_N(IGAUSS)*H_M(IGAUSS)'',
     *                                  '' SUM_K COE_K*H_K(IGAUSS)'',
     *                                  ''     RELATIVE DIFFERENCE'',
     *                                  ''              DIFFERENCE'')')
C
                   WRITE (*,'('' N='',I4,'' M='',I4,'' IGAUSS='',I4,
     *                     4D24.10)')
     *                     N,M,IGAUSS,
     *                     HERPLN(N,IGAUSS)*HERPLN(M,IGAUSS),RESULT,
     *                    (HERPLN(N,IGAUSS)*HERPLN(M,IGAUSS)-RESULT)/
     *                                                       RESULT,
     *                     HERPLN(N,IGAUSS)*HERPLN(M,IGAUSS)-RESULT
C
                   DIFMAX=MAX(DIFMAX,ABS(
     *                    (HERPLN(N,IGAUSS)*HERPLN(M,IGAUSS)-RESULT)/
     *                                                       RESULT))
                   DIFMAY=MAX(DIFMAY,ABS(
     *                     HERPLN(N,IGAUSS)*HERPLN(M,IGAUSS)-RESULT))
C
                END DO
             END DO
          END DO
C
          PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10)',DIFMAX
          PRINT '(/'' MAXIMUM          DIFFERENCE='',D19.10)',DIFMAY
C
      END IF
C
C=======================================================================
C        CALCULATING THE EXPANSION COEFFICIENTS FOR THE PRODUCTS
C        DERIVATIVE (EXP * HERMIT) * HERMIT * HERMIT
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=M+N+1,0,-2
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH1PLN(N,IGAUSS)
     *                                        *HERPLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF01(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*HERPLN(N,IGAUSS)
     *                                        *DH1PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF10(K,M,N,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE EXPANSION COEFFICIENTS FOR THE PRODUCTS
C        DERIVATIVE (EXP * HERMIT) * DERIVATIVE (EXP * HERMIT) * HERMIT
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=M+N+2,0,-2
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH1PLN(N,IGAUSS)
     *                                        *DH1PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF11(K,M,N,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE EXPANSION COEFFICIENTS FOR THE PRODUCTS
C        SECOND DERIVATIVE (EXP * HERMIT) * HERMIT * HERMIT
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=M+N+2,0,-2
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH2PLN(N,IGAUSS)
     *                                        *HERPLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF02(K,M,N,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE REMAINING EXPANSION COEFFICIENTS
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=M+N+3,0,-2
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH2PLN(N,IGAUSS)
     *                                        *DH1PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF12(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH3PLN(N,IGAUSS)
     *                                        *HERPLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF03(K,M,N,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=M+N+4,0,-2
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH2PLN(N,IGAUSS)
     *                                        *DH2PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF22(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH3PLN(N,IGAUSS)
     *                                        *DH1PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF13(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH4PLN(N,IGAUSS)
     *                                        *HERPLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF04(K,M,N,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=M+N+5,0,-2
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH3PLN(N,IGAUSS)
     *                                        *DH2PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF23(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH4PLN(N,IGAUSS)
     *                                        *DH1PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF14(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH5PLN(N,IGAUSS)
     *                                        *HERPLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF05(K,M,N,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
            DO K=M+N+6,0,-2
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH3PLN(N,IGAUSS)
     *                                        *DH3PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF33(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH4PLN(N,IGAUSS)
     *                                        *DH2PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF24(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH5PLN(N,IGAUSS)
     *                                        *DH1PLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF15(K,M,N,KARTEZ)=RESULT
C
               RESULT=0
C
               DO IGAUSS=1,NGAUSS
                  RESULT=RESULT+WHERMI(IGAUSS)*DH6PLN(N,IGAUSS)
     *                                        *HERPLN(M,IGAUSS)
     *                                        *HERPLN(K,IGAUSS)
               END DO
C
               COEF06(K,M,N,KARTEZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C       THE CODE USES DIMENSIONED WAVE FUNCTIONS AND THEIR DERIVATIVES.
C       THEREFORE, THE COEFFICIENTS       COEF__     ARE HERE SCALED BY
C       APPROPRIATE FACTORS WHICH TAKE INTO ACCOUNT  THESE  DIMENSIONS.
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            DO K=M+N,0,-2
               QOEF00(K,M,N,KARTEZ)=  QOEF00(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
               COEF00(K,M,N,KARTEZ)=  COEF00(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
               COUL00(K,M,N,KARTEZ)=  COUL00(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
            END DO
C
            DO K=M+N+1,0,-2
               COEF01(K,M,N,KARTEZ)=  COEF01(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *      HOMSCA(KARTEZ,1)
               COEF10(K,M,N,KARTEZ)=COEF10(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *     HOMSCA(KARTEZ,1)
            END DO
C
            DO K=M+N+2,0,-2
C
               COEF02(K,M,N,KARTEZ)=  COEF02(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *      HOMSCA(KARTEZ,1)
     *                             *      HOMSCA(KARTEZ,1)
C
               COEF11(K,M,N,KARTEZ)=  COEF11(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *      HOMSCA(KARTEZ,1)
     *                             *      HOMSCA(KARTEZ,1)
            END DO
C
            DO K=M+N+3,0,-2
C
               COEF12(K,M,N,KARTEZ)=  COEF12(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**3
C
               COEF03(K,M,N,KARTEZ)=  COEF03(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**3
            END DO
C
            DO K=M+N+4,0,-2
C
               COEF22(K,M,N,KARTEZ)=  COEF22(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**4
C
               COEF13(K,M,N,KARTEZ)=  COEF13(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**4
C
               COEF04(K,M,N,KARTEZ)=  COEF04(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**4
            END DO
C
            DO K=M+N+5,0,-2
C
               COEF23(K,M,N,KARTEZ)=  COEF23(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**5
C
               COEF14(K,M,N,KARTEZ)=  COEF14(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**5
C
               COEF05(K,M,N,KARTEZ)=  COEF05(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**5
            END DO
C
            DO K=M+N+6,0,-2
C
               COEF33(K,M,N,KARTEZ)=  COEF33(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**6
C
               COEF24(K,M,N,KARTEZ)=  COEF24(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**6
C
               COEF15(K,M,N,KARTEZ)=  COEF15(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**6
C
               COEF06(K,M,N,KARTEZ)=  COEF06(K,M,N,KARTEZ)
     *                             *SQRT(HOMSCA(KARTEZ,1))
     *                             *   HOMSCA(KARTEZ,1)**6
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('DEVHER',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEVTHC(MORDER,NOSACT,KARTEZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          PHERMI(2*NOSACT+MORDER+1),DHERMI(2*NOSACT+MORDER+1)
      DIMENSION
     *          XHERMI(2*NOSACT+MORDER+1),WHERMI(2*NOSACT+MORDER+1)
      DIMENSION
     *          HERPLN(0:2*NOSACT+MORDER,1:2*NOSACT+MORDER+1)
      DIMENSION
     *          DHEPLN(1:MORDER,0:NOSACT,1:2*NOSACT+MORDER+1)
      DIMENSION
     *          HERFAC(0:2*NOSACT+MORDER)
C
      COMMON
     *       /MATTHC/ DENTHC(0:NDORDE,
     *                         0:NDOSCI,0:2*NDOSCI+NDORDE,1:NDKART),
     *                POTTHC(0:2*NDOSCI,0:2*NDOSCI+NDORDE,1:NDKART),
     *                NUMTHC(1:NDKART)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C         THIS SUBROUTIONE CALCULATES FORMFACTORS REQUIRED IN THE TENSOR
C         HYPERCONTRACTION METHOD, PRL111-132505, THAT IS,  TO  SEPARATE
C         INDICES OF THE MATRIX:
C
C         COEFIJ(K,M,N) = SUM_L H(K,XL)* H^(I)(M,XL)* H^(J)(N,XL)
C
C         WHERE:
C
C         H    (K,XL) IS THE HERMITE POLYNOMIAL OF THE ORDER K AT  POINT
C                     XL, ASSUMED TO BE NORMALIZED TO   O N E   WHEN ITS
C                     SQUARE IS INTEGRATED WITH  EXP(-X**2),  MULTIPLIED
C                     BY THE GAUSS-HERMITT WEIGHT WL.
C         H^(I)(M,XL) IS THE I-TH DERIVATIVE OF      H(M,X)*EXP(-X**2/2)
C                     MULTIPLIED BY EXP(X**2/2) AT POINT XL
C         XL ARE THE GAUSS-HERMITE NODES.
C
C         "NOSACT"  IS THE MAXIMUM ORDER OF THE HERMITE POLYNOMIALS USED
C         IN THE CODE. THEREFORE:
C
C         "MORDER"  IS THE MAXIMUM ORDER OF THE     DERIVATIVES     USED
C         IN THE CODE. THEREFORE:
C
C         NOTE THAT THE SAME ORDER IS USED FOR     A L L    DERIVATIVES,
C         ALTHOUGH FOR I+J<MORDER THIS IS NOT REALLY NECESSARY. HOWEVER,
C         ONE WANTS THE RANGE OF SUMATION OVER "XL" TO BE INDEPENDENT OF
C         WHICH DERIVATIVE IS TREATED.
C
C         H^(I)(M,XL) HAS THE MAXIMUM ORDER OF NOSACT + MORDER
C
C         HOWEVER, THE EXPRESSION ABOVE WILL  BE  USED    O N L Y    FOR
C         I+J<=MORDER. THEREFORE,  THE  MAXIMUM  ORDER  OF  PRODUCTS  OF
C         DERIVATIVES IS EQUAL TO:
C
C=======================================================================
C
      NMAIN6=2*NOSACT+MORDER
C
      IF (NMAIN6.GT.2*NDOSCI+NDORDE) THEN
C
         WRITE(NFIPRI,'(//,1X,''NMAIN6='',I2,'' .GT. 2*NDOSCI+NDORDE='',
     *             I2,''   STOP IN DEVTHC'',//)') NMAIN6,2*NDOSCI+NDORDE
         STOP ' NMAIN6.GT.2*NDOSCI+NDORDE IN DEVTHC'
C
      END IF
C
C=======================================================================
C
      NGAUSS=2*NOSACT+MORDER+1
C
      NUMTHC(KARTEZ)=NGAUSS
C
C=======================================================================
C
      CALL NORFAC(HERFAC,NMAIN6)
C
C=======================================================================
C         DEFINING ZEROS AND WEIGHTS FOR THE  GAUSS-HERMITE  INTEGRATION
C=======================================================================
C
      CALL HERMIT(NGAUSS,XHERMI,WHERMI,2*NOSACT+MORDER+1)
C
C=======================================================================
C         DEFINING THE VALUES OF THE HERMITE POLYNOMIALS AT GAUSS  ZEROS
C=======================================================================
C
      HERPLN=0.0D0
      DHEPLN=0.0D0
C
      DO IZEROS = 1,NGAUSS
C
         XZER = XHERMI(IZEROS)
C
         CALL D_HERM(XZER,NMAIN6,PHERMI,DHERMI,2*NOSACT+MORDER+1)
C
         DO NOSCIL = 0,NMAIN6
C
            HERPLN(NOSCIL,IZEROS)= PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
         END DO
C
         DO NOSCIL = 0,NOSACT
C
            IF (MORDER.GE.1)
     *      DHEPLN(1,NOSCIL,IZEROS)=(DHERMI(NOSCIL+1)
     *                           - XZER*PHERMI(NOSCIL+1))
     *                                             /HERFAC(NOSCIL)
C
            IF (MORDER.GE.2)
     *      DHEPLN(2,NOSCIL,IZEROS)=(XZER**2-2*NOSCIL-1)
     *                           * PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
            IF (MORDER.GE.3)
     *      DHEPLN(3,NOSCIL,IZEROS)=((-XZER**3+(2*NOSCIL+3)*XZER)
     *                           * PHERMI(NOSCIL+1)
     *                           +(XZER*XZER-2*NOSCIL-1)
     *                           * DHERMI(NOSCIL+1))
     *                                             /HERFAC(NOSCIL)
C
            IF (MORDER.GE.4)
     *      DHEPLN(4,NOSCIL,IZEROS)=((XZER**4-(4*NOSCIL+6)*XZER**2
     *                              +4*NOSCIL**2+4*NOSCIL+3)
     *                           * PHERMI(NOSCIL+1)
     *                           + 4*XZER
     *                           * DHERMI(NOSCIL+1))
     *                                             /HERFAC(NOSCIL)
C
            IF (MORDER.GE.5)
     *      DHEPLN(5,NOSCIL,IZEROS)=0.0D0
C
            IF (MORDER.GE.6)
     *      DHEPLN(6,NOSCIL,IZEROS)=0.0D0
C
         END DO
C
      END DO
C
C=======================================================================
C        CALCULATING THE THC FORMFACTORS
C=======================================================================
C       THE CODE USES DIMENSIONED WAVE FUNCTIONS AND THEIR  DERIVATIVES.
C       THEREFORE,  THE  FORMFACTORS   "POTTHC"    ARE  HERE  SCALED  BY
C       APPROPRIATE FACTORS WHICH TAKE INTO ACCOUNT THESE DIMENSIONS.
C=======================================================================
C
      DENTHC(:,:,:,KARTEZ)=0.0D0
C
      DO N=0,NOSACT
         DO L=1,NGAUSS
C
            DENTHC(0,N,L,KARTEZ)=HERPLN(N,L)*SQRT(HOMSCA(KARTEZ,1))
C
            DO I=1,MORDER
C
               DENTHC(I,N,L,KARTEZ)=DHEPLN(I,N,L)*SQRT(HOMSCA(KARTEZ,1))
     *                                           *   HOMSCA(KARTEZ,1)**I
C
            END DO
C
         END DO
      END DO
C
      POTTHC(:,:,KARTEZ)=0.0D0
C
      DO N=0,2*NOSACT
         DO L=1,NGAUSS
C
            POTTHC(N,L,KARTEZ)=HERPLN(N,L)*SQRT(HOMSCA(KARTEZ,1))
     *                                    *WHERMI(L)
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFINT(NOSACT,KARTEZ,NGAUSS,NOBODY,
     *                  HERACT,DHRACT,DDHACT,WGTACT,PNTACT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          PHERMI(ND2MAX+1),DHERMI(ND2MAX+1)
      DIMENSION
     *          XHERMI(NDGAUS),WHERMI(NDGAUS)
C
      DIMENSION
     *          HERACT(0:ND2MAX,1:NDGAUS,1:NDKART)
      DIMENSION
     *          DHRACT(0:ND2MAX,1:NDGAUS,1:NDKART),
     *          DDHACT(0:ND2MAX,1:NDGAUS,1:NDKART)
      DIMENSION
     *          WGTACT(1:NDGAUS,1:NDKART),
     *          PNTACT(1:NDGAUS,1:NDKART)
C
      COMMON
     *       /FACHER/ HERFAC(0:ND2MAX)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C          THIS SUBROUTINE CALCULATES HARMONIC OSCILLATOR WAVE FUNCTIONS
C          AND THEIR FIRST AND SECOND DERIVATIVES, AS WELL  AS  PREPARES
C          POINTS AND WEIGHTS FOR THE GAUSS-HERMITE INTEGRATION.
C
C          EXPONENTIAL FACTORS ARE    N  O  T   INCLUDED  NEITHER IN THE
C          WAVE FUNCTIONS NOR IN THE DERIVATIVES.
C
C=======================================================================
C          EVEN IF THE BASIS CONTAINS THE WAVE FUNCTIONS ONLY UP TO  THE
C          NUMBER OF OSCILLATOR QUANTA EQUAL TO "NOSACT", THE CODE NEEDS
C          THE WAVE FUNCTIONS UP TO THE MAXIMUM NUMBER OF QUANTA  EQUAL:
C=======================================================================
C
      NMAIN2=2*NOSACT+2
C
      IF (NGAUSS.GT.NDGAUS) THEN
C
         WRITE(NFIPRI,'(//,1X,''NGAUSS='',I2,'' .GT. NDGAUS='',I2,
     *                         ''   STOP IN DEFINT'',//)') NGAUSS,NDGAUS
         STOP ' NGAUSS.GT.NDGAUS  IN  DEFINT'
C
      END IF
C
C=======================================================================
C          DEFINING ZEROS AND WEIGHTS FOR THE GAUSS-HERMITE  INTEGRATION
C=======================================================================
C
      CALL HERMIT(NGAUSS,XHERMI,WHERMI,NDGAUS)
C
C=======================================================================
C
C        IF NOBODY=2 WE SCALE THE WEIGHTS AND THE ZEROS BY 1/SQRT(2).
C        THIS  SCALING  CORRESPONDS  TO  INTEGRATING  THE PRODUCTS OF
C        F O U R   HARMONIC - OSCILLATOR  WAVE  FUNCTIONS. EXCEPT FOR
C        THE DENSITY-DEPENDENT TERM OF THE SKYRME INTERACTION AND THE
C        COULOMB-EXCHANGE TERM IN THE MEAN FIELD, TOTAL ENERGIES  AND
C        MATRIX ELEMENTS OF THE ONE-BODY POTENTIAL  CONTAIN  PRODUCTS
C        OF  F O U R  WAVE FUNCTIONS. THE SCALED  WEIGHTS  AND  ZEROS
C        WILL BE USED TO INTEGRATE THESE QUANTITIES.
C
C=======================================================================
C
C        IF NOBODY=1 NO SQRT(2) SCALING; IN THIS CASE THE WEIGHTS AND
C        ZEROS CAN BE USED TO INTEGRATE PRODUCTS OF   T W O  HARMONIC
C        OSCILLATOR WAVE FUNCTIONS.
C
C=======================================================================
C
      IF (NOBODY.GT.2) STOP 'NOBODY TOO  BIG  IN DEFINT'
      IF (NOBODY.LT.1) STOP 'NOBODY TOO SMALL IN DEFINT'
C
      IF (NOBODY.EQ.2) SCBODY=SQRT(2.0D0)
      IF (NOBODY.EQ.1) SCBODY=(1.000000D0)
C
      DO IZEROS = 1,NGAUSS
C
         WGTACT(IZEROS,KARTEZ)=WHERMI(IZEROS)/SCBODY/HOMSCA(KARTEZ,1)
C
C=======================================================================
C
C        IN THE ABOVE INSTRUCTION WE HAVE DIVIDED THE GAUSS WEIGHTS BY:
C
C                    HOMSCA() = SQRT(MASS*HOMEG()/H_BAR**2)
C
C        THIS CORRESPONDS TO EXPRESSING THE ONE-DIMENSIONAL INTEGRATION
C        MEASURE IN FERMIS.  INTEGRALS  OVER  THE VOLUME HAVE THEREFORE
C        FERMI**3 AS THEIR DIMENSION.
C
C=======================================================================
C
         PNTACT(IZEROS,KARTEZ)=XHERMI(IZEROS)/SCBODY
C
         XZER = PNTACT(IZEROS,KARTEZ)
C
         CALL D_HERM(XZER,NMAIN2,PHERMI,DHERMI,ND2MAX+1)
C
C=======================================================================
C
C        THE HERMITE POLYNOMIALS ARE MULTIPLIED  BY THE DIMENSIONED
C        NORMALIZATION CONSTANT:
C
C                     (MASS*HOMEG()/H_BAR**2)**(1/4)
C
C        THIS CORRESPONDS TO INTRODUCING THE ONE - DIMENSIONAL WAVE
C        FUNCTIONS IN UNITS OF FM**(-1/2). CORRESPONDING  DENSITIES
C        IN THREE DIMENSIONS ARE THEN IN UNITS OF FM**(-3)
C
C=======================================================================
C
         DO NOSCIL = 0,NMAIN2
C
            HERACT(NOSCIL,IZEROS,KARTEZ) = PHERMI(NOSCIL+1)
     *                                   * SQRT(HOMSCA(KARTEZ,1))
     *                                   / HERFAC( NOSCIL )
C
            DHRACT(NOSCIL,IZEROS,KARTEZ) =(DHERMI(NOSCIL+1)
     *                                   - XZER*PHERMI(NOSCIL+1))
     *                                   * SQRT(HOMSCA(KARTEZ,1))
     *                                   / HERFAC( NOSCIL )
C
            DDHACT(NOSCIL,IZEROS,KARTEZ) =(XZER*XZER-2*NOSCIL-1)
     *                                   * PHERMI(NOSCIL+1)
     *                                   * SQRT(HOMSCA(KARTEZ,1))
     *                                   / HERFAC( NOSCIL )
C
         END DO
C
C=======================================================================
C
C        DERIVATIVES OF THE "HERMITE * EXPONENT" PRODUCTS  (SEE COMMENTS
C        IN DEVHER)  ARE  MULTIPLIED  BY  THE  APPROPRIATE POWERS OF THE
C        DIMENSIONED STRETCHING FACTORS "HOMSCA". IN THIS WAY THE  FIRST
C        DERIVATIVE HAS THE CORRECT DIMENSION OF FERMI**(-3/2). ALSO THE
C        SECOND DERIVATIVE HAS THE CORRECT DIMENSION OF FERMI**(-5/2).
C
C=======================================================================
C
         DO NOSCIL = 0,NMAIN2
C
            DHRACT(NOSCIL,IZEROS,KARTEZ) = DHRACT(NOSCIL,IZEROS,KARTEZ)
     *                                   *             HOMSCA(KARTEZ,1)
C
            DDHACT(NOSCIL,IZEROS,KARTEZ) = DDHACT(NOSCIL,IZEROS,KARTEZ)
     *                                   *             HOMSCA(KARTEZ,1)
     *                                   *             HOMSCA(KARTEZ,1)
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE COPHER(NOSACT,KARTEZ,NGAUSS,HERACT,DHRACT,DDHACT,
     *                                       CERACT,CHRACT,CDHACT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CERACT,CHRACT,CDHACT
C
      DIMENSION
     *          HERACT(0:ND2MAX,1:NDGAUS,1:NDKART),
     *          DHRACT(0:ND2MAX,1:NDGAUS,1:NDKART),
     *          DDHACT(0:ND2MAX,1:NDGAUS,1:NDKART)
      DIMENSION
     *          CERACT(0:ND2MAX,1:NDGAUS,1:NDKART),
     *          CHRACT(0:ND2MAX,1:NDGAUS,1:NDKART),
     *          CDHACT(0:ND2MAX,1:NDGAUS,1:NDKART)
C
C=======================================================================
C
C          THIS SUBROUTINE COPIES THE HARMONIC OSCILLATOR WAVE FUNCTIONS
C          AND THEIR FIRST AND SECOND DERIVATIVES TO COMPLEX ARRAYS.
C
C=======================================================================
C
      NMAIN2=2*NOSACT+2
C
      DO IZEROS = 1,NGAUSS
         DO NOSCIL = 0,NMAIN2
C
            CERACT(NOSCIL,IZEROS,KARTEZ) = HERACT(NOSCIL,IZEROS,KARTEZ)
            CHRACT(NOSCIL,IZEROS,KARTEZ) = DHRACT(NOSCIL,IZEROS,KARTEZ)
            CDHACT(NOSCIL,IZEROS,KARTEZ) = DDHACT(NOSCIL,IZEROS,KARTEZ)
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIASIG(MREVER,ICHARG,LIMPAR,ECUTOF)
C=======================================================================
      USE MAT_PP
      USE ALLWAV
      USE ALLSIG
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,C_ZERO
C=======================================================================
      DIMENSION
     *          PSPECT(1:NDBASP,0:NDPARI)
C=======================================================================
      ALLOCATABLE CELMTS(:)
C=======================================================================
      DIMENSION
     *          NPARIT(1:NDBASE),NPSTAT(1:NDBASE),
     *          NORDER(1:NDBASE),EORDER(1:NDBASE)
      DIMENSION
     *          NUMVEC(0:NDPARI)
C
C=======================================================================
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /SIMSPE/ SPESIM(1:NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /PARIND/ INDPAR(1:NDBASE,0:NDPARI)
      COMMON
     *       /SIGSTA/ ISTSIG(1:NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('DIASIG',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(WAVOCC)) THEN
          ALLOCATE (WAVOCC(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVOCC','DIASIG')
      END IF
C=======================================================================
C SEE COMMENTS IN DIASIM
      IF (.NOT.ALLOCATED(EWASIG)) THEN
          ALLOCATE (EWASIG(1:NDBASP,1:NDBASP,0:NDPARI,0:NDREVE),
     *              STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('EWASIG','DIASIG')
      END IF
C=======================================================================
      IF (LIMPAR.EQ.1) THEN
         IF (.NOT.ALLOCATED(SPESVG)) THEN
             ALLOCATE (SPESVG(1:NDBASP,0:NDPARI,0:NDREVE),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('SPESVG','DIASIG')
         END IF
C=======================================================================
         IF (.NOT.ALLOCATED(LDMEFG)) THEN
             ALLOCATE (LDMEFG(0:NDPARI,0:NDREVE),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('LDMEFG','DIASIG')
         END IF
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:((NDBASP+1)*NDBASP)/2),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIASIG')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE DIAGONALIZATION IN THE CASE OF
C        CONSERVED SIMPLEX AND SIGNATURE SYMMETRIES
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        ATTENTION: IN CASE OF THE CONSERVED TIME-REVERSAL  SYMMETRY
C                   THIS SUBROUTINE IS CALLED WITH MREVER=0, AND THE
C                   DIAGONALIZATION IN THE TIME-REVERSED BLOCK  WILL
C                   NOT BE PERFORMED.
C=======================================================================
C     SEE COMMENTS ABOUT NDBASP IN THE DIASIQ SUBROUTINE
C=======================================================================
C
      IF (MAX(LDBASP(0),LDBASP(1)).GT.NDBASP) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' PARAMETER NDBASP TOO SMALL'',
     *                            '' IN DIASIG'',       1X,19(1H/),/,
     *                 1X,20(1H/),'' NDBASP ='',I3,
     *                            '' INCREASE TO  NDBASP ='',I3,
     *                                                  1X,19(1H/),/)')
     *
     *    NDBASP,MAX(LDBASP(0),LDBASP(1))
C
          STOP 'INCREASE NDBASP IN DIASIG'
C
      END IF
C
C=======================================================================
      DO IREVER=0,MREVER
C
C=======================================================================
C        DIAGONALIZING THE HAMILTONIAN IN EACH PARITY  BLOCK.
C=======================================================================
C        BEFORE THE NUMBERS OF USEFUL STATES IN  EACH  PARITY
C        BLOCK ARE KNOWN, ALL STATES UP TO THE  TOTAL  NUMBER
C        OF THOSE OF GIVEN SIMPLEX AND CHARGE ARE CONSIDERED,
C        BUT NOT MORE THAN THE TOTAL NUMBER OF STATES IN  THE
C        GIVEN PARITY BLOCK
C=======================================================================
C
         DO IPARIT=0,NDPARI
C
            DO IBRAPA = 1,LDBASP(IPARIT)
               DO IKETPA = 1,LDBASP(IPARIT)
C
                  IF (IBRAPA.GE.IKETPA) THEN
C
                      NCOUNT=IBRAPA
     *                         +((2*LDBASP(IPARIT)-IKETPA)*(IKETPA-1))/2
C
                      CELMTS(NCOUNT)=BIG_PP(INDPAR(IBRAPA,IPARIT),
     *                                      INDPAR(IKETPA,IPARIT),
     *                                                    IREVER)
C
                  END IF
C
               END DO
            END DO
C
            IF (LIMPAR.NE.1) THEN
C
                NUMVEC(IPARIT)=MIN(NUMBSP(IREVER,ICHARG),
     *                             LDBASP(IPARIT))
C
                CALL DIAMAT(CELMTS,PSPECT(1,IPARIT),
     *                      EWASIG(:,:,IPARIT,IREVER),
     *                      LDBASP(IPARIT),NDBASP,NUMVEC(IPARIT))
C
            ELSE
C
                EIGMIN=-200.0D0
                EIGMAX=ECUTOF
                NUMVEC(IPARIT)=0
C
                CALL DIAMAT(CELMTS,PSPECT(1,IPARIT),
     *                      EWASIG(:,:,IPARIT,IREVER),
     *                      LDBASP(IPARIT),NDBASP,NUMVEC(IPARIT))
C
                NUMLIM=MIN(NUMBSP(IREVER,ICHARG)/2,LDBASP(IPARIT))
C
                IF (NUMVEC(IPARIT).LT.NUMLIM) THEN
C
                    WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' NOT ENOUGH SP STATES FOUND'',
     *                                '' IN DIASIG'',    1X,19(1H/),/,
     *                     1X,20(1H/),'' LDMEFG='',I4,
     *                                '' SMALLER THAN NUMBSP='',I4,
     *                     1X,20(1H/),'' INCRESE THE CUTOFF ENERGY'',
     *                                '' ECUTOF    '',   1X,19(1H/),/,
     *                                                   1X,19(1H/),/)')
     *
     *               NUMVEC(IPARIT),NUMLIM
C
                     STOP 'INCREASE ECUTOF IN DIASIG'
C
                END IF
C
                SPESVG(1:NUMVEC(IPARIT),IPARIT,IREVER)=
     *          PSPECT(1:NUMVEC(IPARIT),IPARIT)
C
                LDMEFG(IPARIT,IREVER)=NUMVEC(IPARIT)
C
            END IF
C
         END DO
C
C=======================================================================
C        ORDERING THE SINGLE-PARTICLE ENERGIES
C=======================================================================
C
         IORDER=0
C
         DO IPARIT=0,NDPARI
C
            DO IPSTAT=1,NUMVEC(IPARIT)
C
               IORDER=IORDER+1
               NPARIT(IORDER)=IPARIT
               NPSTAT(IORDER)=IPSTAT
               NORDER(IORDER)=IORDER
               EORDER(IORDER)=PSPECT(IPSTAT,IPARIT)
C
            END DO
C
         END DO
C
         CALL ORDER1(EORDER,NORDER,IORDER)
C
C=======================================================================
C        SECURITY CHECK ON THE NUMBER OF STATES FOUND
C=======================================================================
C
         IF (IORDER.LT.NUMBSP(IREVER,ICHARG))
     *
     *       STOP ' NOT ENOUGH STATES IN DIASIG'
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE ENERGIES
C=======================================================================
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            IPARIT=NPARIT(NORDER(ISTATE))
            IPSTAT=NPSTAT(NORDER(ISTATE))
C
            SPESIM(ISTATE)=PSPECT(IPSTAT,IPARIT)
            SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)=SPESIM(ISTATE)
C
            ISTSIG(IPSTAT,IPARIT,IREVER)=ISTATE
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE WAVE FUNCTIONS
C=======================================================================
C
            DO IPBASE=1,LDBASP(IPARIT)
C
               WAVOCC(INDPAR(IPBASE,IPARIT),
     *                ISTATE+IREVER*NUMBSP(0,ICHARG),  IREVER)=
     *                     EWASIG(IPBASE,IPSTAT,IPARIT,IREVER)
               WAVOCC(INDPAR(IPBASE,IPARIT),
     *                ISTATE+IREVER*NUMBSP(0,ICHARG),1-IREVER)=
     *                                                C_ZERO
C
            END DO
C
            DO IPBASE=1,LDBASP(1-IPARIT)
C
               WAVOCC(INDPAR(IPBASE,1-IPARIT),
     *                ISTATE+IREVER*NUMBSP(0,ICHARG),  IREVER)=
     *                                                C_ZERO
               WAVOCC(INDPAR(IPBASE,1-IPARIT),
     *                ISTATE+IREVER*NUMBSP(0,ICHARG),1-IREVER)=
     *                                                C_ZERO
C
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS)
C=======================================================================
C
      CALL CPUTIM('DIASIG',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIASIM(MREVER,ICHARG,LIMPAR,ECUTOF)
C=======================================================================
      USE MAT_PP
      USE ALLWAV
      USE ALLSIM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
      COMPLEX
     *          CELMTS
C=======================================================================
      ALLOCATABLE CELMTS(:)
C=======================================================================
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIMSPE/ SPESIM(1:NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('DIASIM',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(WAVOCC)) THEN
          ALLOCATE (WAVOCC(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVOCC','DIASIM')
      END IF
C=======================================================================
C ALLOCATE SPACE TO STORE WAVE FUNCTION AND SO ON
C NEEDED IN TWO BASIS METHOD.
C=======================================================================
C EWASIM IS USED IN BOTH HF AND TWO BASIS METHOD CASE
      IF (.NOT.ALLOCATED(EWASIM)) THEN
          ALLOCATE (EWASIM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('EWASIM','DIASIM')
      END IF
C=======================================================================
      IF(LIMPAR.EQ.1) THEN
         IF (.NOT.ALLOCATED(SPESVM)) THEN
             ALLOCATE (SPESVM(1:NDBASE,0:NDREVE),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('SPESVM','DIASIM')
         END IF
C=======================================================================
         IF (.NOT.ALLOCATED(LDMEFM)) THEN
             ALLOCATE (LDMEFM(0:NDREVE),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('LDMEFM','DIASIM')
         END IF
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:((NDBASE+1)*NDBASE)/2),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIASIM')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE DIAGONALIZATION IN THE CASE OF
C        CONSERVED SIMPLEX SYMMETRY
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        ATTENTION: IN CASE OF THE CONSERVED TIME-REVERSAL  SYMMETRY
C                   THIS SUBROUTINE IS CALLED WITH MREVER=0, AND THE
C                   DIAGONALIZATION IN THE TIME-REVERSED BLOCK  WILL
C                   NOT BE PERFORMED.
C=======================================================================
C
      DO IREVER=0,MREVER
C
         DO IBRA=1,LDBASE
            DO IKET=1,LDBASE
C
               IF (IBRA.GE.IKET) THEN
C
                   NCOUNT=IBRA+((2*LDBASE-IKET)*(IKET-1))/2
C
                   CELMTS(NCOUNT)=BIG_PP(IBRA,IKET,IREVER)
C
               END IF
C
            END DO
         END DO
C
         IF (LIMPAR.NE.1) THEN!HF
C
             CALL DIAMAT(CELMTS,SPESIM,EWASIM(:,:,IREVER),
     *                   LDBASE,NDBASE,NUMBSP(IREVER,ICHARG))
C
         ELSE
C
             EIGMIN=-200.0D0
             EIGMAX=ECUTOF
             LDMEFM(IREVER)=0
C
             CALL DIAMAT(CELMTS,SPESIM,EWASIM(:,:,IREVER),
     *                   LDBASE,NDBASE,LDMEFM(IREVER))
C
             IF (LDMEFM(IREVER).LT.NUMBSP(IREVER,ICHARG)) THEN
C
                 WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' NOT ENOUGH SP STATES FOUND'',
     *                                '' IN DIASIM'',    1X,19(1H/),/,
     *                     1X,20(1H/),'' LDMEFM='',I4,
     *                                '' SMALLER THAN NUMBSP='',I4,
     *                     1X,20(1H/),'' INCRESE THE CUTOFF ENERGY'',
     *                                '' ECUTOF    '',   1X,19(1H/),/,
     *                                                   1X,19(1H/),/)')
     *
     *           LDMEFM(IREVER),NUMBSP(IREVER,ICHARG)
C
                 STOP 'INCREASE ECUTOF IN DIASIM'
C
             END IF
C
             SPESVM(1:LDMEFM(IREVER),IREVER)=SPESIM(1:LDMEFM(IREVER))
C
         END IF
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE ENERGIES AND WAVE FUNCTIONS
C=======================================================================
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)=SPESIM(ISTATE)
C
            DO IBASE=1,LDBASE
C
               WAVOCC(IBASE,ISTATE+IREVER*NUMBSP(0,ICHARG),1-IREVER)=
     *                                                       C_ZERO
               WAVOCC(IBASE,ISTATE+IREVER*NUMBSP(0,ICHARG),  IREVER)=
     *                                   EWASIM(IBASE,ISTATE,IREVER)
C
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS)
C=======================================================================
C
      CALL CPUTIM('DIASIM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIASIQ(ICHARG,LIMPAR,ECUTOF)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE ALLWAV
      USE ALLSIQ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,C_ZERO
C=======================================================================
      ALLOCATABLE CELMTS(:)
C=======================================================================
      DIMENSION
     *          SPESIQ(1:2*NDBASP,0:NDPARI)
      DIMENSION
     *          NPARIT(1:2*NDBASE),NPSTAT(1:2*NDBASE),
     *          NORDER(1:2*NDBASE),EORDER(1:2*NDBASE)
      DIMENSION
     *          NUMVEC(0:NDPARI)
C
C=======================================================================
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /PARIND/ INDPAR(1:NDBASE,0:NDPARI)
      COMMON
     *       /SIQSTA/ ISTSIQ(1:2*NDSTAT,0:NDPARI)
      COMMON
     *       /CUSIQN/ NCUSIQ(0:NDISOS,0:NDPARI)
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('DIASIQ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(WAVOCC)) THEN
          ALLOCATE (WAVOCC(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVOCC','DIASIQ')
      END IF
C=======================================================================
C SEE COMMENTS IN DIASIM
      IF (.NOT.ALLOCATED(EWASIQ)) THEN
          ALLOCATE (EWASIQ(1:2*NDBASP,1:2*NDBASP,0:NDPARI),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('EWASIQ','DIASIQ')
      END IF
C=======================================================================
      IF (LIMPAR.EQ.1) THEN
         IF (.NOT.ALLOCATED(SPESVQ)) THEN
             ALLOCATE (SPESVQ(1:2*NDBASP,0:NDPARI),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('SPESVQ','DIASIQ')
         END IF
C=======================================================================
         IF (.NOT.ALLOCATED(LDMEFQ)) THEN
             ALLOCATE (LDMEFQ(0:NDPARI),STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('LDMEFQ','DIASIQ')
         END IF
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:(2*NDBASP+1)*NDBASP),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIASIQ')
C
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE DIAGONALIZATION IN THE CASE OF
C        BROKEN SIMPLEX AND CONSERVED PARITY
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        THE TEST BELOW IS PERFORMED TO CHECK WHETHER THE  DIMENSIONS
C        OF THE  HAMILTONIAN  MATRICES  ARE  SUFFICIENT. THE  FORMULA
C                     NDBASP=NDBASE/2+MAX(10,NDBASE/12)
C        WOULD HAVE ENSURED THAT THE DIMENSIONS ARE CORRECT  FOR  ANY
C        CLOSED-SHELL SPHERICAL BASIS. SINCE FOR THE  DEFORMED  BASIS
C        THE NUMBERS OF POSITIVE AND NEGATIVE-PARITY BASIS STATES ARE
C        DIFFERENT, AN EMPIRICAL SAFE FORMULA
C                     NDBASP=NDBASE/2+MAX(20,NDBASE/12)
C        IS USED IN THE PARAMETER STATEMENT ABOVE. IF THE TEST  BELOW
C        FAILS, THE USER SHOULD SET NDBASP EQUAL TO THE VALUE THAT IS
C        EQUAL TO
C                       MAX(LDBASP(0),LDBASP(1))
C        WHICH IS PRINTED BY THE PROGRAM IN THE MESSAGE  ACCOMPANYING
C        THE STOP STATEMENT BELOW.
C=======================================================================
C
      IF (MAX(LDBASP(0),LDBASP(1)).GT.NDBASP) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' PARAMETER NDBASP TOO SMALL'',
     *                            '' IN DIASIQ'',       1X,19(1H/),/,
     *                 1X,20(1H/),'' NDBASP ='',I3,
     *                            '' INCREASE TO  NDBASP ='',I3,
     *                                                  1X,19(1H/),/)')
     *
     *    NDBASP,MAX(LDBASP(0),LDBASP(1))
C
          STOP 'INCREASE NDBASP IN DIASIQ'
C
      END IF
C
C=======================================================================
C        DIAGONALIZING THE HAMILTONIAN IN EACH PARITY BLOCK.
C=======================================================================
C        BEFORE THE NUMBERS OF USEFUL STATES IN EACH PARITY
C        BLOCK ARE KNOWN, ALL STATES UP TO THE TOTAL NUMBER
C        OF THOSE OF GIVEN CHARGE ARE  CONSIDERED, BUT  NOT
C        MORE THAN THE TOTAL NUMBER OF STATES IN THE  GIVEN
C        PARITY BLOCK.
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
         LDPARI=LDBASP(IPARIT)
         NCOUNT=0
C
         DO IKETPA=1,2*LDPARI
            DO IBRAPA=IKETPA,2*LDPARI
C
               NCOUNT=NCOUNT+1
C
               IF (IBRAPA.LE.LDPARI.AND.IKETPA.LE.LDPARI)
     *             CELMTS(NCOUNT)=BIG_PP(INDPAR(IBRAPA,       IPARIT),
     *                                   INDPAR(IKETPA,       IPARIT),0)
C
               IF (IBRAPA.GT.LDPARI.AND.IKETPA.LE.LDPARI)
     *             CELMTS(NCOUNT)=BIG_PM(INDPAR(IBRAPA-LDPARI,IPARIT),
     *                                   INDPAR(IKETPA,       IPARIT),1)
C
               IF (IBRAPA.GT.LDPARI.AND.IKETPA.GT.LDPARI)
     *             CELMTS(NCOUNT)=BIG_PP(INDPAR(IBRAPA-LDPARI,IPARIT),
     *                                   INDPAR(IKETPA-LDPARI,IPARIT),1)
C
            END DO
         END DO
C
         IF (LIMPAR.NE.1) THEN
             NUMVEC(IPARIT)=MIN(NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG),
     *                          2*LDPARI)
C
             CALL DIAMAT(CELMTS,SPESIQ(1,IPARIT),EWASIQ(1,1,IPARIT),
     *                   2*LDPARI,2*NDBASP,NUMVEC(IPARIT))
C
         ELSE
C
             IF (NCUSIQ(ICHARG,IPARIT).EQ.0) THEN
C
                 EIGMIN=-200.0D0
                 EIGMAX=ECUTOF
                 NUMVEC(IPARIT)=0
             ELSE
                 NUMVEC(IPARIT)=NCUSIQ(ICHARG,IPARIT)
C
             END IF
C
             CALL DIAMAT(CELMTS,SPESIQ(1,IPARIT),EWASIQ(1,1,IPARIT),
     *                             2*LDPARI,2*NDBASP,NUMVEC(IPARIT))
C
             NUMLIM=MIN((NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG))/2,2*LDPARI)
C
             IF (NUMVEC(IPARIT).LT.NUMLIM) THEN
C
                 WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' NOT ENOUGH SP STATES FOUND'',
     *                                '' IN DIASIQ'',    1X,19(1H/),/,
     *                     1X,20(1H/),'' LDMEFQ='',I4,
     *                                '' SMALLER THAN NUMBSP='',I4,
     *                     1X,20(1H/),'' INCRESE THE CUTOFF ENERGY'',
     *                                '' ECUTOF    '',   1X,19(1H/),/,
     *                                                   1X,19(1H/),/)')
     *
     *           NUMVEC(IPARIT),NUMLIM
C
                 STOP 'INCREASE ECUTOF IN DIASIQ'
C
             END IF
C
             SPESVQ(1:NUMVEC(IPARIT),IPARIT)=
     *       SPESIQ(1:NUMVEC(IPARIT),IPARIT)
C
             LDMEFQ(IPARIT)=NUMVEC(IPARIT)
         END IF
C
      END DO
C
C=======================================================================
C        ORDERING THE SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      IORDER=0
C
      DO IPARIT=0,NDPARI
C
         DO IPSTAT=1,NUMVEC(IPARIT)
C
            IORDER=IORDER+1
            NPARIT(IORDER)=IPARIT
            NPSTAT(IORDER)=IPSTAT
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=SPESIQ(IPSTAT,IPARIT)
C
         END DO
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
C=======================================================================
C        SECURITY CHECK ON THE NUMBER OF STATES FOUND
C=======================================================================
C
         IF (IORDER.LT.NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG))
     *
     *       STOP ' NOT ENOUGH STATES IN DIASIQ'
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
         IPARIT=NPARIT(NORDER(ISTATE))
         IPSTAT=NPSTAT(NORDER(ISTATE))
C
         ISTSIQ(IPSTAT,IPARIT)=ISTATE
C
         SPENER(ISTATE,ICHARG)=SPESIQ(IPSTAT,IPARIT)
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE WAVE FUNCTIONS
C=======================================================================
C
         DO IREVER=0,NDREVE
C
            DO IPBASE=1,LDBASP(IPARIT)
C
               WAVOCC(INDPAR(IPBASE,IPARIT),ISTATE,IREVER)=
     *                EWASIQ(IPBASE+IREVER*LDBASP(IPARIT),IPSTAT,IPARIT)
C
            END DO
C
            DO IPBASE=1,LDBASP(1-IPARIT)
C
               WAVOCC(INDPAR(IPBASE,1-IPARIT),ISTATE,IREVER)=C_ZERO
C
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS)
C=======================================================================
C
      CALL CPUTIM('DIASIQ',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIASIZ(ICHARG,LIMPAR,ECUTOF,LDMEFI,ISAOCC)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE ALLWAV
      USE ALLSIZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS
C=======================================================================
      ALLOCATABLE CELMTS(:)
C=======================================================================
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZSPE/ SPESIZ(1:4*NDBASE)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CUSIZN/ NCUSIZ(0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /NPADBC/ NPTOTL(0:NDISOS)
C
C=======================================================================
C
      CALL CPUTIM('DIASIZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(WAVOCC)) THEN
          ALLOCATE (WAVOCC(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVOCC','DIASIZ')
      END IF
C=======================================================================
      IF (ISAOCC.EQ.1.AND..NOT.ALLOCATED(SAVOCC)) THEN
          ALLOCATE (SAVOCC(1:NDBASE,1:2*NDSTAT,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SAVOCC','DIASIZ')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(EWASIZ)) THEN
          ALLOCATE (EWASIZ(1:2*NDBASE,1:2*NDBASE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('EWASIZ','DIASIZ')
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:(2*NDBASE+1)*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIASIZ')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE DIAGONALIZATION IN THE CASE OF
C        NO CONSERVED SYMMETRIES
C=======================================================================
C
C=======================================================================
C         CONSTRUCTING THE HAMILTONIAN MATRIX
C=======================================================================
C
      DO IBRA=1,2*LDBASE
         DO IKET=1,2*LDBASE
C
            IF (IBRA.GE.IKET) THEN
C
                NCOUNT=IBRA+((4*LDBASE-IKET)*(IKET-1))/2
C
                IF (IBRA.LE.LDBASE.AND.IKET.LE.LDBASE)
     *
     *              CELMTS(NCOUNT)=BIG_PP(IBRA,IKET,0)
C
                IF (IBRA.GT.LDBASE.AND.IKET.LE.LDBASE)
     *
     *              CELMTS(NCOUNT)=BIG_PM(IBRA-LDBASE,IKET,1)
C
                IF (IBRA.GT.LDBASE.AND.IKET.GT.LDBASE)
     *
     *              CELMTS(NCOUNT)=BIG_PP(IBRA-LDBASE,IKET-LDBASE,1)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      IF (ISAOCC.EQ.1) LIMPAR = 1
C
      IF (LIMPAR.NE.1) THEN
C
          LDMEFI=NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
          CALL DIAMAT(CELMTS,SPESIZ,EWASIZ,2*LDBASE,2*NDBASE,LDMEFI)
C
      ELSE
C
          IF (NCUSIZ(ICHARG).EQ.0) THEN
C
              EIGMIN=-200.0D0
              EIGMAX=ECUTOF
              IF (ISAOCC.EQ.1) EIGMAX = 9999.d0
              LDMEFI=0
          ELSE
              LDMEFI=NCUSIZ(ICHARG)
C
          END IF
C
          CALL DIAMAT(CELMTS,SPESIZ,EWASIZ,2*LDBASE,2*NDBASE,LDMEFI)
C
          IF (LDMEFI.LT.NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' NOT ENOUGH SP STATES FOUND'',
     *                                '' IN DIASIZ'',    1X,19(1H/),/,
     *                     1X,20(1H/),'' LDMEFI='',I4,
     *                                '' SMALLER THAN NUMBSP='',I4,
     *                     1X,20(1H/),'' INCRESE THE CUTOFF ENERGY'',
     *                                '' ECUTOF    '',   1X,19(1H/),/,
     *                                                   1X,19(1H/),/)')
     *
     *        LDMEFI,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
              STOP 'INCREASE ECUTOF IN DIASIZ'
C
          END IF
C
      END IF
C
C=======================================================================
C
      DO IALLST=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
         SPENER(IALLST,ICHARG)=SPESIZ(IALLST)
      END DO
C
C=======================================================================
C         SAVING THE SINGLE-PARTICLE WAVE FUNCTIONS TO BE USED  FOR  THE
C         CURRENT CHARGE
C=======================================================================
C
      DO IALLST=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
         DO IBASE=1,LDBASE
            WAVOCC(IBASE,IALLST,0)=EWASIZ(IBASE       ,IALLST)
            WAVOCC(IBASE,IALLST,1)=EWASIZ(IBASE+LDBASE,IALLST)
         END DO
      END DO
C
C=======================================================================
C         SAVING THE SINGLE-PARTICLE WAVE FUNCTIONS TO BE USED FOR  BOTH
C         CHARGES
C=======================================================================
C
      IF (ISAOCC.EQ.1) THEN
C
          NPTOTL(ICHARG) = LDMEFI
C
          DO IALLST=1,NPTOTL(ICHARG)
             SPENER(IALLST,ICHARG)=SPESIZ(IALLST)
          END DO
C
          DO IALLST=1,NPTOTL(ICHARG)
             DO IBASE=1,LDBASE
                WAVOCC(IBASE,IALLST,0)=EWASIZ(IBASE       ,IALLST)
                WAVOCC(IBASE,IALLST,1)=EWASIZ(IBASE+LDBASE,IALLST)
             END DO
          END DO
C
          DO IALLST=1,NPTOTL(ICHARG)
             DO IBASE=1,LDBASE
                SAVOCC(IBASE,IALLST,0,ICHARG)=WAVOCC(IBASE,IALLST,0)
                SAVOCC(IBASE,IALLST,1,ICHARG)=WAVOCC(IBASE,IALLST,1)
             END DO
          END DO
C
      END IF
C
C=======================================================================
      DEALLOCATE (CELMTS)
C=======================================================================
C
      CALL CPUTIM('DIASIZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE DIAMIG(MREVER)
C=======================================================================
      USE PNMXPP
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          PWAVEF,CELMTS,C_ZERO
C=======================================================================
      ALLOCATABLE PWAVEF(:,:,:)
C=======================================================================
      DIMENSION
     *          PSPECT(1:2*NDBASP,0:NDPARI)
C=======================================================================
      ALLOCATABLE CELMTS(:)
C=======================================================================
      DIMENSION
     *          NPARIT(1:2*NDBASE),NPSTAT(1:2*NDBASE),
     *          NORDER(1:2*NDBASE),EORDER(1:2*NDBASE)
      DIMENSION
     *          NUMVEC(0:NDPARI)
C
C=======================================================================
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /SIMPNM/ SPNSIM(1:2*NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /PARIND/ INDPAR(1:NDBASE,0:NDPARI)
      COMMON
     *       /MIGSTA/ ISTMIG(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('DIAMIG',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(PNMOCC)) THEN
          ALLOCATE (PNMOCC(1:2*NDBASE,1:4*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PNMOCC','DIAMIG')
      END IF
C=======================================================================
      ALLOCATE (PWAVEF(1:2*NDBASP,1:2*NDBASP,0:NDPARI),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('PWAVEF','DIAMIG')
      ALLOCATE (CELMTS(1:((2*NDBASP+1)*2*NDBASP)/2),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIAMIG')
C=======================================================================
C
C=======================================================================
C   THIS SUBROUTINE PERFORMS THE HF DIAGONALIZATION IN THE CASE OF
C   CONSERVED SIMPLEX AND SIGNATURE SYMMETRIES AND PROTON-NEUTRON MIXING
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        ATTENTION: IN CASE OF THE CONSERVED TIME-REVERSAL  SYMMETRY
C                   THIS SUBROUTINE IS CALLED WITH MREVER=0, AND THE
C                   DIAGONALIZATION IN THE TIME-REVERSED BLOCK  WILL
C                   NOT BE PERFORMED.
C=======================================================================
C     SEE COMMENTS ABOUT NDBASP IN THE DIASIQ SUBROUTINE
C=======================================================================
C
      IF (MAX(LDBASP(0),LDBASP(1)).GT.NDBASP) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' PARAMETER NDBASP TOO SMALL'',
     *                            '' IN DIAMIG'',       1X,19(1H/),/,
     *                 1X,20(1H/),'' NDBASP ='',I3,
     *                            '' INCREASE TO  NDBASP ='',I3,
     *                                                  1X,19(1H/),/)')
     *
     *    NDBASP,MAX(LDBASP(0),LDBASP(1))
C
          STOP 'INCREASE NDBASP IN DIAMIG'
C
      END IF
C
C=======================================================================
      DO IREVER=0,MREVER
C
C=======================================================================
C        DIAGONALIZING THE HAMILTONIAN IN EACH PARITY  BLOCK.
C=======================================================================
C        BEFORE THE NUMBERS OF USEFUL STATES IN  EACH  PARITY
C        BLOCK ARE KNOWN, ALL STATES UP TO THE  TOTAL  NUMBER
C        OF THOSE OF GIVEN SIMPLEX ARE CONSIDERED,
C        BUT NOT MORE THAN THE TOTAL NUMBER OF STATES IN  THE
C        GIVEN PARITY BLOCK
C=======================================================================
C
         DO IPARIT=0,NDPARI
C
            LDPARI=LDBASP(IPARIT)
            NCOUNT=0
C
            DO IKETPA = 1,2*LDPARI
               DO IBRAPA = IKETPA,2*LDPARI
C
                  NCOUNT=NCOUNT+1
C
                  IF(IBRAPA.LE.LDPARI .AND. IKETPA.LE.LDPARI)
     *                CELMTS(NCOUNT)
     *               =PNM_PP(INDPAR(IBRAPA,IPARIT),
     *                       INDPAR(IKETPA,IPARIT),       IREVER)
C
                  IF(IBRAPA.GT.LDPARI .AND. IKETPA.LE.LDPARI)
     *                CELMTS(NCOUNT)
     *               =PNM_PP(INDPAR(IBRAPA-LDPARI,IPARIT)+LDBASE,
     *                       INDPAR(IKETPA,IPARIT),       IREVER)
C
                  IF(IBRAPA.GT.LDPARI .AND. IKETPA.GT.LDPARI)
     *                CELMTS(NCOUNT)
     *               =PNM_PP(INDPAR(IBRAPA-LDPARI,IPARIT)+LDBASE,
     *                       INDPAR(IKETPA-LDPARI,IPARIT)+LDBASE,
     *                                                    IREVER)
               END DO
            END DO
C
            NUMVEC(IPARIT)=MIN((NUMBSP(IREVER,0)+NUMBSP(IREVER,1))
     *                                                ,2*LDBASP(IPARIT))
C
            CALL DIAMAT(CELMTS,PSPECT(1,IPARIT),PWAVEF(1,1,IPARIT),
     *                      2*LDBASP(IPARIT),2*NDBASP,NUMVEC(IPARIT))
C
         END DO
C
C=======================================================================
C        ORDERING THE SINGLE-PARTICLE ENERGIES
C=======================================================================
C
         IORDER=0
C
         DO IPARIT=0,NDPARI
C
            DO IPSTAT=1,NUMVEC(IPARIT)
C
               IORDER=IORDER+1
               NPARIT(IORDER)=IPARIT
               NPSTAT(IORDER)=IPSTAT
               NORDER(IORDER)=IORDER
               EORDER(IORDER)=PSPECT(IPSTAT,IPARIT)
C
            END DO
C
         END DO
C
         CALL ORDER1(EORDER,NORDER,IORDER)
C
C=======================================================================
C        SECURITY CHECK ON THE NUMBER OF STATES FOUND
C=======================================================================
C
         IF (IORDER.LT.NUMBSP(IREVER,0)+NUMBSP(IREVER,1))
     *
     *       STOP ' NOT ENOUGH STATES IN DIAMIG'
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE ENERGIES
C=======================================================================
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IPARIT=NPARIT(NORDER(ISTATE))
            IPSTAT=NPSTAT(NORDER(ISTATE))
C
            SPNSIM(ISTATE)=PSPECT(IPSTAT,IPARIT)
            PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *     =SPNSIM(ISTATE)
C
            ISTMIG(IPSTAT,IPARIT,IREVER)=ISTATE
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE WAVE FUNCTIONS
C=======================================================================
C
            DO IPBASE=1,LDBASP(IPARIT)
C
               PNMOCC(INDPAR(IPBASE,IPARIT),
     *                ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),  IREVER)
     *        =PWAVEF(IPBASE,IPSTAT,IPARIT)
C
               PNMOCC(INDPAR(IPBASE,IPARIT),
     *                ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)), 1-IREVER)
     *        =C_ZERO
C
            END DO
C
            DO IPBASE=1+LDBASP(IPARIT),2*LDBASP(IPARIT)
C
               PNMOCC(INDPAR(IPBASE-LDBASP(IPARIT),IPARIT)+LDBASE,
     *                ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),  IREVER)
     *        =PWAVEF(IPBASE,IPSTAT,IPARIT)
C
               PNMOCC(INDPAR(IPBASE-LDBASP(IPARIT),IPARIT)+LDBASE,
     *                ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)), 1-IREVER)
     *        =C_ZERO
C
            END DO
C
            DO IPBASE=1,LDBASP(1-IPARIT)
C
               PNMOCC(INDPAR(IPBASE,1-IPARIT),
     *                ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),  IREVER)
     *         =C_ZERO
C
               PNMOCC(INDPAR(IPBASE,1-IPARIT),
     *                ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),1-IREVER)
     *         =C_ZERO
C
            END DO
C
            DO IPBASE=1+LDBASP(1-IPARIT),2*LDBASP(1-IPARIT)
C
               PNMOCC(INDPAR(IPBASE-LDBASP(1-IPARIT),1-IPARIT)+LDBASE,
     *                ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),  IREVER)
     *         =C_ZERO
C
               PNMOCC(INDPAR(IPBASE-LDBASP(1-IPARIT),1-IPARIT)+LDBASE,
     *                ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),1-IREVER)
     *         =C_ZERO
C
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
      DEALLOCATE (PWAVEF,CELMTS)
C=======================================================================
C
      CALL CPUTIM('DIAMIG',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIAMIM(MREVER)
C=======================================================================
      USE PNMXPP
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          EWAVEF,C_ZERO
      COMPLEX
     *          CELMTS
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE EWAVEF(:,:)
C=======================================================================
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /SIMPNM/ SPNSIM(1:2*NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('DIAMIM',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(PNMOCC)) THEN
          ALLOCATE (PNMOCC(1:2*NDBASE,1:4*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PNMOCC','DIAMIM')
      END IF
C=======================================================================
      ALLOCATE (EWAVEF(1:2*NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAVEF','DIAMIM')
      ALLOCATE (CELMTS(1:((2*NDBASE+1)*2*NDBASE)/2),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIAMIM')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE HF DIAGONALIZATION IN THE CASE OF
C        CONSERVED SIMPLEX SYMMETRY AND PROTON-NEUTRON MIXED STATES
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        ATTENTION: IN CASE OF THE CONSERVED TIME-REVERSAL  SYMMETRY
C                   THIS SUBROUTINE IS CALLED WITH MREVER=0, AND THE
C                   DIAGONALIZATION IN THE TIME-REVERSED BLOCK  WILL
C                   NOT BE PERFORMED.
C=======================================================================
C
      DO IREVER=0,MREVER
C
         DO IBRA=1,2*LDBASE
            DO IKET=1,2*LDBASE
C
               IF (IBRA.GE.IKET) THEN
C
                   NCOUNT=IBRA+((4*LDBASE-IKET)*(IKET-1))/2
C
                   CELMTS(NCOUNT)=PNM_PP(IBRA,IKET,IREVER)
C
               END IF
C
            END DO
         END DO
C
         CALL DIAMAT(CELMTS,SPNSIM,EWAVEF,2*LDBASE,2*NDBASE,
     *                                NUMBSP(IREVER,0)+NUMBSP(IREVER,1))
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE ENERGIES AND WAVE FUNCTIONS
C=======================================================================
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                   =SPNSIM(ISTATE)
C
            DO IBASE=1,2*LDBASE
C
               PNMOCC(IBASE,ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),
     *                                  1-IREVER)=C_ZERO
               PNMOCC(IBASE,ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),
     *                                    IREVER)=  EWAVEF(IBASE,ISTATE)
C
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
      DEALLOCATE (EWAVEF,CELMTS)
C=======================================================================
C
      CALL CPUTIM('DIAMIM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIAMIQ
C=======================================================================
      USE PNMXPP
      USE PNMXPM
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          EWAMIQ,CELMTS,C_ZERO
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE EWAMIQ(:,:,:)
C=======================================================================
      DIMENSION
     *          SPNMIQ(1:4*NDBASP,0:NDPARI)
      DIMENSION
     *          NPARIT(1:4*NDBASE),NPSTAT(1:4*NDBASE),
     *          NORDER(1:4*NDBASE),EORDER(1:4*NDBASE)
      DIMENSION
     *          NUMVEC(0:NDPARI)
C
C=======================================================================
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /PARIND/ INDPAR(1:NDBASE,0:NDPARI)
      COMMON
     *       /MIQSTA/ ISTMIQ(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('DIAMIQ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(PNMOCC)) THEN
          ALLOCATE (PNMOCC(1:2*NDBASE,1:4*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PNMOCC','DIAMIQ')
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:(4*NDBASP+1)*2*NDBASP),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIAMIQ')
      ALLOCATE (EWAMIQ(1:4*NDBASP,1:4*NDBASP,0:NDPARI),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAMIQ','DIAMIQ')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE HF DIAGONALIZATION IN THE CASE OF
C        BROKEN SIMPLEX AND CONSERVED PARITY AND PROTON-NEUTRON MIXING
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        THE TEST BELOW IS PERFORMED TO CHECK WHETHER THE  DIMENSIONS
C        OF THE  HAMILTONIAN  MATRICES  ARE  SUFFICIENT. THE  FORMULA
C                     NDBASP=NDBASE/2+MAX(10,NDBASE/12)
C        WOULD HAVE ENSURED THAT THE DIMENSIONS ARE CORRECT  FOR  ANY
C        CLOSED-SHELL SPHERICAL BASIS. SINCE FOR THE  DEFORMED  BASIS
C        THE NUMBERS OF POSITIVE AND NEGATIVE-PARITY BASIS STATES ARE
C        DIFFERENT, AN EMPIRICAL SAFE FORMULA
C                     NDBASP=NDBASE/2+MAX(20,NDBASE/12)
C        IS USED IN THE PARAMETER STATEMENT ABOVE. IF THE TEST  BELOW
C        FAILS, THE USER SHOULD SET NDBASP EQUAL TO THE VALUE THAT IS
C        EQUAL TO
C                       MAX(LDBASP(0),LDBASP(1))
C        WHICH IS PRINTED BY THE PROGRAM IN THE MESSAGE  ACCOMPANYING
C        THE STOP STATEMENT BELOW.
C=======================================================================
C
      IF (MAX(LDBASP(0),LDBASP(1)).GT.NDBASP) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' PARAMETER NDBASP TOO SMALL'',
     *                            '' IN DIAMIQ'',       1X,19(1H/),/,
     *                 1X,20(1H/),'' NDBASP ='',I3,
     *                            '' INCREASE TO  NDBASP ='',I3,
     *                                                  1X,19(1H/),/)')
     *
     *    NDBASP,MAX(LDBASP(0),LDBASP(1))
C
          STOP 'INCREASE NDBASP IN DIAMIQ'
C
      END IF
C
C=======================================================================
C        DIAGONALIZING THE HAMILTONIAN IN EACH PARITY BLOCK.
C=======================================================================
C        BEFORE THE NUMBERS OF USEFUL STATES IN EACH PARITY
C        BLOCK ARE KNOWN, ALL STATES UP TO THE TOTAL NUMBER
C        OF THOSE OF GIVEN CHARGE ARE  CONSIDERED, BUT  NOT
C        MORE THAN THE TOTAL NUMBER OF STATES IN THE  GIVEN
C        PARITY BLOCK.
C=======================================================================
C
      IPNKET=0
      IPNBRA=0
      DO IPARIT=0,NDPARI
C
         LDPARI=LDBASP(IPARIT)
         NCOUNT=0
C
         DO IKETPA=1,4*LDPARI
C
            MOIKLD=MOD(IKETPA,LDPARI)
            IF(MOIKLD.EQ.0) MOIKLD=LDPARI
            IPNKET=MOD((IKETPA-MOIKLD)/LDPARI,2)
C
            DO IBRAPA=IKETPA,4*LDPARI
C
               MOIBLD=MOD(IBRAPA,LDPARI)
               IF(MOIBLD.EQ.0) MOIBLD=LDPARI
               IPNBRA=MOD((IBRAPA-MOIBLD)/LDPARI,2)
C
               NCOUNT=NCOUNT+1
C
               IF (IBRAPA.LE.2*LDPARI.AND.IKETPA.LE.2*LDPARI)
     *             CELMTS(NCOUNT)
     *            =PNM_PP(INDPAR(MOIBLD,       IPARIT)+IPNBRA*LDBASE,
     *                    INDPAR(MOIKLD,       IPARIT)+IPNKET*LDBASE,0)
C
               IF (IBRAPA.GT.2*LDPARI.AND.IKETPA.LE.2*LDPARI)
     *             CELMTS(NCOUNT)
     *            =PNM_PM(INDPAR(MOIBLD,       IPARIT)+IPNBRA*LDBASE,
     *                    INDPAR(MOIKLD,       IPARIT)+IPNKET*LDBASE,1)
C
               IF (IBRAPA.GT.2*LDPARI.AND.IKETPA.GT.2*LDPARI)
     *             CELMTS(NCOUNT)
     *            =PNM_PP(INDPAR(MOIBLD,       IPARIT)+IPNBRA*LDBASE,
     *                    INDPAR(MOIKLD,       IPARIT)+IPNKET*LDBASE,1)
C
            END DO
         END DO
C
         NUMVEC(IPARIT)=MIN(NUMBSP(0,0)+NUMBSP(1,0)
     *                     +NUMBSP(0,1)+NUMBSP(1,1),4*LDPARI)
C
         CALL DIAMAT(CELMTS,SPNMIQ(1,IPARIT),EWAMIQ(1,1,IPARIT),
     *                                 4*LDPARI,4*NDBASP,NUMVEC(IPARIT))
C
      END DO
C
C=======================================================================
C        ORDERING THE SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      IORDER=0
C
      DO IPARIT=0,NDPARI
C
         DO IPSTAT=1,NUMVEC(IPARIT)
C
            IORDER=IORDER+1
            NPARIT(IORDER)=IPARIT
            NPSTAT(IORDER)=IPSTAT
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=SPNMIQ(IPSTAT,IPARIT)
C
         END DO
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
C=======================================================================
C        SECURITY CHECK ON THE NUMBER OF STATES FOUND
C=======================================================================
C
      IF (IORDER.LT.NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1))
     *
     *       STOP ' NOT ENOUGH STATES IN DIAMIQ'
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         IPARIT=NPARIT(NORDER(ISTATE))
         IPSTAT=NPSTAT(NORDER(ISTATE))
C
         ISTMIQ(IPSTAT,IPARIT)=ISTATE
C
         PNENER(ISTATE)=SPNMIQ(IPSTAT,IPARIT)
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE WAVE FUNCTIONS
C=======================================================================
C
         DO IREVER=0,NDREVE
C
            DO IPBASE=1,LDBASP(IPARIT)
C
               PNMOCC(INDPAR(IPBASE,IPARIT),ISTATE,IREVER)=
     *         EWAMIQ(IPBASE+IREVER*2*LDBASP(IPARIT),IPSTAT,IPARIT)
C
            END DO
C
            DO IPBASE=1+LDBASP(IPARIT),2*LDBASP(IPARIT)
C
               PNMOCC(INDPAR(IPBASE-LDBASP(IPARIT),IPARIT)+LDBASE,
     *                                               ISTATE,IREVER)=
     *         EWAMIQ(IPBASE+IREVER*2*LDBASP(IPARIT),IPSTAT,IPARIT)
C
            END DO
C
            DO IPBASE=1,LDBASP(1-IPARIT)
C
               PNMOCC(INDPAR(IPBASE,1-IPARIT),ISTATE,IREVER)=C_ZERO
C
            END DO
C
            DO IPBASE=1+LDBASP(1-IPARIT),2*LDBASP(1-IPARIT)
C
               PNMOCC(INDPAR(IPBASE-LDBASP(1-IPARIT),1-IPARIT)+LDBASE
     *                                       ,ISTATE,IREVER)=C_ZERO
C
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS,EWAMIQ)
C=======================================================================
C
      CALL CPUTIM('DIAMIQ',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIAMIZ(LIMPAR,ECUTOF,LDMEFI)
C=======================================================================
      USE PNMXPP
      USE PNMXPM
      USE PNMWAV
      USE ALLMIZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS
C=======================================================================
      ALLOCATABLE CELMTS(:)
C=======================================================================
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /SIZSPE/ SPESIZ(1:4*NDBASE)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('DIAMIZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(PNMOCC)) THEN
          ALLOCATE (PNMOCC(1:2*NDBASE,1:4*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PNMOCC','DIAMIZ')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(EWAMIZ)) THEN
          ALLOCATE (EWAMIZ(1:4*NDBASE,1:4*NDBASE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('EWAMIZ','DIAMIZ')
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:(4*NDBASE+1)*2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','DIAMIZ')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE HF DIAGONALIZATION IN THE CASE  OF
C        NO CONSERVED SYMMETRIES AND PROTON-NEUTRON MIXED STATES
C=======================================================================
C        CONSTRUCTING THE HF HAMILTONIAN MATRIX, WHICH HAS THE FOLLOWING
C        NEUTRON (N),  PROTON (P),  SIMPLEX=+i (U),   AND SIMPLEX=-i (D)
C        STRUCTURE OF THE 4x4 LDBASE BLOCKS:
C=======================================================================
C
C         -------------------------------------------------------------
C         |         SIMPLEX-UP          |         SIMPLEX-DOWN        |
C         |-----------------------------|-----------------------------|
C         |   NEUTRONS   |   PROTONS    |   NEUTRONS   |   PROTONS    |
C         -------------------------------------------------------------
C
C         -------------------------------------------------------------
C         |    NU-NU     |    NU-PU     |    NU-ND     |    NU-PD     |
C         |--------------|--------------|--------------|--------------|
C         |    PU-NU     |    PU-PU     |    PU-ND     |    PU-PD     |
C         |--------------|--------------|--------------|--------------|
C         |    ND-NU     |    ND-PU     |    ND-ND     |    ND-PD     |
C         |--------------|--------------|--------------|--------------|
C         |    PD-NU     |    PD-PU     |    PD-ND     |    PD-PD     |
C         -------------------------------------------------------------
C
C=======================================================================
C
      DO IBRA=1,4*LDBASE
         DO IKET=1,4*LDBASE
C
            IF (IBRA.GE.IKET) THEN
C
                NCOUNT=IBRA+((8*LDBASE-IKET)*(IKET-1))/2
C
                IF (IBRA.LE.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=PNM_PP(IBRA,IKET,0)
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=PNM_PM(IBRA-2*LDBASE,IKET,1)
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.GT.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=PNM_PP(IBRA-2*LDBASE,IKET-2*LDBASE,1)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      IF (LIMPAR.NE.1) THEN
C
          LDMEFI=NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
          CALL DIAMAT(CELMTS,SPESIZ,EWAMIZ,4*LDBASE,4*NDBASE,LDMEFI)
C
      ELSE
C
          LDMEFI=0
C
          EIGMIN=-200.0D0
          EIGMAX=ECUTOF
C
          CALL DIAMAT(CELMTS,SPESIZ,EWAMIZ,4*LDBASE,4*NDBASE,LDMEFI)
C
          IF (LDMEFI.LT.(NUMBSP(0,0)+NUMBSP(1,0)
     *                  +NUMBSP(0,1)+NUMBSP(1,1))) THEN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' NOT ENOUGH SP STATES FOUND'',
     *                                '' IN DIAMIZ'',    1X,19(1H/),/,
     *                     1X,20(1H/),'' LDMEFI='',I4,
     *                                '' SMALLER THAN NUMBSP='',I4,
     *                     1X,20(1H/),'' INCRESE THE CUTOFF ENERGY'',
     *                                '' ECUTOF    '',   1X,19(1H/),/,
     *                                                   1X,19(1H/),/)')
     *
     *        LDMEFI,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
              STOP 'INCREASE ECUTOF IN DIAMIZ'
C
          END IF
C
      END IF
C
C=======================================================================
C
      DO IALLST=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
         PNENER(IALLST)=SPESIZ(IALLST)
      END DO
C
C=======================================================================
C
      DO IALLST=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
         DO IBASE=1,2*LDBASE
            PNMOCC(IBASE,IALLST,0)=EWAMIZ(IBASE         ,IALLST)
            PNMOCC(IBASE,IALLST,1)=EWAMIZ(IBASE+2*LDBASE,IALLST)
         END DO
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS)
C=======================================================================
C
      CALL CPUTIM('DIAMIZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HFBSIG(EFERMI,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                         FERALM,IFERAL,PARNUM,NOPART,
     *                                       ITWOBA,IWRIQU,
     *                         INSIGB,IPSIGB,ISSIGB,IDSIGB,
     *                                       IFIBLB,ISABLB,
     *                         IREQPB,INUQPB,JNUQPB,IF_RPA)
C=======================================================================
      USE PAIDEL
      USE MAT_PP
      USE ALLQUA
      USE SAVQUA
      USE ALLSIG, ONLY:LDMEFG
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,PWAHFB,C_ZERO
      COMPLEX
     *          ABLQUA,BBLQUA
C=======================================================================
      ALLOCATABLE PWAHFB(:,:,:)
      ALLOCATABLE CELMTS(:)
C=======================================================================
      DIMENSION
     *          IDSTAT(0:NDREVE),I_STAT(0:NDREVE)
      DIMENSION
     *          PQUHFB(1:2*NDBASP,0:NDPARI)
      DIMENSION
     *          IALLXX(1:NDSTAT,0:NDREVE)
      DIMENSION
     *          LDQUAP(0:NDPARI),LDOFFS(0:NDPARI)
      DIMENSION
     *          LDHALF(0:NDPARI,0:NDREVE)
      DIMENSION
     *          EORDER(1:2*NDBASE),NORDER(1:2*NDBASE),
     *          NREVER(1:2*NDBASE),NPSTAT(1:2*NDBASE),
     *          NPARIT(1:2*NDBASE)
C
      COMMON
     *       /XBLQUA/ ABLQUA(1:NDBASE,0:NDREVE,0:NDISOS),
     *                BBLQUA(1:NDBASE,0:NDREVE,0:NDISOS)
C=======================================================================
C         ATTENTION: ON 14/02/2020 IN VERSION (2.93B), ARRAYS IN COMMONS
C                    BELOW ACQUIRED  DOUBLED  DIMENSIONS  "2*NDSTAT"  TO
C                    MAKE THEM SUITABLE FOR THE  IMPLEMENTATION  OF  THE
C                    PROTON-NEUTRON MIXING WITH PAIRING.
C=======================================================================
      COMMON
     *       /XEQUIV/ EEQUIV(1:2*NDSTAT,0:NDREVE),
     *                DEQUIV(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PARIQU/ QPPARI(1:2*NDSTAT,0:NDREVE)
C=======================================================================
C         ATTENTION: BUG CORRECTED ON 19/02/2020
C                    BETWEEN VERSIONS (2.64) AND (2.93C), ARRAY "FERMFN"
C                    WAS DIMENSIONNED UP TO  "NDBASE",  WHEREAS  IT  WAS
C                    MEANT TO CONTAIN INFORMATION ON  THE  QUASIPARTICLE
C                    STATES, AND THUS IT SHOULD HAVE  BEEN  DIMENSIONNED
C                    UP TO "NDSTAT". THE BUG WAS CORRECTED ON 19/02/2020
C                    IN VERSION (2.93D), WHEN THE  IMPLEMENTING  OF  THE
C                    PROTON-NEUTRON MIXING IN THE  PAIRING  CHANNEL  WAS
C                    STARTED, WHEREUPON THIS ARRAY  ACQUIRED  A  DOUBLED
C                    DIMENSION "2*NDSTAT". WITH CONSERVED SIGNATURE  AND
C                    SIMPLEX, THE BUG WAS VERY  UNLIKELY  TO  CAUSE  ANY
C                    PROBLEM, HOWEVER FOR CONSERVED SIMPLEX ONLY,  THERE
C                    WAS A RISK OF GOING BEYOND THE ALLOCATED MEMORY.
C=======================================================================
C                    REMARKS  ABOVE  ALSO  PERTAIN  TO  ARRAYS:  E_QUAP,
C                    EQPISO, VQPISO, ESPEQU, AND DELEQU.
C=======================================================================
      COMMON
     *       /QUACNS/ E_QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAISO/ EQPISO(1:2*NDSTAT,0:NDREVE,0:NDISOS),
     *                VQPISO(1:2*NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /EQUISO/ ESPEQU(1:2*NDSTAT,0:NDREVE,0:NDISOS),
     *                DELEQU(1:2*NDSTAT,0:NDREVE,0:NDISOS)
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
      COMMON
     *       /GCTEMP/ TEMP_T
      COMMON
     *       /SENTRO/ ENTRPY(0:NDISOS)
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /PARIND/ INDPAR(1:NDBASE,0:NDPARI)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
      INTERFACE
         SUBROUTINE TWOSIG(IPARIT,CELMTS,EQUHFB,EWAHFB,EFERMI)
            USE hfodd_sizes
            COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
            COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
            REAL, DIMENSION(1:2*NDBASP) :: EQUHFB
            INTEGER :: IPARIT,ICHARG
            REAL :: ECUTOF,EFERMI
         END SUBROUTINE TWOSIG
      END INTERFACE
C=======================================================================
C
      CALL CPUTIM('HFBSIG',1)
C
C=======================================================================
C
      IALLOC=0
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
      IF (.NOT.ALLOCATED(AWAQUA)) THEN
          ALLOCATE (AWAQUA(1:NDBASE,1:NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('AWAQUA','HFBSIG')
      END IF
      IF (.NOT.ALLOCATED(BWAQUA)) THEN
          ALLOCATE (BWAQUA(1:NDBASE,1:NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BWAQUA','HFBSIG')
      END IF
C=======================================================================
C
      IF (IF_RPA.EQ.1.OR.IFTEMP.EQ.1.OR.IWRIQU.NE.-1) THEN
C
          IF (.NOT.ALLOCATED(ASVQUA)) THEN
              ALLOCATE (ASVQUA(1:NDBASE,1:NDSTAT,0:NDREVE,0:NDISOS),
     *                  STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('ASVQUA','HFBSIG')
              ASVQUA(:,:,:,:) = C_ZERO
          END IF
          IF (.NOT.ALLOCATED(BSVQUA)) THEN
              ALLOCATE (BSVQUA(1:NDBASE,1:NDSTAT,0:NDREVE,0:NDISOS),
     *                  STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('BSVQUA','HFBSIG')
              BSVQUA(:,:,:,:) = C_ZERO
          END IF
C
      END IF
C
C=======================================================================
      ALLOCATE (CELMTS(1:(2*NDBASP+1)*NDBASP),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','HFBSIG')
      CELMTS(:) = C_ZERO
      ALLOCATE (PWAHFB(1:2*NDBASP,1:2*NDBASP,0:NDPARI),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('PWAHFB','HFBSIG')
      PWAHFB(:,:,:) = C_ZERO
C=======================================================================
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HFB MATRIX
C         FOR THE CONSERVED-PARITY&SIGNATURE CASE
C=======================================================================
C
      I_STAT(0)=0
      I_STAT(1)=0
C
C=======================================================================
C     SEE COMMENTS ABOUT NDBASP IN THE DIASIQ SUBROUTINE
C=======================================================================
C
      IF (MAX(LDBASP(0),LDBASP(1)).GT.NDBASP) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' PARAMETER NDBASP TOO SMALL'',
     *                            '' IN HFBSIG'',       1X,19(1H/),/,
     *                 1X,20(1H/),'' NDBASP ='',I3,
     *                            '' INCREASE TO  NDBASP ='',I3,
     *                                                  1X,19(1H/),/)')
     *
     *    NDBASP,MAX(LDBASP(0),LDBASP(1))
C
          STOP 'INCREASE NDBASP IN HFBSIG'
C
      END IF
C
C=======================================================================
C         DETERMINING THE HFB MEAN-FIELD EIGENSTATES AND SPECTRUM
C=======================================================================
C      Put this outside the IPARIT loop because inside DIASIQ there is
C      already a parity loop
      IF (IABS(IDSIGB).EQ.1 .OR. IMFHFB.EQ.1 .OR. ITWOBA.EQ.1) THEN
C
          IF (ITWOBA.EQ.1) THEN
              LIMPAR=1
          ELSE
              LIMPAR=0
          END IF
C
          CALL DIASIG(1,ICHARG,LIMPAR,ECUTOF)
C
      END IF
C
C=======================================================================
C     CONSTRUCTING THE HFB MATRIX
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
         LDPARI=LDBASP(IPARIT)
C
         NCOUNT=0
C
         DO IKETPA=1,2*LDPARI
            DO IBRAPA=IKETPA,2*LDPARI
C
               NCOUNT=NCOUNT+1
C
               IF (IBRAPA.LE.LDPARI.AND.IKETPA.LE.LDPARI)
     *            CELMTS(NCOUNT)=BIG_PP(INDPAR(IBRAPA,       IPARIT),
     *                                  INDPAR(IKETPA,       IPARIT),0)
C
               IF (IBRAPA.GT.LDPARI.AND.IKETPA.LE.LDPARI)
     *            CELMTS(NCOUNT)=
     *                    -CONJG(HAMIDE(INDPAR(IBRAPA-LDPARI,IPARIT),
     *                                  INDPAR(IKETPA,       IPARIT),0))
C
               IF (IBRAPA.GT.LDPARI.AND.IKETPA.GT.LDPARI)
     *            CELMTS(NCOUNT)=
     *                    -CONJG(BIG_PP(INDPAR(IBRAPA-LDPARI,IPARIT),
     *                                  INDPAR(IKETPA-LDPARI,IPARIT),1))
C
            END DO
         END DO
C
C=======================================================================
C     SUBTRACTING THE FERMI ENERGY TERM FROM THE MEAN FIELD
C=======================================================================
C
         IF (IFERAL.NE.1) THEN
             EFERAC=EFERMI
         ELSE
             EFERAC=EFERMI-2*FERALM*(PARNUM-NOPART)
         END IF
C
         DO IBRAPA=1,2*LDPARI
C
            IKETPA=IBRAPA
C
            NCOUNT=IBRAPA+((4*LDPARI-IKETPA)*(IKETPA-1))/2
C
            IF (IBRAPA.LE.LDPARI)
     *          CELMTS(NCOUNT)=CELMTS(NCOUNT)-EFERAC
C
            IF (IBRAPA.GT.LDPARI)
     *          CELMTS(NCOUNT)=CELMTS(NCOUNT)+EFERAC
C
         END DO
C
C=======================================================================
C        CALLING THE DIAGONALIZATION ROUTINE
C=======================================================================
C
         IF (ITWOBA.NE.1) THEN
C
             IF (LIMQUA.EQ.1) THEN
C
                 LDQUAP(IPARIT)=0
C
                 EIGMIN=EFERMI-ECUTOF
                 EIGMAX=ECUTOF-EFERMI
C
             ELSE
C
                 LDQUAP(IPARIT)=2*LDPARI
C
             END IF
C
             CALL DIAMAT(CELMTS,PQUHFB(1,IPARIT),PWAHFB(1,1,IPARIT),
     *                             2*LDPARI,2*NDBASP,LDQUAP(IPARIT))
C
         ELSE
C
             CALL TWOSIG(IPARIT,CELMTS,PQUHFB(:,IPARIT),
     *                   PWAHFB(:,:,IPARIT),EFERMI)
C
             LDQUAP(IPARIT)=LDMEFG(IPARIT,0)+LDMEFG(IPARIT,1)
C
         END IF
C
C=======================================================================
C          BELOW WE DEAL WITH A POSSIBLE SITUATION OF AN ODD  NUMBER  OF
C          THE QUASIPARTICLE STATES  FOUND  IN  A  GIVEN  ENERGY  WINDOW
C          (FOR LIMQUA=1). THEN WE DISREGARD  THE  STATE  THAT  HAS  THE
C          LARGEST ABSOLUTE VALUE OF THE QUASIPARTICLE ENERGY.
C=======================================================================
C
         IF (ITWOBA.NE.1) THEN
C
             IF (MOD(LDQUAP(IPARIT),2).EQ.0) THEN
C
                 LDHALF(IPARIT,:)=LDQUAP(IPARIT)/2
                 LDOFFS(IPARIT)=0
C
             ELSE
C
                 LDHALF(IPARIT,:)=(LDQUAP(IPARIT)-1)/2
C
                 IF (ABS(PQUHFB(             1,IPARIT)).LT.
     *               ABS(PQUHFB(LDQUAP(IPARIT),IPARIT))) THEN
                     LDOFFS(IPARIT)=0
                 ELSE
                     LDOFFS(IPARIT)=1
                 END IF
C
             END IF
C
         ELSE
C             For two basis method, LDHALF already stores orbit number
C             after cut off
             LDHALF(:,:)=LDMEFG(:,:)
             LDOFFS(IPARIT)=0
         END IF
C
      END DO
C
C=======================================================================
C         DETERMINING THE ORDERED QUASIPARTICLE SPECTRUM
C=======================================================================
C
      IORDER=0
C
      DO IPARIT=0,NDPARI
C
         LDPARI=LDBASP(IPARIT)
C
         DO IREVER=0,NDREVE
C
            DO IPSTAT=1,LDHALF(IPARIT,IREVER)
C
               IORDER=IORDER+1
               IF (IORDER.GT.2*LDBASE) STOP' IORDER TOO LARGE IN HFBSIG'
               NORDER(IORDER)=IORDER
               NPARIT(IORDER)=IPARIT
               EORDER(IORDER)=(2*IREVER-1)
     *        *PQUHFB(IPSTAT+LDOFFS(IPARIT)+IREVER*LDHALF(IPARIT,0),
     *                                                    IPARIT)
               NPSTAT(IORDER)=IPSTAT+LDOFFS(IPARIT)
               NREVER(IORDER)=IREVER
C
            END DO
C
         END DO
C
      END DO
C
      LDORDE=IORDER
C
      CALL ORDER1(EORDER,NORDER,LDORDE)
C
C=======================================================================
C         LOOP OVER ORDERED QUASIPARTICLE STATES
C=======================================================================
C
      INCORR=0
C
      IDSTAT(0)=0
      IDSTAT(1)=0
C
      DO IALLST=1,LDORDE
C
         IPSTAT=NPSTAT(NORDER(IALLST))
         IREVER=NREVER(NORDER(IALLST))
         IPARIT=NPARIT(NORDER(IALLST))
C
         LDPARI=LDBASP(IPARIT)
C
C=======================================================================
C        CALCULATING THE NORMS OF THE "FIRST" COMPONENTS
C=======================================================================
C
         VORDER=0.0D0
C
         DO IBASE=1,LDPARI
C
            VORDER=VORDER+ABS(PWAHFB( IBASE+IREVER*LDPARI,
     *                IPSTAT+IREVER*LDHALF(IPARIT,0),IPARIT))**2
C
         END DO
C
C=======================================================================
C        CHECKING VALUES OF VORDER - JUST IN CASE. VALUES WHICH ARE OUT
C        OF BOUNDS UP TO A SMALL MACHINE-PRECISION NUMBER "EMACHI"  ARE
C        REPLACED BY THE VALUES AT BOUNDS.
C=======================================================================
C
         EMACHI=1.0D-10
C
         IF (VORDER.GT.1+EMACHI.OR.VORDER.LT. -EMACHI) THEN
C
             WRITE(NFIPRI,'(/,1X,20(1H/),
     *             '' ERROR IN NORMALIZATION OF'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' QUASIPARTICLES IN HFBSIG.'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' IF THIS IS A ROUND-OFF PROBLEM'', 4X,20(1H/),/,
     *             1X,20(1H/),
     *             '' YOU MAY CHANGE VALUE OF EMACHI.'',3X,20(1H/),/,
     *             1X,20(1H/),'' IPSTAT='',I5,'' IREVER='',I2,
     *                                           12X,20(1H/),/,
     *             1X,20(1H/),'' VORDER='',D25.18,
     *                                            2X,20(1H/),/)')
     *
     *             IPSTAT,IREVER,VORDER
C
             STOP 'ERROR IN NORMALIZATION OF QUASIPARTICLES IN HFBSIG'
C
         END IF
C
         IF (VORDER.GT.1) VORDER=1
         IF (VORDER.LT.0) VORDER=0
C
C=======================================================================
C
         I_STAT(IREVER)=I_STAT(IREVER)+1
         E_QUAP(I_STAT(IREVER),IREVER)=EORDER(IALLST)
C
C=======================================================================
C        CALCULATING THE EQUIVALENT SPECTRUM AND CUTTING-OFF THE STATES
C        WITH HIGH EQUIVALENT ENERGIES
C=======================================================================
C
         HORDER=EORDER(IALLST)*(1-2*VORDER)
C
                          CORDER=HORDER+EFERMI
         IF (LAMCUT.EQ.1) CORDER=HORDER
C
         IF (CORDER.GT.ECUTOF.AND.ITWOBA.NE.1) GO TO 1
C
         IDSTAT(IREVER)=IDSTAT(IREVER)+1
C
         IF (IDSTAT(IREVER).GT.NDSTAT) THEN
C
             INCORR=1
             GO TO 1
C
         END IF
C
C=======================================================================
C        SEE COMMENTS IN THE HFBSIM SUBROUTINE ABOUT THE EQUIVALENT
C        SPECTRUM
C=======================================================================
C
         DEQUIV(IDSTAT(IREVER),IREVER)=
     *                            SQRT(ABS(EORDER(IALLST)**2-HORDER**2))
         DELEQU(IDSTAT(IREVER),IREVER,ICHARG)=
     *                            SQRT(ABS(EORDER(IALLST)**2-HORDER**2))
C
         EEQUIV(IDSTAT(IREVER),IREVER)=HORDER+EFERMI
         ESPEQU(IDSTAT(IREVER),IREVER,ICHARG)=HORDER+EFERMI
C
C=======================================================================
C        DEFINING THE QUASIPARTICLE ENERGIES AND OCCUPATIONS
C=======================================================================
C
         ENQUAP(IDSTAT(IREVER),IREVER)       =EORDER(IALLST)
         EQPISO(IDSTAT(IREVER),IREVER,ICHARG)=EORDER(IALLST)
C
         V2QUAP(IDSTAT(IREVER),IREVER)=VORDER
         VQPISO(IDSTAT(IREVER),IREVER,ICHARG)=VORDER
C
         QPPARI(IDSTAT(IREVER),IREVER)=1-2*IPARIT
C
C=======================================================================
C        SEE COMMENTS IN THE HFBSIM SUBROUTINE ABOUT THE BOGOLIUBOV
C        MATRICES
C=======================================================================
C
         JPARIT=1-IPARIT
         KDPARI=LDBASP(JPARIT)
C
         IF (IREVER.EQ.0) THEN
C
             DO IPBASE=1,LDPARI
C
                BWAQUA(INDPAR(IPBASE,IPARIT),IDSTAT(0),0)=
     *                       PWAHFB(IPBASE       ,IPSTAT,IPARIT)
                AWAQUA(INDPAR(IPBASE,IPARIT),IDSTAT(0),1)=
     *                       PWAHFB(IPBASE+LDPARI,IPSTAT,IPARIT)
C
             END DO
C
             DO IPBASE=1,KDPARI
C
                BWAQUA(INDPAR(IPBASE,JPARIT),IDSTAT(0),0)=C_ZERO
                AWAQUA(INDPAR(IPBASE,JPARIT),IDSTAT(0),1)=C_ZERO
C
             END DO
C
             IALLXX(IDSTAT(0),0)=IALLST
C
         ELSE
C
             DO IPBASE=1,LDPARI
C
                BWAQUA(INDPAR(IPBASE,IPARIT),IDSTAT(1),1)=
     *           CONJG(PWAHFB(IPBASE+LDPARI,IPSTAT+LDHALF(IPARIT,0),
     *                                                    IPARIT))
                AWAQUA(INDPAR(IPBASE,IPARIT),IDSTAT(1),0)=
     *           CONJG(PWAHFB(IPBASE       ,IPSTAT+LDHALF(IPARIT,0),
     *                                                    IPARIT))
C
             END DO
C
             DO IPBASE=1,KDPARI
C
                BWAQUA(INDPAR(IPBASE,JPARIT),IDSTAT(1),1)=C_ZERO
                AWAQUA(INDPAR(IPBASE,JPARIT),IDSTAT(1),0)=C_ZERO
C
             END DO
C
             IALLXX(IDSTAT(1),1)=IALLST
C
         END IF
C
C=======================================================================
C        SEE COMMENTS IN THE HFBSIM SUBROUTINE ABOUT THE BOGOLIUBOV
C        MATRICES
C=======================================================================
C
         IF (IF_RPA.EQ.1.OR.IFTEMP.EQ.1) THEN
C
             IF (IREVER.EQ.0) THEN
C
                 DO IPBASE=1,LDPARI
C
                    BSVQUA(INDPAR(IPBASE,IPARIT),IDSTAT(0),0,ICHARG)=
     *                           PWAHFB(IPBASE       ,IPSTAT,IPARIT)
                    ASVQUA(INDPAR(IPBASE,IPARIT),IDSTAT(0),1,ICHARG)=
     *                           PWAHFB(IPBASE+LDPARI,IPSTAT,IPARIT)
C
                 END DO
C
                 DO IPBASE=1,KDPARI
C
                    BSVQUA(INDPAR(IPBASE,JPARIT),IDSTAT(0),0,ICHARG)
     *             =C_ZERO
                    ASVQUA(INDPAR(IPBASE,JPARIT),IDSTAT(0),1,ICHARG)
     *             =C_ZERO
C
                 END DO
C
             ELSE
C
                 DO IPBASE=1,LDPARI
C
                    BSVQUA(INDPAR(IPBASE,IPARIT),IDSTAT(1),1, ICHARG)=
     *        CONJG(PWAHFB(IPBASE+LDPARI,IPSTAT+LDHALF(IPARIT,0),
     *                                                        IPARIT))
                    ASVQUA(INDPAR(IPBASE,IPARIT),IDSTAT(1),0, ICHARG)=
     *        CONJG(PWAHFB(IPBASE       ,IPSTAT+LDHALF(IPARIT,0),
     *                                                        IPARIT))
C
                 END DO
C
                 DO IPBASE=1,KDPARI
C
                    BSVQUA(INDPAR(IPBASE,JPARIT),IDSTAT(1),1,ICHARG)
     *             =C_ZERO
                    ASVQUA(INDPAR(IPBASE,JPARIT),IDSTAT(1),0,ICHARG)
     *             =C_ZERO
C
                 END DO
C
             END IF
C
         END IF
C
C=======================================================================
C
    1 CONTINUE
C
      END DO
C
C=======================================================================
C         DEFINING NUMBERS OF QUASIPARTICLES KEPT AFTER THE CUT-OFF
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         NUMBQP(IREVER,ICHARG)=IDSTAT(IREVER)
C
      END DO
C
C=======================================================================
C         STOP IN CASE OF AN INCORRECT PHASE SPACE
C=======================================================================
C
      IF (INCORR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,                             1X,20(1H/),
     *              '' TOO LARGE PHASE SPACE IN HFBSIG NO.1'',
     *                                                   1X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' ICHARG='',I2,3X,'' NDSTAT='',I4, 13X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' INCREASE NDSTAT UP TO NUMBQP OR MORE'',
     *                                                   1X,20(1H/),/)')
     *
     *    ICHARG,NDSTAT,(IREVER,NUMBQP(IREVER,ICHARG),IREVER=0,NDREVE)
C
          STOP ' TOO LARGE PHASE SPACE IN HFBSIG NO.1'
C
      END IF
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C=====================================================================
C          CALCULATION OF ENTROPY AT FINITE TEMPERATURE TEMP_T
C=====================================================================
C
      ENTRPY(ICHARG)=0.0D0
      EPSILO=1.0D-13
C
      IF (IFTEMP.EQ.1) THEN
C
c          IF(ITWOBA.EQ.1)STOP 'IFTEMP=1 and ITWOBA=1 in hfbsig '
          DO ISTATE=1,LDHALF(0,0)+LDHALF(1,0)
C
             FERDIR=0.5D0*(1.0D0-TANH(E_QUAP(ISTATE,0)/TEMP_T/2.0D0))
             FERMFN(ISTATE,ICHARG)=FERDIR
C
             IF (ABS(FERDIR).GT.EPSILO.AND.(1.0D0-FERDIR).GT.EPSILO)
     *       THEN
                 ENTRPY(ICHARG)=ENTRPY(ICHARG)-FERDIR*LOG(FERDIR)-
     *                           (1.0D0-FERDIR)*LOG(1.0D0-FERDIR)
             END IF
C
          END DO
C
C=======================================================================
C          BUG VERSION 2.49T: SEE COMMENTS IN SUBROUTINE HFBSIM
C=======================================================================
C
          ENTRPY(ICHARG)=2.0D0*ENTRPY(ICHARG)
C
      END IF
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C=======================================================================
C         HERE QUASIPARTICLE STATES ARE BLOCKED
C=======================================================================
C
      IREQPB=0
      INUQPB=0
      JNUQPB=0
C
      ABLQUA(:,:,ICHARG)=C_ZERO
      BBLQUA(:,:,ICHARG)=C_ZERO
C
      INCORR=0
C
      IF (IABS(IDSIGB).EQ.1) THEN
C
          CALL BLOSIG(ICHARG,INSIGB,IPSIGB,ISSIGB,IDSIGB,IREQPB,INUQPB,
     *                                                   IFIBLB,ISABLB)
C
          IPSTAT=NPSTAT(NORDER(IALLXX(INUQPB,IREQPB)))
          IREVER=NREVER(NORDER(IALLXX(INUQPB,IREQPB)))
          IPARIT=NPARIT(NORDER(IALLXX(INUQPB,IREQPB)))
C
          IF (IREVER.NE.IREQPB) STOP ' INCONSISTENT IREVER IN HFBSIG'
C
          LDPARI=LDBASP(IPARIT)
C SEE COMMENTS IN HFBSIM
          IF (ITWOBA.NE.1) THEN
              KDPARI=LDPARI
          ELSE
              KDPARI=LDHALF(IPARIT,0)
          END IF
C
          IF (IREQPB.EQ.0) THEN
C
              IDSTAT(1)=IDSTAT(1)+1
C
              IF (IDSTAT(1).GT.NDSTAT) THEN
C
                  INCORR=1
                  GO TO 2
C
              END IF
C
C=======================================================================
C         HERE THE BLOCKED QUASIPARTICLE STATE IS  ZEROED  AND  INVERTED
C         QUASIPARTICLE STATE IS ADDED TO THE OPPOSITE SIMPLEX
C=======================================================================
C
              DO IPBASE=1,LDPARI
C
                 BWAQUA(INDPAR(IPBASE,IPARIT),INUQPB,0)=C_ZERO
                 AWAQUA(INDPAR(IPBASE,IPARIT),INUQPB,1)=C_ZERO
C
                 BWAQUA(INDPAR(IPBASE,IPARIT),IDSTAT(1),1)=
     *                        CONJG(PWAHFB(IPBASE+LDPARI,IPSTAT,IPARIT))
                 AWAQUA(INDPAR(IPBASE,IPARIT),IDSTAT(1),0)=
     *                        CONJG(PWAHFB(IPBASE       ,IPSTAT,IPARIT))
C
                 BBLQUA(INDPAR(IPBASE,IPARIT),1,ICHARG)=
     *                        CONJG(PWAHFB(IPBASE+LDPARI,IPSTAT,IPARIT))
                 ABLQUA(INDPAR(IPBASE,IPARIT),0,ICHARG)=
     *                        CONJG(PWAHFB(IPBASE       ,IPSTAT,IPARIT))
C
              END DO
C
              DEQUIV(IDSTAT(1),1)=      DEQUIV(INUQPB,0)
              EEQUIV(IDSTAT(1),1)=      EEQUIV(INUQPB,0)
              ENQUAP(IDSTAT(1),1)=      ENQUAP(INUQPB,0)
              V2QUAP(IDSTAT(1),1)=1.0D0-V2QUAP(INUQPB,0)
              QPPARI(IDSTAT(1),1)=      QPPARI(INUQPB,0)
C
              JNUQPB=IDSTAT(1)
C
          ELSE
C
              IDSTAT(0)=IDSTAT(0)+1
C
              IF (IDSTAT(0).GT.NDSTAT) THEN
C
                  INCORR=1
                  GO TO 2
C
              END IF
C
              DO IPBASE=1,LDPARI
C
                 BWAQUA(INDPAR(IPBASE,IPARIT),INUQPB,1)=C_ZERO
                 AWAQUA(INDPAR(IPBASE,IPARIT),INUQPB,0)=C_ZERO
C
                 BWAQUA(INDPAR(IPBASE,IPARIT),IDSTAT(0),0)=
     *                        PWAHFB(IPBASE       ,IPSTAT+KDPARI,IPARIT)
                 AWAQUA(INDPAR(IPBASE,IPARIT),IDSTAT(0),1)=
     *                        PWAHFB(IPBASE+LDPARI,IPSTAT+KDPARI,IPARIT)
C
                 BBLQUA(INDPAR(IPBASE,IPARIT),0,ICHARG)=
     *                        PWAHFB(IPBASE       ,IPSTAT+KDPARI,IPARIT)
                 ABLQUA(INDPAR(IPBASE,IPARIT),1,ICHARG)=
     *                        PWAHFB(IPBASE+LDPARI,IPSTAT+KDPARI,IPARIT)
C
              END DO
C
              DEQUIV(IDSTAT(0),0)=      DEQUIV(INUQPB,1)
              EEQUIV(IDSTAT(0),0)=      EEQUIV(INUQPB,1)
              ENQUAP(IDSTAT(0),0)=      ENQUAP(INUQPB,1)
              V2QUAP(IDSTAT(0),0)=1.0D0-V2QUAP(INUQPB,1)
              QPPARI(IDSTAT(0),0)=      QPPARI(INUQPB,1)
C
              JNUQPB=IDSTAT(0)
C
          END IF
C
C=======================================================================
C
    2     CONTINUE
C
C=======================================================================
C
      END IF
C
C=======================================================================
C         RE-DEFINING NUMBERS OF QUASIPARTICLES KEPT AFTER THE BLOCKING
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         NUMBQP(IREVER,ICHARG)=IDSTAT(IREVER)
C
      END DO
C
C=======================================================================
C         STOP IN CASE OF AN INCORRECT PHASE SPACE
C=======================================================================
C
      IF (INCORR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,                             1X,20(1H/),
     *              '' TOO LARGE PHASE SPACE IN HFBSIG NO.2'',
     *                                                   1X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' ICHARG='',I2,3X,'' NDSTAT='',I4, 13X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' INCREASE NDSTAT UP TO NUMBQP OR MORE'',
     *                                                   1X,20(1H/),/)')
     *
     *    ICHARG,NDSTAT,(IREVER,NUMBQP(IREVER,ICHARG),IREVER=0,NDREVE)
C
          STOP ' TOO LARGE PHASE SPACE IN HFBSIG NO.2'
C
      END IF
C
C=======================================================================
C        SAVING THE ARRAYS OF THE BOGOLIUBOV TRANSFORMATION FOR
C        NEUTRONS AND PROTONS FOR USE IN THE ROUTINE "RECQUA".
C        ATTENTION: THIS OVERWRITES PREVIOUS SAVING  OF  THESE
C                   ARRAYS, SO SWITCHES "IF_RPA"  OR  "IFTEMP"
C                   SHOULD  NOT  BE  ACTIVATED  SIMULTANEOUSLY
C                   WITH SWITCH "IWRIQU".
C=======================================================================
C
      IF (IWRIQU.NE.-1) THEN
C
          ASVQUA(:,:,:,ICHARG)=AWAQUA(:,:,:)
          BSVQUA(:,:,:,ICHARG)=BWAQUA(:,:,:)
C
      END IF
C
C=======================================================================
      DEALLOCATE (CELMTS,PWAHFB)
C=======================================================================
C
      CALL CPUTIM('HFBSIG',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HFBSIM(EFERMI,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                         FERALM,IFERAL,PARNUM,NOPART,
     *                                       ITWOBA,IWRIQU,
     *                                INSIMB,IRSIMB,IDSIMB,
     *                                       IFIBLB,ISABLB,
     *                         IREQPB,INUQPB,JNUQPB,IF_RPA)
C=======================================================================
      USE PAIDEL
      USE MAT_PP
      USE ALLQUA
      USE SAVQUA
      USE ALLSIM, ONLY:LDMEFM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,EWAHFB,C_ZERO
      COMPLEX
     *          ABLQUA,BBLQUA
C=======================================================================
      ALLOCATABLE EWAHFB(:,:)
C=======================================================================
      DIMENSION
     *          IDSTAT(0:NDREVE),I_STAT(0:NDREVE)
      DIMENSION
     *          EQUHFB(1:2*NDBASE)
      DIMENSION
     *          IALLXX(1:NDSTAT,0:NDREVE)
      DIMENSION
     *          LDHALF(0:NDREVE)
C=======================================================================
      ALLOCATABLE CELMTS(:)
C=======================================================================
      DIMENSION
     *          EORDER(1:2*NDBASE),NORDER(1:2*NDBASE),
     *          NREVER(1:2*NDBASE),NSTATE(1:2*NDBASE)
C
      COMMON
     *       /XBLQUA/ ABLQUA(1:NDBASE,0:NDREVE,0:NDISOS),
     *                BBLQUA(1:NDBASE,0:NDREVE,0:NDISOS)
      COMMON
     *       /XEQUIV/ EEQUIV(1:2*NDSTAT,0:NDREVE),
     *                DEQUIV(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PARIQU/ QPPARI(1:2*NDSTAT,0:NDREVE)
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /QUACNS/ E_QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAISO/ EQPISO(1:2*NDSTAT,0:NDREVE,0:NDISOS),
     *                VQPISO(1:2*NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /EQUISO/ ESPEQU(1:2*NDSTAT,0:NDREVE,0:NDISOS),
     *                DELEQU(1:2*NDSTAT,0:NDREVE,0:NDISOS)
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
      COMMON
     *       /GCTEMP/ TEMP_T
      COMMON
     *       /SENTRO/ ENTRPY(0:NDISOS)
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /PARBAS/ IBAPAR(1:NDBASE,1:NDTWCE)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
      INTERFACE
         SUBROUTINE TWOSIM(CELMTS,EQUHFB,EWAHFB,EFERMI)
            USE hfodd_sizes
            COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
            COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
            REAL, DIMENSION(1:2*NDBASE) :: EQUHFB
            INTEGER :: ICHARG
            REAL :: ECUTOF,EFERMI
         END SUBROUTINE TWOSIM
      END INTERFACE
C=======================================================================
C
      CALL CPUTIM('HFBSIM',1)
C
C=======================================================================
C
      IALLOC=0
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
      IF (.NOT.ALLOCATED(AWAQUA)) THEN
          ALLOCATE (AWAQUA(1:NDBASE,1:NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('AWAQUA','HFBSIM')
      END IF
      IF (.NOT.ALLOCATED(BWAQUA)) THEN
          ALLOCATE (BWAQUA(1:NDBASE,1:NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BWAQUA','HFBSIM')
      END IF
C=======================================================================
C
      IF (IF_RPA.EQ.1.OR.IFTEMP.EQ.1.OR.IWRIQU.NE.-1) THEN
C
          IF (.NOT.ALLOCATED(ASVQUA)) THEN
              ALLOCATE (ASVQUA(1:NDBASE,1:NDSTAT,0:NDREVE,0:NDISOS),
     *                  STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('ASVQUA','HFBSIM')
              ASVQUA(:,:,:,:) = CMPLX(0.0D0,0.0D0)
          END IF
          IF (.NOT.ALLOCATED(BSVQUA)) THEN
              ALLOCATE (BSVQUA(1:NDBASE,1:NDSTAT,0:NDREVE,0:NDISOS),
     *                  STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('BSVQUA','HFBSIM')
              BSVQUA(:,:,:,:) = CMPLX(0.0D0,0.0D0)
          END IF
C
      END IF
C
C=======================================================================
      ALLOCATE (CELMTS(1:(2*NDBASE+1)*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','HFBSIM')
      CELMTS(:)=C_ZERO
      ALLOCATE (EWAHFB(1:2*NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAHFB','HFBSIM')
      EWAHFB(:,:)=C_ZERO
C=======================================================================
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HFB MATRIX
C         FOR THE CONSERVED-SIMPLEX CASE
C=======================================================================
C
      I_STAT(0)=0
      I_STAT(1)=0
C
C=======================================================================
C         DETERMINING THE HFB MEAN-FIELD EIGENSTATES AND SPECTRUM
C=======================================================================
C
      IF (IABS(IDSIMB).EQ.1 .OR. IMFHFB.EQ.1 .OR. ITWOBA.EQ.1) THEN
C
          IF (ITWOBA.EQ.1) THEN
              LIMPAR=1
          ELSE
              LIMPAR=0
          END IF
          CALL DIASIM(1,ICHARG,LIMPAR,ECUTOF)
C
      END IF
C
C=======================================================================
C         CONSTRUCTING THE HFB MATRIX
C=======================================================================
C
      DO IBRA=1,2*LDBASE
         DO IKET=1,2*LDBASE
C
            IF (IBRA.GE.IKET) THEN
C
                NCOUNT=IBRA+((4*LDBASE-IKET)*(IKET-1))/2
C
                IF (IBRA.LE.LDBASE.AND.IKET.LE.LDBASE)
     *
     *              CELMTS(NCOUNT)=BIG_PP(IBRA,IKET,0)
C
                IF (IBRA.GT.LDBASE.AND.IKET.LE.LDBASE)
     *
     *              CELMTS(NCOUNT)=
     *                      -CONJG(HAMIDE(IBRA-LDBASE,IKET,0))
C
                IF (IBRA.GT.LDBASE.AND.IKET.GT.LDBASE)
     *
     *              CELMTS(NCOUNT)=
     *                      -CONJG(BIG_PP(IBRA-LDBASE,IKET-LDBASE,1))
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         SUBTRACTING THE FERMI ENERGY TERM FROM THE MEAN FIELD
C=======================================================================
C
      DO IBRA=1,2*LDBASE
C
         IKET=IBRA
C
         NCOUNT=IBRA+((4*LDBASE-IKET)*(IKET-1))/2
C
         IF (IBRA.LE.LDBASE)
     *
     *       CELMTS(NCOUNT)=CELMTS(NCOUNT)-EFERMI
C
         IF (IBRA.GT.LDBASE)
     *
     *       CELMTS(NCOUNT)=CELMTS(NCOUNT)+EFERMI
C
      END DO
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE.
C=======================================================================
C
      IF (ITWOBA.NE.1) THEN
C
          IF (LIMQUA.EQ.1) THEN
C
              LDQUAP=0
C
              EIGMIN=EFERMI-ECUTOF
              EIGMAX=ECUTOF-EFERMI
C
          ELSE
C
              LDQUAP=2*LDBASE
C
          END IF
C
          CALL DIAMAT(CELMTS,EQUHFB,EWAHFB,2*LDBASE,2*NDBASE,LDQUAP)
C
      ELSE
C
         CALL TWOSIM(CELMTS,EQUHFB,EWAHFB,EFERMI)
C
         LDQUAP=LDMEFM(0)+LDMEFM(1)
C
      END IF
C
C=======================================================================
C          BELOW WE DEAL WITH A POSSIBLE SITUATION OF AN ODD  NUMBER  OF
C          THE QUASIPARTICLE STATES  FOUND  IN  A  GIVEN  ENERGY  WINDOW
C          (FOR LIMQUA=1). THEN WE DISREGARD  THE  STATE  THAT  HAS  THE
C          LARGEST ABSOLUTE VALUE OF THE QUASIPARTICLE ENERGY.
C=======================================================================
C
      IF (ITWOBA.NE.1) THEN
C
          IF (MOD(LDQUAP,2).EQ.0) THEN
C
              LDHALF(:)=LDQUAP/2
              LDOFFS=0
C
          ELSE
C
              LDHALF(:)=(LDQUAP-1)/2
C
              IF (ABS(EQUHFB(1)).LT.ABS(EQUHFB(LDQUAP))) THEN
                  LDOFFS=0
              ELSE
                  LDOFFS=1
              END IF
C
          END IF
C
      ELSE
C         In the two basis method, LDHALF can be different in two
C         simplex blocks
         LDHALF(:)=LDMEFM(:)
         LDOFFS=0
      END IF
C
C=======================================================================
C         DETERMINING THE ORDERED QUASIPARTICLE SPECTRUM
C=======================================================================
C
      IORDER=0
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,LDHALF(IREVER)
C
            IORDER=IORDER+1
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=(2*IREVER-1)
     *                    *EQUHFB(ISTATE+LDOFFS+IREVER*LDHALF(0))
            NSTATE(IORDER)=ISTATE+LDOFFS
            NREVER(IORDER)=IREVER
C
         END DO
C
      END DO
C
      LDORDE=IORDER
C
      CALL ORDER1(EORDER,NORDER,LDORDE)
C
C=======================================================================
C         LOOP OVER ORDERED QUASIPARTICLE STATES
C=======================================================================
C
      INCORR=0
C
      IDSTAT(0)=0
      IDSTAT(1)=0
C
      DO IALLST=1,LDORDE
C
         ISTATE=NSTATE(NORDER(IALLST))
         IREVER=NREVER(NORDER(IALLST))
C
C=======================================================================
C        CALCULATING THE NORMS AND PARITIES OF THE "FIRST" COMPONENTS
C=======================================================================
C
         VORDER=0.0D0
         PORDER=0.0D0
C
         DO IBASE=1,LDBASE
C
            VORDER=VORDER+ABS(EWAHFB( IBASE+IREVER*LDBASE,
     *                               ISTATE+IREVER*LDHALF(0)))**2
            PORDER=PORDER+ABS(EWAHFB( IBASE+IREVER*LDBASE,
     *                               ISTATE+IREVER*LDHALF(0)))**2
     *                              *(1-2*IBAPAR(IBASE,1))
C
         END DO
C
C=======================================================================
C        CHECKING VALUES OF VORDER - JUST IN CASE. VALUES WHICH ARE OUT
C        OF BOUNDS UP TO A SMALL MACHINE-PRECISION NUMBER "EMACHI"  ARE
C        REPLACED BY THE VALUES AT BOUNDS.
C=======================================================================
C
         EMACHI=1.0D-10
C
         IF (VORDER.GT.1+EMACHI.OR.VORDER.LT. -EMACHI) THEN
C
             WRITE(NFIPRI,'(/,1X,20(1H/),
     *             '' ERROR IN NORMALIZATION OF'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' QUASIPARTICLES IN HFBSIM.'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' IF THIS IS A ROUND-OFF PROBLEM'', 4X,20(1H/),/,
     *             1X,20(1H/),
     *             '' YOU MAY CHANGE VALUE OF EMACHI.'',3X,20(1H/),/,
     *             1X,20(1H/),'' ISTATE='',I5,'' IREVER='',I2,
     *                                           12X,20(1H/),/,
     *             1X,20(1H/),'' VORDER='',D25.18,
     *                                            2X,20(1H/),/)')
     *
     *             ISTATE,IREVER,VORDER
C
             STOP 'ERROR IN NORMALIZATION OF QUASIPARTICLES IN HFBSIM'
C
         END IF
C
         IF (VORDER.GT.1) VORDER=1
         IF (VORDER.LT.0) VORDER=0
C
C=======================================================================
C
         I_STAT(IREVER)=I_STAT(IREVER)+1
         E_QUAP(I_STAT(IREVER),IREVER)=EORDER(IALLST)
C
C=======================================================================
C        CALCULATING THE EQUIVALENT SPECTRUM AND CUTTING-OFF THE STATES
C        WITH HIGH EQUIVALENT ENERGIES
C=======================================================================
C
         HORDER=EORDER(IALLST)*(1-2*VORDER)
C
                          CORDER=HORDER+EFERMI
         IF (LAMCUT.EQ.1) CORDER=HORDER
C
         IF (CORDER.GT.ECUTOF.AND.ITWOBA.NE.1) GO TO 1
C
         IDSTAT(IREVER)=IDSTAT(IREVER)+1
C
         IF (IDSTAT(IREVER).GT.NDSTAT) THEN
C
             INCORR=1
             GO TO 1
C
         END IF
C
C=======================================================================
C        EEQUIV CONTAINS THE EQUIVALENT  SINGLE-PARTICLE  ENERGY
C        DEQUIV CONTAINS THE EQUIVALENT  SINGLE-PARTICLE  PAIRING  GAP.
C=======================================================================
C        THE ABSOLUTE VALUE BELOW IS ADDED ONLY AS A  SECURITY  MEASURE
C        AGAINST VERY SMALL NEGATIVE NUMBERS UNDER THE SQUARE ROOT.  IN
C        PRINCIPLE, THESE NUMBERS HAVE TO BE POSITIVE PROVIDED   VALUES
C        OF VORDER ARE FROM ZERO TO ONE, AS THAY SHOULD BE, SEE ABOVE.
C=======================================================================
C        ATTENTION:   THE QUASIPARTICLE ENERGIES BELOW CAN BE NEGATIVE.
C                     THIS BRINGS THE CORRESPONDING  EQUIVALENT  ENERGY
C                     TO THE OTHER SIDE OF THE FERMI ENERGY. A REACTION
C                     OF THE EQUIVALENT-SPECTRUM METHOD TO  A  PRESENCE
C                     OF SUCH A STATE IS UNKNOWN AS YET.
C=======================================================================
C
         DEQUIV(IDSTAT(IREVER),IREVER)=
     *                            SQRT(ABS(EORDER(IALLST)**2-HORDER**2))
         DELEQU(IDSTAT(IREVER),IREVER,ICHARG)=
     *                            SQRT(ABS(EORDER(IALLST)**2-HORDER**2))
C
         EEQUIV(IDSTAT(IREVER),IREVER)=HORDER+EFERMI
         ESPEQU(IDSTAT(IREVER),IREVER,ICHARG)=HORDER+EFERMI
C
C=======================================================================
C        DEFINING THE QUASIPARTICLE ENERGIES AND OCCUPATIONS
C=======================================================================
C
         ENQUAP(IDSTAT(IREVER),IREVER)       =EORDER(IALLST)
         EQPISO(IDSTAT(IREVER),IREVER,ICHARG)=EORDER(IALLST)
C
         V2QUAP(IDSTAT(IREVER),IREVER)=VORDER
         VQPISO(IDSTAT(IREVER),IREVER,ICHARG)=VORDER
C
         IF (VORDER.GT.0) THEN
C
             QPPARI(IDSTAT(IREVER),IREVER)=PORDER/VORDER
         ELSE
             QPPARI(IDSTAT(IREVER),IREVER)=1.0D+10
C
         END IF
C
C
C=======================================================================
C        CONSTRUCTING THE HFB A* AND B* MATRICES. THE THIRD  INDICES  OF
C        THESE MATRICES CORRESPOND TO "IREVER" (TO THE TIME-REVERSAL  OF
C        THE BASIS STATE). THEREFORE:
C        FOR IREVER=0 ONE STORES MATRICES A+* AND B+*, AND
C        FOR IREVER=1 ONE STORES MATRICES A-* AND B-*, SEE NOTES 7-41.
C
C        ON THE OTHER HAND, THE SECOND  INDICES  OF  MATRICES  A* AND B*
C        CORRESPOND TO THE QUASIPARTICLE STATES, AND HERE THE USE OF THE
C        NAME "IREVER" IS IN PRINCIPLE MISLEADING: THESE INDICES  DENOTE
C        SIMPLY THE FIRST OR THE SECOND SET OF THE QUASIPARTICLE STATES.
C=======================================================================
C
         IF (IREVER.EQ.0) THEN
C
             DO IBASE=1,LDBASE
C
                BWAQUA(IBASE,IDSTAT(0),0)=
     *                               EWAHFB(IBASE       ,ISTATE       )
                AWAQUA(IBASE,IDSTAT(0),1)=
     *                               EWAHFB(IBASE+LDBASE,ISTATE       )
C
             END DO
C
             IALLXX(IDSTAT(0),0)=IALLST
C
         ELSE
C
             DO IBASE=1,LDBASE
C
                BWAQUA(IBASE,IDSTAT(1),1)=
     *    CONJG(EWAHFB(IBASE+LDBASE,ISTATE+LDHALF(0)))
                AWAQUA(IBASE,IDSTAT(1),0)=
     *    CONJG(EWAHFB(IBASE       ,ISTATE+LDHALF(0)))
C
             END DO
C
             IALLXX(IDSTAT(1),1)=IALLST
C
         END IF
C
C=======================================================================
C        SAVING THE MATRICES OF THE BOGOLIUBOV TRANSFORMATION FOR
C        NEUTRONS AND PROTONS FOR USE IN THE ROUTINE QMULCM  THAT
C        IS PLACED AFTER THE NEUTRON / PROTON LOOP AND RE-ADJUSTS
C        THE CONSTRAINTS BASED ON THE RPA MATRIX
C=======================================================================
C
         IF (IF_RPA.EQ.1.OR.IFTEMP.EQ.1) THEN
C
             IF (IREVER.EQ.0) THEN
C
                 DO IBASE=1,LDBASE
C
                    BSVQUA(IBASE,IDSTAT(0),0,ICHARG)=
     *                                   EWAHFB(IBASE       ,ISTATE)
                    ASVQUA(IBASE,IDSTAT(0),1,ICHARG)=
     *                                   EWAHFB(IBASE+LDBASE,ISTATE)
C
                 END DO
C
             ELSE
C
                 DO IBASE=1,LDBASE
C
                    BSVQUA(IBASE,IDSTAT(1),1,ICHARG)=
     *                    CONJG(EWAHFB(IBASE+LDBASE,ISTATE+LDHALF(0)))
                    ASVQUA(IBASE,IDSTAT(1),0,ICHARG)=
     *                    CONJG(EWAHFB(IBASE       ,ISTATE+LDHALF(0)))
C
                 END DO
C
             END IF
C
         END IF
C
C=======================================================================
C
    1    CONTINUE
C
      END DO
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C=====================================================================
C          CALCULATION OF ENTROPY AT FINITE TEMPERATURE TEMP_T
C=====================================================================
C
      ENTRPY(ICHARG)=0.0D0
      EPSILO=1.0D-13
C
      IF (IFTEMP.EQ.1) THEN
C
C          IF(ITWOBA.EQ.1)STOP 'IFTEMP=1 and ITWOBA=1 in hfbsim '
          DO ISTATE=1,LDHALF(0)
C
             FERDIR=0.5D0*(1.0D0-TANH(E_QUAP(ISTATE,0)/TEMP_T/2.0D0))
             FERMFN(ISTATE,ICHARG)=FERDIR
C
             IF (ABS(FERDIR).GT.EPSILO.AND.(1.0D0-FERDIR).GT.EPSILO)
     *       THEN
                 ENTRPY(ICHARG)=ENTRPY(ICHARG)-FERDIR*LOG(FERDIR)-
     *                           (1.0D0-FERDIR)*LOG(1.0D0-FERDIR)
             END IF
C
          END DO
C
C=======================================================================
C          BUG IN VERSION 2.49T: BECAUSE OF SIMPLEX SYMMETRY, Q.P. ARE
C          DEGENERATE AND FOR T>0 HAVE THE SAME FERMI-DIRAC OCCUPATION.
C          THE LOOP  ABOVE USES  THIS PROPERTY  AND ONLY FILLS OUT THE
C          OCCUPATION VECTOR  FERMFN() FROM 1 TO LDHALF. HOWEVER, THIS
C          MEANS THAT ONLY *HALF* OF THE  ENTROPY IS ACTUALLY COMPUTED,
C          HENCE THE CORRECTION BELOW.
C=======================================================================
C
          ENTRPY(ICHARG)=2.0D0*ENTRPY(ICHARG)
C
      END IF
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C=======================================================================
C         DEFINING NUMBERS OF QUASIPARTICLES KEPT AFTER THE CUT-OFF
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         NUMBQP(IREVER,ICHARG)=IDSTAT(IREVER)
C
      END DO
C
C=======================================================================
C         STOP IN CASE OF AN INCORRECT PHASE SPACE
C=======================================================================
C
      IF (INCORR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,                              1X,20(1H/),
     *              '' TOO LARGE PHASE-SPACE IN HFBSIM NO.1'',
     *                                                   1X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' ICHARG='',I2,3X,'' NDSTAT='',I4, 13X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' INCREASE NDSTAT UP TO NUMBQP OR MORE'',
     *                                                   1X,20(1H/),/)')
     *
     *    ICHARG,NDSTAT,(IREVER,NUMBQP(IREVER,ICHARG),IREVER=0,NDREVE)
C
          STOP ' TOO LARGE PHASE-SPACE IN HFBSIM NO.1'
C
      END IF
C
C=======================================================================
C         HERE QUASIPARTICLE STATES ARE BLOCKED
C=======================================================================
C
      IREQPB=0
      INUQPB=0
      JNUQPB=0
C
      ABLQUA(:,:,ICHARG)=C_ZERO
      BBLQUA(:,:,ICHARG)=C_ZERO
C
      INCORR=0
C
      IF (IABS(IDSIMB).EQ.1) THEN
C
C          The dimension (column number) of EWAHFB is different
c          between quasiparticle cutoff and two-basis cutoff
          IF (ITWOBA.NE.1) THEN
              KDBASE=LDBASE
          ELSE
              KDBASE=LDHALF(0)
          END IF
C
          CALL BLOSIM(ICHARG,INSIMB,IRSIMB,IDSIMB,INUQPB,IREQPB,
     *                                            IFIBLB,ISABLB)
C
          ISTATE=NSTATE(NORDER(IALLXX(INUQPB,IREQPB)))
C
          IF (IREQPB.EQ.0) THEN
C
              IDSTAT(1)=IDSTAT(1)+1
C
              IF (IDSTAT(1).GT.NDSTAT) THEN
C
                  INCORR=1
                  GO TO 2
C
              END IF
C
C=======================================================================
C         HERE THE BLOCKED QUASIPARTICLE STATE IS  ZEROED  AND  INVERTED
C         QUASIPARTICLE STATE IS ADDED TO THE OPPOSITE SIMPLEX
C=======================================================================
C
              DO IBASE=1,LDBASE
C
                 BWAQUA(IBASE,INUQPB   ,0)=C_ZERO
                 AWAQUA(IBASE,INUQPB   ,1)=C_ZERO
C
                 BWAQUA(IBASE,IDSTAT(1),1)=
     *                                CONJG(EWAHFB(IBASE+LDBASE,ISTATE))
                 AWAQUA(IBASE,IDSTAT(1),0)=
     *                                CONJG(EWAHFB(IBASE       ,ISTATE))
C
                 BBLQUA(IBASE,1,ICHARG)=
     *                                CONJG(EWAHFB(IBASE+LDBASE,ISTATE))
                 ABLQUA(IBASE,0,ICHARG)=
     *                                CONJG(EWAHFB(IBASE       ,ISTATE))
C
              END DO
C
              DEQUIV(IDSTAT(1),1)=      DEQUIV(INUQPB,0)
              EEQUIV(IDSTAT(1),1)=      EEQUIV(INUQPB,0)
              ENQUAP(IDSTAT(1),1)=      ENQUAP(INUQPB,0)
              V2QUAP(IDSTAT(1),1)=1.0D0-V2QUAP(INUQPB,0)
              QPPARI(IDSTAT(1),1)=      QPPARI(INUQPB,0)
C
              JNUQPB=IDSTAT(1)
C
          ELSE
C
              IDSTAT(0)=IDSTAT(0)+1
C
              IF (IDSTAT(0).GT.NDSTAT) THEN
C
                  INCORR=1
                  GO TO 2
C
              END IF
C
              DO IBASE=1,LDBASE
C
                 BWAQUA(IBASE,INUQPB   ,1)=C_ZERO
                 AWAQUA(IBASE,INUQPB   ,0)=C_ZERO
C
                 BWAQUA(IBASE,IDSTAT(0),0)=
     *                                EWAHFB(IBASE       ,ISTATE+KDBASE)
                 AWAQUA(IBASE,IDSTAT(0),1)=
     *                                EWAHFB(IBASE+LDBASE,ISTATE+KDBASE)
C
                 BBLQUA(IBASE,0,ICHARG)=
     *                                EWAHFB(IBASE       ,ISTATE+KDBASE)
                 ABLQUA(IBASE,1,ICHARG)=
     *                                EWAHFB(IBASE+LDBASE,ISTATE+KDBASE)
C
              END DO
C
              DEQUIV(IDSTAT(0),0)=      DEQUIV(INUQPB,1)
              EEQUIV(IDSTAT(0),0)=      EEQUIV(INUQPB,1)
              ENQUAP(IDSTAT(0),0)=      ENQUAP(INUQPB,1)
              V2QUAP(IDSTAT(0),0)=1.0D0-V2QUAP(INUQPB,1)
              QPPARI(IDSTAT(0),0)=      QPPARI(INUQPB,1)
C
              JNUQPB=IDSTAT(0)
C
          END IF
C
C=======================================================================
C
    2     CONTINUE
C
C=======================================================================
C
      END IF
C
C=======================================================================
C         RE-DEFINING NUMBERS OF QUASIPARTICLES KEPT AFTER THE BLOCKING
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         NUMBQP(IREVER,ICHARG)=IDSTAT(IREVER)
C
      END DO
C
C=======================================================================
C         STOP IN CASE OF AN INCORRECT PHASE SPACE
C=======================================================================
C
      IF (INCORR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,                              1X,20(1H/),
     *              '' TOO LARGE PHASE-SPACE IN HFBSIM NO.2'',
     *                                                   1X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' ICHARG='',I2,3X,'' NDSTAT='',I4, 13X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' INCREASE NDSTAT UP TO NUMBQP OR MORE'',
     *                                                   1X,20(1H/),/)')
     *
     *    ICHARG,NDSTAT,(IREVER,NUMBQP(IREVER,ICHARG),IREVER=0,NDREVE)
C
          STOP ' TOO LARGE PHASE-SPACE IN HFBSIM NO.2'
C
      END IF
C
C=======================================================================
C        SAVING THE ARRAYS OF THE BOGOLIUBOV TRANSFORMATION FOR
C        NEUTRONS AND PROTONS FOR USE IN THE ROUTINE "RECQUA".
C        ATTENTION: THIS OVERWRITES PREVIOUS SAVING  OF  THESE
C                   ARRAYS, SO SWITCHES "IF_RPA"  OR  "IFTEMP"
C                   SHOULD  NOT  BE  ACTIVATED  SIMULTANEOUSLY
C                   WITH SWITCH "IWRIQU".
C=======================================================================
C
      IF (IWRIQU.NE.-1) THEN
C
          ASVQUA(:,:,:,ICHARG)=AWAQUA(:,:,:)
          BSVQUA(:,:,:,ICHARG)=BWAQUA(:,:,:)
C
      END IF
C
C=======================================================================
      DEALLOCATE (CELMTS,EWAHFB)
C=======================================================================
C
      CALL CPUTIM('HFBSIM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HFBSIQ(EFERMI,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                         FERALM,IFERAL,PARNUM,NOPART,
     *                                       ITWOBA,NUQEVE,
     *                                INSIQB,IPSIQB,IDSIQB,
     *                                       IFIBLB,ISABLB,
     *                                IREQPB,INUQPB,JNUQPB)
C=======================================================================
      USE PAIDEL
      USE MAT_PP
      USE MAT_PM
      USE ALLQUZ
      USE ALLSIQ, ONLY:LDMEFQ
      USE BLOSAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,PWAHFB,C_ZERO
      COMPLEX
     *          ABLQUZ,BBLQUZ
C=======================================================================
      ALLOCATABLE PWAHFB(:,:,:)
      ALLOCATABLE CELMTS(:)
C=======================================================================
      DIMENSION
     *          IDSTAT(0:NDREVE)
      DIMENSION
     *          PQUHFB(1:2*NDBASP,0:NDPARI)
      DIMENSION
     *          LDQUAP(0:NDPARI)
      DIMENSION
     *          EORDER(1:2*NDBASE),NORDER(1:2*NDBASE),
     *          NPARIT(1:2*NDBASE),NPSTAT(1:2*NDBASE)
      DIMENSION
     *          KPSTAT(1:NDSTAT,0:NDREVE),
     *          KPARIT(1:NDSTAT,0:NDREVE)
      DIMENSION
     *          INSIQB(1:NDBLOC),IPSIQB(1:NDBLOC),IDSIQB(1:NDBLOC)
C
      COMMON
     *       /XBLQUZ/ ABLQUZ(1:2*NDBASE,0:NDREVE,0:NDISOS,1:NDBLOC),
     *                BBLQUZ(1:2*NDBASE,0:NDREVE,0:NDISOS,1:NDBLOC)
      COMMON
     *       /XEQUIV/ EEQUIV(1:2*NDSTAT,0:NDREVE),
     *                DEQUIV(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PARIQU/ QPPARI(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /SIMPQU/ QPSIMP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /PARIND/ INDPAR(1:NDBASE,0:NDPARI)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      INTERFACE
         SUBROUTINE TWOSIQ(IPARIT,CELMTS,EQUHFB,EWAHFB,EFERMI)
            USE hfodd_sizes
            COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
            COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
            REAL, DIMENSION(1:2*NDBASP) :: EQUHFB
            INTEGER :: IPARIT,ICHARG
            REAL :: ECUTOF,EFERMI
         END SUBROUTINE TWOSIQ
      END INTERFACE
C=======================================================================
C
      CALL CPUTIM('HFBSIQ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(AWAQUZ)) THEN
          ALLOCATE (AWAQUZ(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('AWAQUZ','HFBSIQ')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(BWAQUZ)) THEN
          ALLOCATE (BWAQUZ(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BWAQUZ','HFBSIQ')
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:(4*NDBASP+1)*2*NDBASP),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','HFBSIQ')
      ALLOCATE (PWAHFB(1:4*NDBASP,1:4*NDBASP,0:NDPARI),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('PWAHFB','HFBSIQ')
C=======================================================================
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HFB MATRIX
C         FOR THE CONSERVED-PARITY CASE
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C     SEE COMMENTS ABOUT NDBASP IN THE DIASIQ SUBROUTINE
C=======================================================================
C
      IF (MAX(LDBASP(0),LDBASP(1)).GT.NDBASP) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' PARAMETER NDBASP TOO SMALL'',
     *                            '' IN HFBSIQ'',       1X,19(1H/),/,
     *                 1X,20(1H/),'' NDBASP ='',I3,
     *                            '' INCREASE TO  NDBASP ='',I3,
     *                                                  1X,19(1H/),/)')
     *
     *    NDBASP,MAX(LDBASP(0),LDBASP(1))
C
          STOP 'INCREASE NDBASP IN HFBSIQ'
C
      END IF
C
C=======================================================================
C         DETERMINING THE HFB MEAN-FIELD EIGENSTATES AND SPECTRUM
C=======================================================================
C      See comments in HFBSIG
      IF (IABS(IDSIQB(1)).EQ.1 .OR. IMFHFB.EQ.1 .OR. ITWOBA.EQ.1) THEN
C
          IF(ITWOBA.EQ.1)THEN
              LIMPAR=1
          ELSE
              LIMPAR=0
          END IF
C
          CALL DIASIQ(ICHARG,LIMPAR,ECUTOF)
C
      END IF
C=======================================================================
C         CONSTRUCTING THE HFB MATRIX
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
         LDPARI=LDBASP(IPARIT)
C
         DO IBRAPA=1,4*LDPARI
            DO IKETPA=1,4*LDPARI
C
               IF (IBRAPA.GE.IKETPA) THEN
C
                   NCOUNT=IBRAPA+((8*LDPARI-IKETPA)*(IKETPA-1))/2
C
                   IF (IBRAPA.LE.2*LDPARI.AND.IKETPA.LE.2*LDPARI) THEN
C
                       IF (IBRAPA.LE.LDPARI.AND.IKETPA.LE.LDPARI)
     *                     CELMTS(NCOUNT)=
     *                          BIG_PP(INDPAR(IBRAPA         ,IPARIT),
     *                                 INDPAR(IKETPA         ,IPARIT),0)
                       IF (IBRAPA.GT.LDPARI.AND.IKETPA.GT.LDPARI)
     *                     CELMTS(NCOUNT)=
     *                          BIG_PP(INDPAR(IBRAPA-  LDPARI,IPARIT),
     *                                 INDPAR(IKETPA-  LDPARI,IPARIT),1)
                       IF (IBRAPA.GT.LDPARI.AND.IKETPA.LE.LDPARI)
     *                     CELMTS(NCOUNT)=
     *                          BIG_PM(INDPAR(IBRAPA-  LDPARI,IPARIT),
     *                                 INDPAR(IKETPA         ,IPARIT),1)
C
                   END IF
C
                   IF (IBRAPA.GT.2*LDPARI.AND.IKETPA.LE.2*LDPARI) THEN
C
                       IF (IBRAPA.LE.3*LDPARI.AND.IKETPA.LE.LDPARI)
     *                     CELMTS(NCOUNT)=
     *                  -CONJG(HAMIDE(INDPAR(IBRAPA-2*LDPARI,IPARIT),
     *                                INDPAR(IKETPA         ,IPARIT),1))
                       IF (IBRAPA.GT.3*LDPARI.AND.IKETPA.GT.LDPARI)
     *                     CELMTS(NCOUNT)=
C USE HAM2DE AS IN HFBSIZ
     *                  -CONJG(HAM2DE(INDPAR(IBRAPA-3*LDPARI,IPARIT),
     *                                INDPAR(IKETPA-  LDPARI,IPARIT),1))
                       IF (IBRAPA.LE.3*LDPARI.AND.IKETPA.GT.LDPARI)
     *                     CELMTS(NCOUNT)=
     *                  +CONJG(HAM2DE(INDPAR(IBRAPA-2*LDPARI,IPARIT),
     *                                INDPAR(IKETPA-  LDPARI,IPARIT),0))
                       IF (IBRAPA.GT.3*LDPARI.AND.IKETPA.LE.LDPARI)
     *                     CELMTS(NCOUNT)=
     *                  -CONJG(HAMIDE(INDPAR(IBRAPA-3*LDPARI,IPARIT),
     *                                INDPAR(IKETPA         ,IPARIT),0))
C
                   END IF
C
                   IF (IBRAPA.GT.2*LDPARI.AND.IKETPA.GT.2*LDPARI) THEN
C
                       IF (IBRAPA.LE.3*LDPARI.AND.IKETPA.LE.3*LDPARI)
     *                     CELMTS(NCOUNT)=
     *                  -CONJG(BIG_PP(INDPAR(IBRAPA-2*LDPARI,IPARIT),
     *                                INDPAR(IKETPA-2*LDPARI,IPARIT),0))
                       IF (IBRAPA.GT.3*LDPARI.AND.IKETPA.GT.3*LDPARI)
     *                     CELMTS(NCOUNT)=
     *                  -CONJG(BIG_PP(INDPAR(IBRAPA-3*LDPARI,IPARIT),
     *                                INDPAR(IKETPA-3*LDPARI,IPARIT),1))
                       IF (IBRAPA.GT.3*LDPARI.AND.IKETPA.LE.3*LDPARI)
     *                     CELMTS(NCOUNT)=
     *                  -CONJG(BIG_PM(INDPAR(IBRAPA-3*LDPARI,IPARIT),
     *                                INDPAR(IKETPA-2*LDPARI,IPARIT),1))
C
                   END IF
C
               END IF
C
            END DO
         END DO
C
C=======================================================================
C         SUBTRACTING THE FERMI ENERGY TERM FROM THE MEAN FIELD
C=======================================================================
C
         DO IBRAPA=1,4*LDPARI
C
            IKETPA=IBRAPA
C
            NCOUNT=IBRAPA+((8*LDPARI-IKETPA)*(IKETPA-1))/2
C
            IF (IBRAPA.LE.2*LDPARI)
     *
     *          CELMTS(NCOUNT)=CELMTS(NCOUNT)-EFERMI
C
            IF (IBRAPA.GT.2*LDPARI)
     *
     *          CELMTS(NCOUNT)=CELMTS(NCOUNT)+EFERMI
C
         END DO
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE SPECTRUM  BELOW
C          THE ENERGY CUTOF WILL BE USED.
C=======================================================================
C
         IF (ITWOBA.NE.1) THEN
C
             IF (LIMQUA.EQ.1) THEN
C
                 LDQUAP(IPARIT)=0
C
                 EIGMIN=EFERMI-ECUTOF
                 EIGMAX=0.0D0
C
                 CALL DIAMAT(CELMTS,PQUHFB(1,IPARIT),PWAHFB(1,1,IPARIT),
     *                                 4*LDPARI,4*NDBASP,LDQUAP(IPARIT))
C
             ELSE
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE LOWER  HALF  OF
C          THE SPECTRUM (NEGATIVE QUASIPARTICLE ENERGIES) WILL BE  USED.
C          THEREFORE, BELOW  WE  REQUEST ONLY HALF OF EIGENVECTORS.
C=======================================================================
C
                 LDQUAP(IPARIT)=2*LDPARI
C
                 CALL DIAMAT(CELMTS,PQUHFB(1,IPARIT),PWAHFB(1,1,IPARIT),
     *                                 4*LDPARI,4*NDBASP,LDQUAP(IPARIT))
C
             END IF
C
         ELSE
C
C=======================================================================
C          CALLING THE TWO-BASIS ROUTINE.
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.04Q) AND (3.16M), THE TREATMENT
C                    OF "NUQUVE" IN "HFBSIQ" WAS IMPLEMENTED  SO  AS  TO
C                    ENSURE AN EVEN TOTAL NUMBER  OF  STATES,  WITH  THE
C                    CASE OF ODD NUMBERS OF STATES IN BOTH PARITY BLOCKS
C                    LEFT TO BE ALLOWED. THAT CASE WAS  CAUSING  STRANGE
C                    WRONG RESULTS FOR THE PFAFFIAN NORMS OF AN  UNKNOWN
C                    ETIOLOGY. THIS BUG WAS CORRECTED ON  28/12/2022  IN
C                    VERSION (3.16N).
C=======================================================================
C
             IF (NUQEVE.EQ.1.AND.MOD(LDMEFQ(IPARIT),2).EQ.1)
     *           LDMEFQ(IPARIT)=LDMEFQ(IPARIT)-1
C
             CALL TWOSIQ(IPARIT,CELMTS,PQUHFB(:,IPARIT),
     *                   PWAHFB(:,:,IPARIT),EFERMI)
C
             LDQUAP(IPARIT)=LDMEFQ(IPARIT)
C
         END IF
C
      END DO
C
C=======================================================================
C         DETERMINING THE ORDERED QUASIPARTICLE SPECTRUM
C=======================================================================
C
      IORDER=0
C
      DO IPARIT=0,NDPARI
C
         DO IPSTAT=1,LDQUAP(IPARIT)
C
            IORDER=IORDER+1
            IF (IORDER.GT.2*NDBASE) STOP ' TOO LARGE IORDER IN HFBSIQ'
            NORDER(IORDER)=IORDER
            NPARIT(IORDER)=IPARIT
            EORDER(IORDER)=-PQUHFB(IPSTAT,IPARIT)
            NPSTAT(IORDER)=IPSTAT
C
         END DO
C
      END DO
C
      LDORDE=IORDER
C
      CALL ORDER1(EORDER,NORDER,LDORDE)
C
C=======================================================================
C         LOOP OVER ORDERED QUASIPARTICLE STATES
C=======================================================================
C
      INCORR=0
C
      IDSTAT(0)=0
      IDSTAT(1)=0
C
      DO IALLST=1,LDORDE
C
         IPSTAT=NPSTAT(NORDER(IALLST))
         IPARIT=NPARIT(NORDER(IALLST))
C
         LDPARI=LDBASP(IPARIT)
C
C=======================================================================
C        CALCULATING THE NORMS OF THE "FIRST" COMPONENTS
C=======================================================================
C
         VORDE0=0.0D0
         VORDE1=0.0D0
C
         DO IBASE=1,LDPARI
C
            VORDE0=VORDE0+ ABS(PWAHFB(IBASE       ,IPSTAT,IPARIT))**2
            VORDE1=VORDE1+ ABS(PWAHFB(IBASE+LDPARI,IPSTAT,IPARIT))**2
C
         END DO
C
         VORDER=VORDE0+VORDE1
C
C=======================================================================
C        CHECKING VALUES OF VORDER - JUST IN CASE. VALUES WHICH ARE OUT
C        OF BOUNDS UP TO A SMALL MACHINE-PRECISION NUMBER "EMACHI"  ARE
C        REPLACED BY THE VALUES AT BOUNDS.
C=======================================================================
C
         EMACHI=1.0D-10
C
         IF (VORDER.GT.1+EMACHI.OR.VORDER.LT. -EMACHI) THEN
C
             WRITE(NFIPRI,'(/,1X,20(1H/),
     *             '' ERROR IN NORMALIZATION OF'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' QUASIPARTICLES IN HFBSIQ.'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' IF THIS IS A ROUND-OFF PROBLEM'', 4X,20(1H/),/,
     *             1X,20(1H/),
     *             '' YOU MAY CHANGE VALUE OF EMACHI.'',3X,20(1H/),/,
     *             1X,20(1H/),'' IPSTAT='',I5,'' IPARIT='',I2,
     *                                           12X,20(1H/),/,
     *             1X,20(1H/),'' VORDER='',D25.18,
     *                                            2X,20(1H/),/)')
     *
     *             IPSTAT,IPARIT,VORDER
C
             STOP 'ERROR IN NORMALIZATION OF QUASIPARTICLES IN HFBSIQ'
C
         END IF
C
         IF (VORDER.GT.1) VORDER=1
         IF (VORDER.LT.0) VORDER=0
C
C=======================================================================
C        CALCULATING THE EQUIVALENT SPECTRUM AND CUTTING-OFF THE STATES
C        WITH HIGH EQUIVALENT ENERGIES
C=======================================================================
C
         HORDER=EORDER(IALLST)*(1-2*VORDER)
C
                          CORDER=HORDER+EFERMI
         IF (LAMCUT.EQ.1) CORDER=HORDER
C
         IF (CORDER.GT.ECUTOF.AND.ITWOBA.NE.1) GO TO 1
C
C=======================================================================
C        HERE WE DIVIDE THE SET OF QUASIPARICLE STATES INTO TWO  GROUPS
C        BY CHECKING IF THEY HAVE  DOMINANT  SIMPLEX=+i  OR  SIMPLEX=-i
C        COMPONENTS. THE DIVISION IS ARTIFICIAL; AND IT ONLY SERVES THE
C        PURPOSE OF CONSTRUCTING MATRICES ANALOGUOUS TO THOSE  USED  IN
C        THE CONSERVED-SIMPLEX CASE.
C=======================================================================
C
         IF (VORDE0.GT.VORDE1) THEN
C
             IREVER=0
         ELSE
             IREVER=1
C
         END IF
C
C=======================================================================
C
         IDSTAT(IREVER)=IDSTAT(IREVER)+1
C
         IF (IDSTAT(IREVER).GT.NDSTAT) THEN
C
             INCORR=1
             GO TO 1
C
         END IF
C
         KPSTAT(IDSTAT(IREVER),IREVER)=IPSTAT
         KPARIT(IDSTAT(IREVER),IREVER)=IPARIT
C
C=======================================================================
C        SEE COMMENTS ABOUT ARRAYS "DEQUIV" AND "EEQUIV" IN "HFBSIM"
C=======================================================================
C
         DEQUIV(IDSTAT(IREVER),IREVER)=
     *                            SQRT(ABS(EORDER(IALLST)**2-HORDER**2))
C
         EEQUIV(IDSTAT(IREVER),IREVER)=HORDER+EFERMI
C
C=======================================================================
C        DEFINING THE QUASIPARTICLE ENERGIES AND OCCUPATIONS
C=======================================================================
C
         ENQUAP(IDSTAT(IREVER),IREVER)=EORDER(IALLST)
C
         V2QUAP(IDSTAT(IREVER),IREVER)=VORDER
C
         QPPARI(IDSTAT(IREVER),IREVER)=1-2*IPARIT
C
         IF (VORDER.GT.0) THEN
C
             QPSIMP(IDSTAT(IREVER),IREVER)=(VORDE0-VORDE1)/VORDER
         ELSE
             QPSIMP(IDSTAT(IREVER),IREVER)=1.0D+10
C
         END IF
C
    1    CONTINUE
C
      END DO
C
C=======================================================================
C         DEFINING NUMBERS OF QUASIPARTICLES KEPT AFTER THE CUT-OFF
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         NUMBQP(IREVER,ICHARG)=IDSTAT(IREVER)
C
      END DO
C
C=======================================================================
C         STOP IN CASE OF AN INCORRECT PHASE SPACE
C=======================================================================
C
      IF (INCORR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,                              1X,20(1H/),
     *              '' TOO LARGE PHASE-SPACE SIZE IN HFBSIQ'',
     *                                                   1X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' ICHARG='',I2,3X,'' NDSTAT='',I4, 13X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' INCREASE NDSTAT UP TO NUMBQP OR MORE'',
     *                                                   1X,20(1H/),/)')
     *
     *    ICHARG,NDSTAT,(IREVER,NUMBQP(IREVER,ICHARG),IREVER=0,NDREVE)
C
          STOP ' TOO LARGE PHASE-SPACE SIZE IN HFBSIQ'
C
      END IF
C
C=======================================================================
C        CONSTRUCTING THE HFB A* AND B* MATRICES.
C=======================================================================
C
      DO IREVER=0,NDREVE
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
            IPSTAT=KPSTAT(ISTATE,IREVER)
            IPARIT=KPARIT(ISTATE,IREVER)
C
            LDPARI=LDBASP(IPARIT)
C
            JPARIT=1-IPARIT
            KDPARI=LDBASP(JPARIT)
C
            LSTATE=ISTATE+IREVER*NUMBQP(0,ICHARG)
C
            DO IPBASE=1,LDPARI
C
               BWAQUZ(INDPAR(IPBASE,IPARIT),LSTATE,0)=
     *                             PWAHFB(IPBASE         ,IPSTAT,IPARIT)
               BWAQUZ(INDPAR(IPBASE,IPARIT),LSTATE,1)=
     *                             PWAHFB(IPBASE+  LDPARI,IPSTAT,IPARIT)
C
               AWAQUZ(INDPAR(IPBASE,IPARIT),LSTATE,0)=
     *                             PWAHFB(IPBASE+2*LDPARI,IPSTAT,IPARIT)
               AWAQUZ(INDPAR(IPBASE,IPARIT),LSTATE,1)=
     *                             PWAHFB(IPBASE+3*LDPARI,IPSTAT,IPARIT)
C
            END DO
C
            DO IPBASE=1,KDPARI
C
               BWAQUZ(INDPAR(IPBASE,JPARIT),LSTATE,0)=C_ZERO
               BWAQUZ(INDPAR(IPBASE,JPARIT),LSTATE,1)=C_ZERO
C
               AWAQUZ(INDPAR(IPBASE,JPARIT),LSTATE,0)=C_ZERO
               AWAQUZ(INDPAR(IPBASE,JPARIT),LSTATE,1)=C_ZERO
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         HERE QUASIPARTICLE STATES ARE BLOCKED
C=======================================================================
C
      IREQPB=0
      INUQPB=0
      JNUQPB=0
C
      ABLQUZ(:,:,ICHARG,:)=C_ZERO
      BBLQUZ(:,:,ICHARG,:)=C_ZERO
C
      IF (IABS(IDSIQB(1)).EQ.1) THEN
C
          CALL BLOSIQ(ICHARG,INSIQB,IPSIQB,IDSIQB,INUQPB,IREQPB,
     *                                            IFIBLB,ISABLB)
C
          IF (IPRODD.EQ.1) THEN
              CALL INIADD
              BLOLAB(ICHARG,1)%N=INUQPB
              BLOLAB(ICHARG,1)%IR=IREQPB
          END IF
C
          IPSTAT=KPSTAT(INUQPB,IREQPB)
          IPARIT=KPARIT(INUQPB,IREQPB)
C
          LDPARI=LDBASP(IPARIT)
C
          LSTATE=INUQPB+IREQPB*NUMBQP(0,ICHARG)
C
C=======================================================================
C         HERE THE INVERTED QUASIPARTICLE REPLACES THE STANDARD ONE
C=======================================================================
C
          DO IPBASE=1,LDPARI
C
             BWAQUZ(INDPAR(IPBASE,IPARIT),LSTATE,0)=
     *                      CONJG(PWAHFB(IPBASE+2*LDPARI,IPSTAT,IPARIT))
             BWAQUZ(INDPAR(IPBASE,IPARIT),LSTATE,1)=
     *                      CONJG(PWAHFB(IPBASE+3*LDPARI,IPSTAT,IPARIT))
C
             AWAQUZ(INDPAR(IPBASE,IPARIT),LSTATE,0)=
     *                      CONJG(PWAHFB(IPBASE         ,IPSTAT,IPARIT))
             AWAQUZ(INDPAR(IPBASE,IPARIT),LSTATE,1)=
     *                      CONJG(PWAHFB(IPBASE+  LDPARI,IPSTAT,IPARIT))
C
             BBLQUZ(INDPAR(IPBASE,IPARIT),0,ICHARG,1)=
     *                    CONJG(PWAHFB(IPBASE+2*LDPARI,IPSTAT,IPARIT))
             BBLQUZ(INDPAR(IPBASE,IPARIT),1,ICHARG,1)=
     *                    CONJG(PWAHFB(IPBASE+3*LDPARI,IPSTAT,IPARIT))
C
             ABLQUZ(INDPAR(IPBASE,IPARIT),0,ICHARG,1)=
     *                    CONJG(PWAHFB(IPBASE         ,IPSTAT,IPARIT))
             ABLQUZ(INDPAR(IPBASE,IPARIT),1,ICHARG,1)=
     *                    CONJG(PWAHFB(IPBASE+  LDPARI,IPSTAT,IPARIT))
C
          END DO
C
          V2QUAP(INUQPB,IREQPB)=1.0D0-V2QUAP(INUQPB,IREQPB)
C
          JNUQPB=INUQPB
C
      END IF
C
C=======================================================================
      DEALLOCATE (CELMTS,PWAHFB)
C=======================================================================
C
      CALL CPUTIM('HFBSIQ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HFBSIZ(EFERMI,ECUTOF,LIMQUA,LAMCUT,ICHARG,IMFHFB,
     *                         FERALM,IFERAL,PARNUM,NOPART,
     *                                       ITWOBA,NUQEVE,
     *                                       INSIZB,IDSIZB,
     *                                       IFIBLB,ISABLB,
     *                         IREMQB,INUMQB,JNUMQB,ISAOCC)
C=======================================================================
      USE PAIDEL
      USE MAT_PP
      USE MAT_PM
      USE ALLQUZ
      USE BLOSAV
      USE SAVQUA
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,EWAHFB
      COMPLEX
     *          ABLQUZ,BBLQUZ
      COMPLEX
     *          C_ZERO
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE EWAHFB(:,:)
C=======================================================================
      DIMENSION
     *          IDSTAT(0:NDREVE)
      DIMENSION
     *          EQUHFB(1:4*NDBASE)
C=======================================================================
      DIMENSION
     *          EORDER(1:2*NDBASE),NORDER(1:2*NDBASE),
     *          NSTATE(1:2*NDBASE)
      DIMENSION
     *          KSTATE(1:NDSTAT,0:NDREVE)
      DIMENSION
     *          INSIZB(1:NDBLOC),IDSIZB(1:NDBLOC)
      DIMENSION
     *          IREMQB(1:NDBLOC),INUMQB(1:NDBLOC),JNUMQB(1:NDBLOC)
C
      COMMON
     *       /XBLQUZ/ ABLQUZ(1:2*NDBASE,0:NDREVE,0:NDISOS,1:NDBLOC),
     *                BBLQUZ(1:2*NDBASE,0:NDREVE,0:NDISOS,1:NDBLOC)
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /XEQUIV/ EEQUIV(1:2*NDSTAT,0:NDREVE),
     *                DEQUIV(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PARIQU/ QPPARI(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /SIMPQU/ QPSIMP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PARBAS/ IBAPAR(1:NDBASE,1:NDTWCE)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /ADBEFE/ E_FERMI(0:NDISOS)
C
      INTERFACE
         SUBROUTINE TWOSIZ(CELMTS,EQUHFB,EWAHFB,LDMEFI,EFERMI)
            USE hfodd_sizes
            COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
            COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
            REAL, DIMENSION(1:4*NDBASE) :: EQUHFB
            INTEGER :: LDMEFI,ICHARG
            REAL :: ECUTOF,EFERMI
         END SUBROUTINE TWOSIZ
      END INTERFACE
C
C=======================================================================
C
      CALL CPUTIM('HFBSIZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(AWAQUZ)) THEN
          ALLOCATE (AWAQUZ(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('AWAQUZ','HFBSIZ')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(BWAQUZ)) THEN
          ALLOCATE (BWAQUZ(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BWAQUZ','HFBSIZ')
      END IF
C=======================================================================
      IF (ISAOCC.EQ.1) THEN
          IF (.NOT.ALLOCATED(ASVQUA)) THEN
              ALLOCATE (ASVQUA(1:NDBASE,1:2*NDSTAT,0:NDREVE,0:NDISOS),
     *                  STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('ASVQUA','HFBSIZ')
          END IF
          IF (.NOT.ALLOCATED(BSVQUA)) THEN
              ALLOCATE (BSVQUA(1:NDBASE,1:2*NDSTAT,0:NDREVE,0:NDISOS),
     *                  STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('BSVQUA','HFBSIZ')
          END IF
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:(4*NDBASE+1)*2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','HFBSIZ')
      ALLOCATE (EWAHFB(1:4*NDBASE,1:4*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAHFB','HFBSIZ')
C=======================================================================
C
      C_ZERO=CMPLX(0.0,0.0)
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HFB MATRIX
C         FOR THE NO-SYMMETRY CASE
C=======================================================================
C
C=======================================================================
C         CONSTRUCTING THE HFB MATRIX
C=======================================================================
C
      DO IBRA=1,4*LDBASE
         DO IKET=1,4*LDBASE
C
            IF (IBRA.GE.IKET) THEN
C
                NCOUNT=IBRA+((8*LDBASE-IKET)*(IKET-1))/2
C
                IF (IBRA.LE.2*LDBASE.AND.IKET.LE.2*LDBASE) THEN
C
                    IF (IBRA.LE.LDBASE.AND.IKET.LE.LDBASE)
     *                  CELMTS(NCOUNT)=
     *                            BIG_PP(IBRA         ,IKET         ,0)
                    IF (IBRA.GT.LDBASE.AND.IKET.GT.LDBASE)
     *                  CELMTS(NCOUNT)=
     *                            BIG_PP(IBRA-  LDBASE,IKET-  LDBASE,1)
                    IF (IBRA.GT.LDBASE.AND.IKET.LE.LDBASE)
     *                  CELMTS(NCOUNT)=
     *                            BIG_PM(IBRA-  LDBASE,IKET         ,1)
C
                END IF
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.LE.2*LDBASE) THEN
C
                    IF (IBRA.LE.3*LDBASE.AND.IKET.LE.LDBASE)
     *                  CELMTS(NCOUNT)=
     *                     -CONJG(HAMIDE(IBRA-2*LDBASE,IKET         ,1))
                    IF (IBRA.GT.3*LDBASE.AND.IKET.GT.LDBASE)
     *                  CELMTS(NCOUNT)=
     *                     -CONJG(HAM2DE(IBRA-3*LDBASE,IKET-  LDBASE,1))
                    IF (IBRA.LE.3*LDBASE.AND.IKET.GT.LDBASE)
     *                  CELMTS(NCOUNT)=
     *                     +CONJG(HAM2DE(IBRA-2*LDBASE,IKET-  LDBASE,0))
                    IF (IBRA.GT.3*LDBASE.AND.IKET.LE.LDBASE)
     *                  CELMTS(NCOUNT)=
     *                     -CONJG(HAMIDE(IBRA-3*LDBASE,IKET         ,0))
C
                END IF
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.GT.2*LDBASE) THEN
C
                    IF (IBRA.LE.3*LDBASE.AND.IKET.LE.3*LDBASE)
     *                  CELMTS(NCOUNT)=
     *                     -CONJG(BIG_PP(IBRA-2*LDBASE,IKET-2*LDBASE,0))
                    IF (IBRA.GT.3*LDBASE.AND.IKET.GT.3*LDBASE)
     *                  CELMTS(NCOUNT)=
     *                     -CONJG(BIG_PP(IBRA-3*LDBASE,IKET-3*LDBASE,1))
                    IF (IBRA.GT.3*LDBASE.AND.IKET.LE.3*LDBASE)
     *                  CELMTS(NCOUNT)=
     *                     -CONJG(BIG_PM(IBRA-3*LDBASE,IKET-2*LDBASE,1))
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         SUBTRACTING THE FERMI ENERGY TERM FROM THE MEAN FIELD
C=======================================================================
C
      DO IBRA=1,4*LDBASE
C
         IKET=IBRA
C
         NCOUNT=IBRA+((8*LDBASE-IKET)*(IKET-1))/2
C
         IF (IBRA.LE.2*LDBASE)
     *
     *       CELMTS(NCOUNT)=CELMTS(NCOUNT)-EFERMI
C
         IF (IBRA.GT.2*LDBASE)
     *
     *       CELMTS(NCOUNT)=CELMTS(NCOUNT)+EFERMI
C
      END DO
C
C=======================================================================
C         DETERMINING THE HFB MEAN-FIELD EIGENSTATES AND SPECTRUM
C=======================================================================
C
      IF (MAXVAL(IABS(IDSIZB)).EQ.1.OR.IMFHFB.EQ.1.OR.ITWOBA.EQ.1) THEN
C
          IF (ITWOBA.EQ.1) THEN
C
              LIMPAR=1
          ELSE
              LIMPAR=0
C
          END IF
C
          CALL DIASIZ(ICHARG,LIMPAR,ECUTOF,LDMEFI,ISAOCC)
C
      END IF
C
      IF (ITWOBA.NE.1) THEN
C
          IF (LIMQUA.EQ.1) THEN
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE SPECTRUM  BELOW
C          THE ENERGY CUTOF WILL BE USED.
C=======================================================================
C
              LDQUAP=0
C
              EIGMIN=EFERMI-ECUTOF
              EIGMAX=0.0D0
C
              CALL DIAMAT(CELMTS,EQUHFB,EWAHFB,4*LDBASE,4*NDBASE,LDQUAP)
C
          ELSE
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE LOWER  HALF  OF
C          THE SPECTRUM (NEGATIVE QUASIPARTICLE ENERGIES) WILL BE  USED.
C          THEREFORE, BELOW  WE  REQUEST ONLY HALF OF EIGENVECTORS.
C=======================================================================
C
              LDQUAP=2*LDBASE
C
              CALL DIAMAT(CELMTS,EQUHFB,EWAHFB,4*LDBASE,4*NDBASE,LDQUAP)
C
          END IF
C
      ELSE
C
C=======================================================================
C          CALLING THE TWO-BASIS ROUTINE.
C=======================================================================
C
          IF (NUQEVE.EQ.1.AND.MOD(LDMEFI,2).EQ.1) LDMEFI=LDMEFI-1
C
          CALL TWOSIZ(CELMTS,EQUHFB,EWAHFB,LDMEFI,EFERMI)
C
          LDQUAP=LDMEFI
C
      END IF
C
C=======================================================================
C         DETERMINING THE ORDERED QUASIPARTICLE SPECTRUM
C=======================================================================
C
      IORDER=0
C
      DO ISTATE=1,LDQUAP
C
         IORDER=IORDER+1
         NORDER(IORDER)=IORDER
         EORDER(IORDER)=-EQUHFB(ISTATE)
         NSTATE(IORDER)=ISTATE
C
      END DO
C
      LDORDE=IORDER
C
      CALL ORDER1(EORDER,NORDER,LDORDE)
C
C=======================================================================
C         LOOP OVER ORDERED QUASIPARTICLE STATES
C=======================================================================
C
      INCORR=0
C
      IDSTAT(0)=0
      IDSTAT(1)=0
C
      DO IALLST=1,LDORDE
C
         ISTATE=NSTATE(NORDER(IALLST))
C
C=======================================================================
C        CALCULATING THE NORMS OF THE "FIRST" COMPONENTS
C=======================================================================
C
         VORDE0=0.0D0
         VORDE1=0.0D0
         PORDER=0.0D0
C
         DO IBASE=1,LDBASE
C
            VORDE0=VORDE0+ ABS(EWAHFB(IBASE       ,ISTATE))**2
            VORDE1=VORDE1+ ABS(EWAHFB(IBASE+LDBASE,ISTATE))**2
C
            PORDER=PORDER+(ABS(EWAHFB(IBASE       ,ISTATE))**2
     *                    +ABS(EWAHFB(IBASE+LDBASE,ISTATE))**2)
     *                    *(1-2*IBAPAR(IBASE,1))
C
         END DO
C
         VORDER=VORDE0+VORDE1
C
C=======================================================================
C        CHECKING VALUES OF VORDER - JUST IN CASE. VALUES WHICH ARE OUT
C        OF BOUNDS UP TO A SMALL MACHINE-PRECISION NUMBER "EMACHI"  ARE
C        REPLACED BY THE VALUES AT BOUNDS.
C=======================================================================
C
         EMACHI=1.0D-10
C
         IF (VORDER.GT.1+EMACHI.OR.VORDER.LT. -EMACHI) THEN
C
             WRITE(NFIPRI,'(/,1X,20(1H/),
     *             '' ERROR IN NORMALIZATION OF'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' QUASIPARTICLES IN HFBSIZ.'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' IF THIS IS A ROUND-OFF PROBLEM'', 4X,20(1H/),/,
     *             1X,20(1H/),
     *             '' YOU MAY CHANGE VALUE OF EMACHI.'',3X,20(1H/),/,
     *             1X,20(1H/),'' ISTATE='',I5,''        '',2X,
     *                                           12X,20(1H/),/,
     *             1X,20(1H/),'' VORDER='',D25.18,
     *                                            2X,20(1H/),/)')
     *
     *             ISTATE,VORDER
C
             STOP 'ERROR IN NORMALIZATION OF QUASIPARTICLES IN HFBSIZ'
C
         END IF
C
         IF (VORDER.GT.1) VORDER=1
         IF (VORDER.LT.0) VORDER=0
C
C=======================================================================
C        CALCULATING THE EQUIVALENT SPECTRUM AND CUTTING-OFF THE STATES
C        WITH HIGH EQUIVALENT ENERGIES. FOR THE  TWO-BASIS METHOD,  ALL
C        QUASIPARTICLE STATES ARE TAKEN INTO ACCOUNT (NO CUTOFF).
C=======================================================================
C
         HORDER=EORDER(IALLST)*(1-2*VORDER)
C
                          CORDER=HORDER+EFERMI
         IF (LAMCUT.EQ.1) CORDER=HORDER
C
         IF (CORDER.GT.ECUTOF.AND.ITWOBA.NE.1) GO TO 1
C
C=======================================================================
C        HERE WE DIVIDE THE SET OF QUASIPARICLE STATES INTO TWO  GROUPS
C        BY CHECKING IF THEY HAVE  DOMINANT  SIMPLEX=+i  OR  SIMPLEX=-i
C        COMPONENTS. THE DIVISION IS ARTIFICIAL; AND IT ONLY SERVES THE
C        PURPOSE OF CONSTRUCTING MATRICES ANALOGUOUS TO THOSE  USED  IN
C        THE CONSERVED-SIMPLEX CASE.
C=======================================================================
C
         IF (VORDE0.GT.VORDE1) THEN
C
             IREVER=0
         ELSE
             IREVER=1
C
         END IF
C
C=======================================================================
C
         IDSTAT(IREVER)=IDSTAT(IREVER)+1
C
         IF (IDSTAT(IREVER).GT.NDSTAT) THEN
C
             INCORR=1
             GO TO 1
C
         END IF
C
         KSTATE(IDSTAT(IREVER),IREVER)=ISTATE
C
C=======================================================================
C        SEE COMMENTS ABOUT ARRAYS "DEQUIV" AND "EEQUIV" IN "HFBSIM"
C=======================================================================
C
         DEQUIV(IDSTAT(IREVER),IREVER)=
     *                            SQRT(ABS(EORDER(IALLST)**2-HORDER**2))
C
         EEQUIV(IDSTAT(IREVER),IREVER)=HORDER+EFERMI
C
C=======================================================================
C        DEFINING THE QUASIPARTICLE ENERGIES AND OCCUPATIONS
C=======================================================================
C
         ENQUAP(IDSTAT(IREVER),IREVER)=EORDER(IALLST)
C
         V2QUAP(IDSTAT(IREVER),IREVER)=VORDER
C
         IF (VORDER.GT.0) THEN
C
             QPPARI(IDSTAT(IREVER),IREVER)=PORDER/VORDER
             QPSIMP(IDSTAT(IREVER),IREVER)=(VORDE0-VORDE1)/VORDER
         ELSE
             QPPARI(IDSTAT(IREVER),IREVER)=1.0D+10
             QPSIMP(IDSTAT(IREVER),IREVER)=1.0D+10
C
         END IF
C
    1    CONTINUE
C
      END DO
C
C=======================================================================
C         DEFINING NUMBERS OF QUASIPARTICLES KEPT AFTER THE CUT-OFF
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         NUMBQP(IREVER,ICHARG)=IDSTAT(IREVER)
C
      END DO
C
C=======================================================================
C         STOP IN CASE OF AN INCORRECT PHASE SPACE
C=======================================================================
C
      IF (INCORR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,                              1X,20(1H/),
     *              '' TOO LARGE PHASE-SPACE SIZE IN HFBSIZ'',
     *                                                   1X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' ICHARG='',I2,3X,'' NDSTAT='',I4, 13X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' INCREASE NDSTAT UP TO NUMBQP OR MORE'',
     *                                                   1X,20(1H/),/)')
     *
     *    ICHARG,NDSTAT,(IREVER,NUMBQP(IREVER,ICHARG),IREVER=0,NDREVE)
C
          STOP ' TOO LARGE PHASE-SPACE SIZE IN HFBSIZ'
C
      END IF
C
C=======================================================================
C        CONSTRUCTING THE HFB A* AND B* MATRICES.
C=======================================================================
C
      DO IREVER=0,NDREVE
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
            JSTATE=KSTATE(ISTATE,IREVER)
C
            LSTATE=ISTATE+IREVER*NUMBQP(0,ICHARG)
C
            DO IBASE=1,LDBASE
C
               BWAQUZ(IBASE,LSTATE,0)=EWAHFB(IBASE         ,JSTATE)
               BWAQUZ(IBASE,LSTATE,1)=EWAHFB(IBASE+  LDBASE,JSTATE)
C
               AWAQUZ(IBASE,LSTATE,0)=EWAHFB(IBASE+2*LDBASE,JSTATE)
               AWAQUZ(IBASE,LSTATE,1)=EWAHFB(IBASE+3*LDBASE,JSTATE)
C
            END DO
C
         END DO
      END DO
C
      IF (ISAOCC.EQ.1) THEN
C
          ASVQUA(:,:,:,ICHARG)=AWAQUZ(:,:,:)
          BSVQUA(:,:,:,ICHARG)=BWAQUZ(:,:,:)
          E_FERMI(ICHARG) = EFERMI
C
      END IF
C=======================================================================
C         HERE QUASIPARTICLE STATES ARE BLOCKED
C=======================================================================
C
      IREMQB(:)=0
      INUMQB(:)=0
      JNUMQB(:)=0
C
      ABLQUZ(:,:,ICHARG,:)=C_ZERO
      BBLQUZ(:,:,ICHARG,:)=C_ZERO
C
      DO NUBLOC=1,NDBLOC
C
C               WRITE (*,'(A8,3I3,3X,4I4,/,20X,4I4)') 'HFBSIZ-A',
C    *                          NUBLOC,0,ICHARG,
C    *                          INSIZB(NUBLOC),IDSIZB(NUBLOC)
C
          IF (IABS(IDSIZB(NUBLOC)).EQ.1) THEN
C
             CALL BLOSIZ(ICHARG,INSIZB(NUBLOC),IDSIZB(NUBLOC),
     *                          INUMQB(NUBLOC),IREMQB(NUBLOC),
     *                                  IFIBLB,ISABLB,NUBLOC,1)
C
             DO MUBLOC=1,NUBLOC-1
C
C               WRITE (*,'(A8,3I3,3X,4I4,/,20X,4I4)') 'HFBSIZ-B',
C    *                          NUBLOC,MUBLOC,ICHARG,
C    *                          INSIZB(NUBLOC),IDSIZB(NUBLOC),
C    *                          INUMQB(NUBLOC),IREMQB(NUBLOC),
C    *                          INSIZB(MUBLOC),IDSIZB(MUBLOC),
C    *                          INUMQB(MUBLOC),IREMQB(MUBLOC)
C
                IF (INUMQB(MUBLOC).EQ.INUMQB(NUBLOC).AND.
     *              IREMQB(MUBLOC).EQ.IREMQB(NUBLOC))
     *
     *              STOP ' QUASIPARTICLES BLOCKED TWICE IN HFBSIZ'
C
             END DO
C
          END IF
C
      END DO
C
      DO NUBLOC=1,NDBLOC
C
          IF (IABS(IDSIZB(NUBLOC)).EQ.1) THEN
C
C     STORE THE LABEL AND OCCUPATION NUMBER OF THE BLOCKED STATE
C
             IF (IPRODD.EQ.1) THEN
                 CALL INIADD
                 BLOLAB(ICHARG,NUBLOC)%N=INUMQB(NUBLOC)
                 BLOLAB(ICHARG,NUBLOC)%IR=IREMQB(NUBLOC)
             END IF
C
             JSTATE=KSTATE(INUMQB(NUBLOC),IREMQB(NUBLOC))
C
             LSTATE=INUMQB(NUBLOC)+IREMQB(NUBLOC)*NUMBQP(0,ICHARG)
C
C=======================================================================
C         HERE THE INVERTED QUASIPARTICLE REPLACES THE STANDARD ONE
C=======================================================================
C
             DO IBASE=1,LDBASE
C
                BWAQUZ(IBASE,LSTATE,0)=
     *                              CONJG(EWAHFB(IBASE+2*LDBASE,JSTATE))
                BWAQUZ(IBASE,LSTATE,1)=
     *                              CONJG(EWAHFB(IBASE+3*LDBASE,JSTATE))
C
                AWAQUZ(IBASE,LSTATE,0)=
     *                              CONJG(EWAHFB(IBASE         ,JSTATE))
                AWAQUZ(IBASE,LSTATE,1)=
     *                              CONJG(EWAHFB(IBASE+  LDBASE,JSTATE))
C
                BBLQUZ(IBASE,0,ICHARG,NUBLOC)=
     *                              CONJG(EWAHFB(IBASE+2*LDBASE,JSTATE))
                BBLQUZ(IBASE,1,ICHARG,NUBLOC)=
     *                              CONJG(EWAHFB(IBASE+3*LDBASE,JSTATE))
C
                ABLQUZ(IBASE,0,ICHARG,NUBLOC)=
     *                              CONJG(EWAHFB(IBASE         ,JSTATE))
                ABLQUZ(IBASE,1,ICHARG,NUBLOC)=
     *                              CONJG(EWAHFB(IBASE+  LDBASE,JSTATE))
C
             END DO
C
             V2QUAP(INUMQB(NUBLOC),IREMQB(NUBLOC))=1.0D0-
     *       V2QUAP(INUMQB(NUBLOC),IREMQB(NUBLOC))
C
             JNUMQB(NUBLOC)=INUMQB(NUBLOC)
C
          END IF
C
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS,EWAHFB)
C=======================================================================
C
      CALL CPUTIM('HFBSIZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE HFBMIZ(EFERMI,ECUTOF,LIMQUA,LAMCUT,IMFHFB,
     *                                       PARNUM,NOPART,
     *                                       ITWOBA,NUQEVE,
     *                                       INMIZB,IDMIZB,
     *                                       IFIBLB,ISABLB,
     *                         IREQPB,INUQPB,JNUQPB,ISAOCC)
C=======================================================================
      USE PNMXPP
      USE PNMXPM
      USE DNMXPP
      USE DNMXPM
      USE ALLQUZ
      USE BLOSAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,EWAHFB
      COMPLEX
     *          ABLMUZ,BBLMUZ
      COMPLEX
     *          C_ZERO
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE EWAHFB(:,:)
C=======================================================================
      DIMENSION
     *          IDSTAT(0:NDREVE)
      DIMENSION
     *          EQUHFB(1:8*NDBASE)
C=======================================================================
      DIMENSION
     *          EORDER(1:4*NDBASE),NORDER(1:4*NDBASE),
     *          NSTATE(1:4*NDBASE)
      DIMENSION
     *          KSTATE(1:2*NDSTAT,0:NDREVE)
      DIMENSION
     *          INMIZB(1:NDBLOC),IDMIZB(1:NDBLOC)
C
      COMMON
     *       /XBLMUZ/ ABLMUZ(1:2*NDBASE,0:NDREVE),
     *                BBLMUZ(1:2*NDBASE,0:NDREVE)
      COMMON
     *       /XEQUIV/ EEQUIV(1:2*NDSTAT,0:NDREVE),
     *                DEQUIV(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PARIQU/ QPPARI(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /SIMPQU/ QPSIMP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PARBAS/ IBAPAR(1:NDBASE,1:NDTWCE)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C     INTERFACE
C        SUBROUTINE TWOSIZ(CELMTS,EQUHFB,EWAHFB,LDMEFI,EFERMI)
C           USE hfodd_sizes
C           COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
C           COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
C           REAL, DIMENSION(1:4*NDBASE) :: EQUHFB
C           INTEGER :: LDMEFI,ICHARG
C           REAL :: ECUTOF,EFERMI
C        END SUBROUTINE TWOSIZ
C     END INTERFACE
C
C=======================================================================
C
      CALL CPUTIM('HFBMIZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(AWAQUZ)) THEN
          ALLOCATE (AWAQUZ(1:2*NDBASE,1:4*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('AWAQUZ','HFBMIZ')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(BWAQUZ)) THEN
          ALLOCATE (BWAQUZ(1:2*NDBASE,1:4*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BWAQUZ','HFBMIZ')
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:(8*NDBASE+1)*4*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','HFBMIZ')
      ALLOCATE (EWAHFB(1:8*NDBASE,1:8*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAHFB','HFBMIZ')
C=======================================================================
C
      C_ZERO=CMPLX(0.0,0.0)
C
C=======================================================================
C         THIS SUBROUTINE BUILDS AND DIAGONALIZES THE HFB MATRIX
C         FOR THE NO-SYMMETRY CASE WITH PROTON-NEUTRON MIXING
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE HFB DIAGONALIZATION IN THE CASE OF
C        NO CONSERVED SYMMETRIES AND PROTON-NEUTRON MIXED STATES
C=======================================================================
C        CONSTRUCTING THE HFB HAMILTONIAN MATRIX, WHICH HAS THE STANDARD
C        STRUCTURE OF THE 8x8 LDBASE BLOCKS:
C
C         -------------------------------------------------------------
C         |    HFB UPPER COMPONENTS     |    HFB LOWER COMPONENTS     |
C         -------------------------------------------------------------
C
C         -------------------------------------------------------------
C         |   HF HAMILTONIAN - LAMBDA   |        PAIRING DELTA        |
C         |-----------------------------|-----------------------------|
C         |      - PAIRING DELTA^*      | - HF HAMILTONIAN^* + LAMBDA |
C         -------------------------------------------------------------
C
C=======================================================================
C        WHERE THE HF HAMILT. AND PAIRING DELTA HAVE BOTH THE  FOLLOWING
C        NEUTRON (N),  PROTON (P),  SIMPLEX=+i (U),   AND SIMPLEX=-i (D)
C        STRUCTURE OF THE 4x4 LDBASE BLOCKS:
C
C         -------------------------------------------------------------
C         |         SIMPLEX-UP          |         SIMPLEX-DOWN        |
C         |-----------------------------|-----------------------------|
C         |   NEUTRONS   |   PROTONS    |   NEUTRONS   |   PROTONS    |
C         -------------------------------------------------------------
C
C         -------------------------------------------------------------
C         |    NU-NU     |    NU-PU     |    NU-ND     |    NU-PD     |
C         |--------------|--------------|--------------|--------------|
C         |    PU-NU     |    PU-PU     |    PU-ND     |    PU-PD     |
C         |--------------|--------------|--------------|--------------|
C         |    ND-NU     |    ND-PU     |    ND-ND     |    ND-PD     |
C         |--------------|--------------|--------------|--------------|
C         |    PD-NU     |    PD-PU     |    PD-ND     |    PD-PD     |
C         -------------------------------------------------------------
C
C=======================================================================
C
C=======================================================================
C        INDICES IBRA AND IKET PERTAIN TO THE 4X4 SUB-BLOCKS OF THE  HFB
C        MATRIX
C=======================================================================
C        THE UPPER-LEFT 4X4 HFB BLOCK (HF HAMILTONIAN)
C=======================================================================
C
      DO IBRA=1,4*LDBASE
         DO IKET=1,4*LDBASE
C
            IF (IBRA.GE.IKET) THEN
C
                NCOUNT=IBRA+((16*LDBASE-IKET)*(IKET-1))/2
C
                IF (IBRA.LE.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=PNM_PP(IBRA,IKET,0)
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=PNM_PM(IBRA-2*LDBASE,IKET,1)
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.GT.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=PNM_PP(IBRA-2*LDBASE,IKET-2*LDBASE,1)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        THE LOWER-LEFT 4X4 HFB BLOCK (-PAIRING DELTA^*)
C=======================================================================
C
      DO IBRA=1,4*LDBASE
         DO IKET=1,4*LDBASE
C
            NCOUNT=IBRA+4*LDBASE+((16*LDBASE-IKET)*(IKET-1))/2
C UPPER-LEFT DELTA
            IF (IBRA.LE.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *
     *          CELMTS(NCOUNT)=-CONJG(DNM_PP(IBRA,IKET,0))
C LOWER-LEFT DELTA
            IF (IBRA.GT.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *
     *          CELMTS(NCOUNT)=-CONJG(DNM_PM(IBRA-2*LDBASE,IKET,1))
C UPPER-RIGHT DELTA
            IF (IBRA.LE.2*LDBASE.AND.IKET.GT.2*LDBASE)
     *
     *          CELMTS(NCOUNT)=-CONJG(DNM_PM(IBRA,IKET-2*LDBASE,0))
C LOWER-RIGHT DELTA
            IF (IBRA.GT.2*LDBASE.AND.IKET.GT.2*LDBASE)
     *
     *          CELMTS(NCOUNT)=
     *                     -CONJG(DNM_PP(IBRA-2*LDBASE,IKET-2*LDBASE,1))
C
         END DO
      END DO
C
C=======================================================================
C        THE LOWER-RIGHT 4X4 HFB BLOCK (-HF HAMILTONIAN^*)
C=======================================================================
C
      DO IBRA=1,4*LDBASE
         DO IKET=1,4*LDBASE
C
            IF (IBRA.GE.IKET) THEN
C
                NCOUNT=IBRA+4*LDBASE+((16*LDBASE-(IKET+4*LDBASE))
     *                                             *(IKET+4*LDBASE-1))/2
C
                IF (IBRA.LE.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=-CONJG(PNM_PP(IBRA,IKET,0))
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=-CONJG(PNM_PM(IBRA-2*LDBASE,IKET,1))
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.GT.2*LDBASE)
     *
     *              CELMTS(NCOUNT)=
     *                     -CONJG(PNM_PP(IBRA-2*LDBASE,IKET-2*LDBASE,1))
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         SUBTRACTING THE FERMI ENERGY TERM FROM THE MEAN FIELD
C=======================================================================
C
      DO IBRA=1,8*LDBASE
C
         IKET=IBRA
C
         NCOUNT=IBRA+((16*LDBASE-IKET)*(IKET-1))/2
C
         IF (IBRA.LE.4*LDBASE)
     *
     *       CELMTS(NCOUNT)=CELMTS(NCOUNT)-EFERMI
C
         IF (IBRA.GT.4*LDBASE)
     *
     *       CELMTS(NCOUNT)=CELMTS(NCOUNT)+EFERMI
C
      END DO
C
C=======================================================================
C         DETERMINING THE HFB MEAN-FIELD EIGENSTATES AND SPECTRUM
C=======================================================================
C
C     IF (IABS(IDSIZB).EQ.1.OR.IMFHFB.EQ.1.OR.ITWOBA.EQ.1) THEN
C
C         IF (ITWOBA.EQ.1) THEN
C
C             LIMPAR=1
C         ELSE
C             LIMPAR=0
C
C         END IF
C
C         CALL DIASIZ(ICHARG,LIMPAR,ECUTOF,LDMEFI,ISAOCC)
C
C     END IF
C
      IF (ITWOBA.NE.1) THEN
C
          IF (LIMQUA.EQ.1) THEN
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE SPECTRUM  BELOW
C          THE ENERGY CUTOF WILL BE USED.
C=======================================================================
C
              LDQUAP=0
C
              EIGMIN=EFERMI-ECUTOF
              EIGMAX=0.0D0
C
              CALL DIAMAT(CELMTS,EQUHFB,EWAHFB,8*LDBASE,8*NDBASE,LDQUAP)
C
          ELSE
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE LOWER  HALF  OF
C          THE SPECTRUM (NEGATIVE QUASIPARTICLE ENERGIES) WILL BE  USED.
C          THEREFORE, BELOW  WE  REQUEST ONLY HALF OF EIGENVECTORS.
C=======================================================================
C
              LDQUAP=4*LDBASE
C
              CALL DIAMAT(CELMTS,EQUHFB,EWAHFB,8*LDBASE,8*NDBASE,LDQUAP)
C
          END IF
C
      ELSE
C
C=======================================================================
C          CALLING THE TWO-BASIS ROUTINE.
C=======================================================================
C
C         CALL TWOSIZ(CELMTS,EQUHFB,EWAHFB,LDMEFI,EFERMI)
C
C         LDQUAP=LDMEFI
C
      END IF
C
C=======================================================================
C         DETERMINING THE ORDERED QUASIPARTICLE SPECTRUM
C=======================================================================
C
      IORDER=0
C
      DO ISTATE=1,LDQUAP
C
         IORDER=IORDER+1
         NORDER(IORDER)=IORDER
         EORDER(IORDER)=-EQUHFB(ISTATE)
         NSTATE(IORDER)=ISTATE
C
      END DO
C
      LDORDE=IORDER
C
      CALL ORDER1(EORDER,NORDER,LDORDE)
C
C=======================================================================
C         LOOP OVER ORDERED QUASIPARTICLE STATES
C=======================================================================
C
      INCORR=0
C
      IDSTAT=0
C
      DO IALLST=1,LDORDE
C
         ISTATE=NSTATE(NORDER(IALLST))
C
C=======================================================================
C        CALCULATING THE NORMS OF THE "FIRST" COMPONENTS
C=======================================================================
C
         VORDE0=0.0D0
         VORDE1=0.0D0
         VORDEN=0.0D0
         VORDEP=0.0D0
         PORDER=0.0D0
C
         DO IBASE=1,LDBASE
C
            VORDE0=VORDE0+ ABS(EWAHFB(IBASE         ,ISTATE))**2
            VORDE0=VORDE0+ ABS(EWAHFB(IBASE+  LDBASE,ISTATE))**2
C
            PORDER=PORDER+(ABS(EWAHFB(IBASE         ,ISTATE))**2
     *                    +ABS(EWAHFB(IBASE+  LDBASE,ISTATE))**2)
     *                    *(1-2*IBAPAR(IBASE,1))
C
            VORDE1=VORDE1+ ABS(EWAHFB(IBASE+2*LDBASE,ISTATE))**2
            VORDE1=VORDE1+ ABS(EWAHFB(IBASE+3*LDBASE,ISTATE))**2
C
            PORDER=PORDER+(ABS(EWAHFB(IBASE+2*LDBASE,ISTATE))**2
     *                    +ABS(EWAHFB(IBASE+3*LDBASE,ISTATE))**2)
     *                    *(1-2*IBAPAR(IBASE,1))
C
            VORDEN=VORDEN+ ABS(EWAHFB(IBASE         ,ISTATE))**2
            VORDEN=VORDEN+ ABS(EWAHFB(IBASE+2*LDBASE,ISTATE))**2
C
            VORDEP=VORDEP+ ABS(EWAHFB(IBASE+  LDBASE,ISTATE))**2
            VORDEP=VORDEP+ ABS(EWAHFB(IBASE+3*LDBASE,ISTATE))**2
C
         END DO
C
         VORDER=VORDE0+VORDE1
C
C=======================================================================
C        CHECKING VALUES OF VORDER - JUST IN CASE. VALUES WHICH ARE OUT
C        OF BOUNDS UP TO A SMALL MACHINE-PRECISION NUMBER "EMACHI"  ARE
C        REPLACED BY THE VALUES AT BOUNDS.
C=======================================================================
C
         EMACHI=1.0D-10
C
         IF (VORDER.GT.1+EMACHI.OR.VORDER.LT. -EMACHI) THEN
C
             WRITE(NFIPRI,'(/,1X,20(1H/),
     *             '' ERROR IN NORMALIZATION OF'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' QUASIPARTICLES IN HFBMIZ.'',      9X,20(1H/),/,
     *             1X,20(1H/),
     *             '' IF THIS IS A ROUND-OFF PROBLEM'', 4X,20(1H/),/,
     *             1X,20(1H/),
     *             '' YOU MAY CHANGE VALUE OF EMACHI.'',3X,20(1H/),/,
     *             1X,20(1H/),'' ISTATE='',I5,''        '',2X,
     *                                           12X,20(1H/),/,
     *             1X,20(1H/),'' VORDER='',D25.18,
     *                                            2X,20(1H/),/)')
     *
     *             ISTATE,VORDER
C
             STOP 'ERROR IN NORMALIZATION OF QUASIPARTICLES IN HFBMIZ'
C
         END IF
C
         IF (VORDER.GT.1) VORDER=1
         IF (VORDER.LT.0) VORDER=0
C
C=======================================================================
C        CALCULATING THE EQUIVALENT SPECTRUM AND CUTTING-OFF THE STATES
C        WITH HIGH EQUIVALENT ENERGIES. FOR THE T WO-BASIS METHOD,  ALL
C        QUASIPARTICLE STATES ARE TAKEN INTO ACCOUNT (NO CUTOFF).
C=======================================================================
C
         HORDER=EORDER(IALLST)*(1-2*VORDER)
C
                          CORDER=HORDER+EFERMI
         IF (LAMCUT.EQ.1) CORDER=HORDER
C
         IF (CORDER.GT.ECUTOF.AND.ITWOBA.NE.1) GO TO 1
C
C=======================================================================
C        HERE WE DIVIDE THE SET OF QUASIPARICLE STATES INTO TWO  GROUPS
C        BY CHECKING IF THEY HAVE  DOMINANT  SIMPLEX=+i  OR  SIMPLEX=-i
C        COMPONENTS. THE DIVISION IS ARTIFICIAL; AND IT ONLY SERVES THE
C        PURPOSE OF CONSTRUCTING MATRICES ANALOGUOUS TO THOSE  USED  IN
C        THE CONSERVED-SIMPLEX CASE. THE SAME PRINCIPLE IS  IMPLEMENTED
C        TO DISTRIBUTE THE QUASIPARTICLES INTO NEUTRON AND PROTON BLOCKS
C=======================================================================
C
         IF (VORDE0.GT.VORDE1) THEN
C
             IREVER=0
         ELSE
             IREVER=1
C
         END IF
C
C=======================================================================
C
         IDSTAT(IREVER)=IDSTAT(IREVER)+1
C
         IF (IDSTAT(IREVER).GT.2*NDSTAT) THEN
C
             INCORR=1
             GO TO 1
C
         END IF
C
         KSTATE(IDSTAT(IREVER),IREVER)=ISTATE
C
C=======================================================================
C        SEE COMMENTS ABOUT ARRAYS "DEQUIV" AND "EEQUIV" IN "HFBSIM"
C=======================================================================
C
         DEQUIV(IDSTAT(IREVER),IREVER)=
     *                            SQRT(ABS(EORDER(IALLST)**2-HORDER**2))
C
         EEQUIV(IDSTAT(IREVER),IREVER)=HORDER+EFERMI
C
C=======================================================================
C        DEFINING THE QUASIPARTICLE ENERGIES AND OCCUPATIONS
C=======================================================================
C
         ENQUAP(IDSTAT(IREVER),IREVER)=EORDER(IALLST)
C
         V2QUAP(IDSTAT(IREVER),IREVER)=VORDER
C
         IF (VORDER.GT.0) THEN
C
             QPPARI(IDSTAT(IREVER),IREVER)=PORDER/VORDER
             QPSIMP(IDSTAT(IREVER),IREVER)=(VORDE0-VORDE1)/VORDER
         ELSE
             QPPARI(IDSTAT(IREVER),IREVER)=1.0D+10
             QPSIMP(IDSTAT(IREVER),IREVER)=1.0D+10
C
         END IF
C
    1    CONTINUE
C
      END DO
C
C=======================================================================
C         DEFINING NUMBERS OF QUASIPARTICLES KEPT AFTER THE CUT-OFF
C         ATTENTION: LOCATION 0 OF ARRAY "NUMBQP" IS USED TO COUNT
C                    ALL PROTON-NEUTRON MIXED QUASIPARTICLES.
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         NUMBQP(IREVER,0)=IDSTAT(IREVER)
C
      END DO
C
C=======================================================================
C         STOP IN CASE OF AN INCORRECT PHASE SPACE
C=======================================================================
C
      IF (INCORR.EQ.1) THEN
C
          WRITE(NFIPRI,'(/,                              1X,20(1H/),
     *              '' TOO LARGE PHASE-SPACE SIZE IN HFBMIZ'',
     *                                                   1X,20(1H/),/,
     *                 1X,20(1H/),
     *              ''        '',2X,3X,'' NDSTAT='',I4, 13X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' IREVER='',I2,3X,'' REQUIRES NUMBQP='',I4,
     *                                                   4X,20(1H/),/,
     *                 1X,20(1H/),
     *              '' INCREASE NDSTAT TO  2*NUMBQP OR MORE'',
     *                                                   1X,20(1H/),/)')
     *
     *           NDSTAT,(IREVER,NUMBQP(IREVER,0),IREVER=0,NDREVE)
C
          STOP ' TOO LARGE PHASE-SPACE SIZE IN HFBMIZ'
C
      END IF
C
C=======================================================================
C        CONSTRUCTING THE HFB A* AND B* MATRICES.
C=======================================================================
C
      DO IREVER=0,NDREVE
         DO ISTATE=1,NUMBQP(IREVER,0)
C
            JSTATE=KSTATE(ISTATE,IREVER)
C
            LSTATE=ISTATE+IREVER*NUMBQP(0,0)
C
            DO IBASE=1,2*LDBASE
C
               BWAQUZ(IBASE,LSTATE,0)=EWAHFB(IBASE,         JSTATE)
               BWAQUZ(IBASE,LSTATE,1)=EWAHFB(IBASE+2*LDBASE,JSTATE)
C
               AWAQUZ(IBASE,LSTATE,0)=EWAHFB(IBASE+4*LDBASE,JSTATE)
               AWAQUZ(IBASE,LSTATE,1)=EWAHFB(IBASE+6*LDBASE,JSTATE)
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         HERE QUASIPARTICLE STATES ARE BLOCKED
C=======================================================================
C
C     IREQPB=0
C     INUQPB=0
C     JNUQPB=0
C
C     ABLMUZ(:,:)=C_ZERO
C     BBLMUZ(:,:)=C_ZERO
C
C     IF (IABS(IDMIZB).EQ.1) THEN
C
C         CALL BLOSIZ(ICHARG,INSIZB,IDSIZB,INUQPB,IREQPB,IFIBLB,ISABLB)
C
C     STORE THE LABEL AND OCCUPATION NUMBER OF THE BLOCKED STATE
C
C         IF (IPRODD.EQ.1) THEN
C             CALL INIADD
C             BLOLAB(ICHARG)%N=INUQPB
C             BLOLAB(ICHARG)%IR=IREQPB
C         END IF
C
C         JSTATE=KSTATE(INUQPB,IREQPB)
C
C         LSTATE=INUQPB+IREQPB*NUMBQP(0,ICHARG)
C
C=======================================================================
C         HERE THE INVERTED QUASIPARTICLE REPLACES THE STANDARD ONE
C=======================================================================
C
C         DO IBASE=1,2*LDBASE
C
C            BWAQUZ(IBASE,LSTATE,0)=CONJG(EWAHFB(IBASE+2*LDBASE,JSTATE))
C            BWAQUZ(IBASE,LSTATE,1)=CONJG(EWAHFB(IBASE+3*LDBASE,JSTATE))
C
C            AWAQUZ(IBASE,LSTATE,0)=CONJG(EWAHFB(IBASE         ,JSTATE))
C            AWAQUZ(IBASE,LSTATE,1)=CONJG(EWAHFB(IBASE+  LDBASE,JSTATE))
C
C            BBLMUZ(IBASE,0)=CONJG(EWAHFB(IBASE+2*LDBASE,JSTATE))
C            BBLMUZ(IBASE,1)=CONJG(EWAHFB(IBASE+3*LDBASE,JSTATE))
C
C            ABLMUZ(IBASE,0)=CONJG(EWAHFB(IBASE         ,JSTATE))
C            ABLMUZ(IBASE,1)=CONJG(EWAHFB(IBASE+  LDBASE,JSTATE))
C
C         END DO
C
C         V2QUAP(INUQPB,IREQPB)=1.0D0-V2QUAP(INUQPB,IREQPB)
C
C         JNUQPB=INUQPB
C
C     END IF
C
C=======================================================================
      DEALLOCATE (CELMTS,EWAHFB)
C=======================================================================
C
      CALL CPUTIM('HFBMIZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE TWOSIG(IPARIT,CELMTS,EQUHFB,EWAHFB,EFERMI)
C=======================================================================
      USE ALLSIG
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DELMTS,DWAHFB,C_ZERO,AUXDUW
C=======================================================================
      ALLOCATABLE DWAHFB(:,:)
      ALLOCATABLE DELMTS(:)
      ALLOCATABLE AUXDUW(:,:)
C=======================================================================
      DIMENSION
     *          LEFIPT(0:NDREVE)
      DIMENSION
     *          EQUHFB(1:2*NDBASP)
      DIMENSION
     *          DQUHFB(1:2*NDBASP)
C=======================================================================
      COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
      COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
C=======================================================================
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('TWOSIG',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (DELMTS(1:(2*NDBASP+1)*NDBASP),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DELMTS','TWOSIG')
      ALLOCATE (DWAHFB(1:2*NDBASP,1:2*NDBASP),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DWAHFB','TWOSIG')
C=======================================================================
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HFB MATRIX IN THE  MEAN-FIELD
C         BASIS FOR THE CONSERVED-SIGNATURE&PARITY CASE
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      LDPARI=LDBASP(IPARIT)
      LEFIPT(0:NDREVE)=LDMEFG(IPARIT,0:NDREVE)
C
      LDMTOT=LEFIPT(1)+LEFIPT(0)
C=======================================================================
      ALLOCATE (AUXDUW(1:LDPARI,1:LDMTOT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXDUW','TWOSIG')
C=======================================================================
C         UNPACKING THE PAIRING PART OF THE HFB MATRIX
! [0,Delta_{+};-Delta_{-}^{*},0]
!(-Delta_{-}^{*})^{\dagger}=Delta_{+}
C=======================================================================
      AUXDUW(:,:)=C_ZERO
      DWAHFB(1:2*LDPARI,1:2*LDPARI)=C_ZERO
C
      DO IKET=1,LDPARI
         DO IBRA=LDPARI+1,2*LDPARI
            NCOUNT=IBRA+((4*LDPARI-IKET)*(IKET-1))/2
C
            DWAHFB(IBRA,IKET)=CELMTS(NCOUNT)
            DWAHFB(IKET,IBRA)=CONJG(DWAHFB(IBRA,IKET))
C
         END DO
      END DO
C=======================================================================
C         CONSTRUCTING THE HFB MATRIX IN THE MEAN-FIELD BASIS
C=======================================================================
C         FIRST WE CALCULATE    DELTA * U^*
C=======================================================================
C Delta_{+}*U_{-}^{*}=DW(1:L,1+L:2L)*EW^*(1:L,1:LDM(1),1)
      AUXDUW(1:LDPARI,1+LEFIPT(0):LDMTOT)=
     *       MATMUL(DWAHFB(1       :  LDPARI,1+LDPARI:2*LDPARI),
     *        CONJG(EWASIG(1:LDPARI,1:LEFIPT(1),IPARIT,1)))
C-Delta_{-}^{*}*U_{+}=DW(1+L:2L,1:L)*EW(1:L,1:LDM(0),0)
      AUXDUW(1:LDPARI,1          :LEFIPT(0))=
     *       MATMUL(DWAHFB(1+LDPARI:2*LDPARI,1       :  LDPARI),
     *              EWASIG(1:LDPARI,1:LEFIPT(0),IPARIT,0))
C=======================================================================
C         NEXT WE CALCULATE  U^+ * DELTA * U^*
C         THE RESULTS ARE STORED IN THE UPPER ROWS OF THE HFB MATRIX
C=======================================================================
C U_{+}^{\dagger}*Delta_{+}*U_{-}^{*}=[EW^+(1:L,1:LDM(0),0)]*[DW(1:L,1+L:2L)*EW(1:L,1:LDM(1),1)]
      DWAHFB(1:2*LDPARI,1:2*LDPARI)=C_ZERO
C
      DWAHFB(1          :LEFIPT(0),1+LEFIPT(0):LDMTOT)=
     * MATMUL(CONJG(TRANSPOSE(EWASIG(1:LDPARI,1:LEFIPT(0),IPARIT,0))),
     *       AUXDUW(1:LDPARI,1+LEFIPT(0):LDMTOT))
C U_{-}^{t}*(-Delta_{-}^{*})*U_{+}   =[EW^T(1:L,1:LDM(1),1)]*[DW(1+L:2L,1:L)*EW(1:L,1:LDM(0),0)]
      DWAHFB(1+LEFIPT(0):LDMTOT,   1          :LEFIPT(0))=
     * MATMUL(      TRANSPOSE(EWASIG(1:LDPARI,1:LEFIPT(1),IPARIT,1)),
     *       AUXDUW(1:LDPARI,1          :LEFIPT(0)))
C put E-Lmbda to diagonal
      DO IREVER=0,NDREVE
         DO ISTATE=1,LEFIPT(IREVER)
            IF(IREVER.EQ.0)THEN
               DWAHFB(ISTATE,ISTATE)
     *       =(SPESVG(ISTATE,IPARIT,IREVER)-EFERMI)
            ELSE
               DWAHFB(ISTATE+LEFIPT(0),ISTATE+LEFIPT(0))
     * =-CONJG(SPESVG(ISTATE,IPARIT,IREVER)-EFERMI)
            END IF
         END DO
      END DO
C=======================================================================
C         PACKING THE HFB MATRIX IN THE MEAN-FIELD BASIS
C=======================================================================
C
      DO JSTATE=1,LDMTOT
         DO ISTATE=1,LDMTOT
C
            IF (JSTATE.GE.ISTATE) THEN
C
                NCOUNT=JSTATE+((2*LDMTOT-ISTATE)*(ISTATE-1))/2
C
                DELMTS(NCOUNT)=DWAHFB(JSTATE,ISTATE)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE LOWER  HALF  OF
C          THE SPECTRUM (NEGATIVE QUASIPARTICLE ENERGIES) WILL BE  USED.
C          THEREFORE, BELOW  WE  REQUEST ONLY HALF OF EIGENVECTORS.
C=======================================================================
C
      CALL DIAMAT(DELMTS,DQUHFB,DWAHFB,LDMTOT,2*NDBASP,LDMTOT)
C
C=======================================================================
C         REBUILDING  THE  HFB  MATRICES  OF  QUASIPARTICLE  STATES  AND
C         QUASIPARTICLE ENERGIES IN THE HO BASIS
C=======================================================================
C
      EWAHFB(1:2*LDPARI,1:LDMTOT)=C_ZERO
C
      EWAHFB(1:LDPARI,1:LDMTOT)=
     *       MATMUL(EWASIG(1:LDPARI,1:LEFIPT(0),IPARIT,0),
     *       DWAHFB(1:LEFIPT(0),1:LDMTOT))
C
      EWAHFB(1+LDPARI:2*LDPARI,1:LDMTOT)=
     *       MATMUL(CONJG(EWASIG(1:LDPARI,1:LEFIPT(1),IPARIT,1)),
     *       DWAHFB(1+LEFIPT(0):LDMTOT,1:LDMTOT))
C
      EQUHFB(1:LDMTOT)=DQUHFB(1:LDMTOT)
C=======================================================================
C FIND THE NUMBER OF STATES IN EACH SIMPLEX BLOCK IF THEY ARE DIFFERENT
      IF(LEFIPT(0).NE.LEFIPT(1))THEN
         ISTATE=1
         LHALFP=0
         DO WHILE(DQUHFB(ISTATE).LT.0.0d0)
            LHALFP=LHALFP+1
            ISTATE=ISTATE+1
         END DO
         LEFIPT(0)=LHALFP
         LEFIPT(1)=LDMTOT-LHALFP
         LDMEFG(IPARIT,0:NDREVE)=LEFIPT(0:NDREVE)
      END IF
C=======================================================================
      DEALLOCATE (DELMTS,DWAHFB,AUXDUW)
C=======================================================================
C
      CALL CPUTIM('TWOSIG',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TWOSIM(CELMTS,EQUHFB,EWAHFB,EFERMI)
C=======================================================================
      USE ALLSIM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DELMTS,DWAHFB,C_ZERO,AUXDUW
C=======================================================================
      ALLOCATABLE DWAHFB(:,:)
      ALLOCATABLE DELMTS(:)
      ALLOCATABLE AUXDUW(:,:)
C=======================================================================
      DIMENSION
     *          LDMEFI(0:NDREVE)
      DIMENSION
     *          EQUHFB(1:2*NDBASE)
      DIMENSION
     *          DQUHFB(1:2*NDBASE)
C=======================================================================
      COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
      COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
C=======================================================================
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('TWOSIM',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (DELMTS(1:(2*NDBASE+1)*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DELMTS','TWOSIM')
      ALLOCATE (DWAHFB(1:2*NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DWAHFB','TWOSIM')
C=======================================================================
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HFB MATRIX IN THE  MEAN-FIELD
C         BASIS FOR THE CONSERVED-SIMPLEX CASE
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      LDMEFI(0:NDREVE)=LDMEFM(0:NDREVE)
C
      LDMTOT=LDMEFI(1)+LDMEFI(0)
C=======================================================================
      ALLOCATE (AUXDUW(1:LDBASE,1:LDMTOT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXDUW','TWOSIM')
C=======================================================================
C         UNPACKING THE PAIRING PART OF THE HFB MATRIX
! [0,Delta_{+};-Delta_{-}^{*},0]
!(-Delta_{-}^{*})^{\dagger}=Delta_{+}
C=======================================================================
      AUXDUW(:,:)=C_ZERO
      DWAHFB(1:2*LDBASE,1:2*LDBASE)=C_ZERO
C
      DO IKET=1,LDBASE
         DO IBRA=LDBASE+1,2*LDBASE
            NCOUNT=IBRA+((4*LDBASE-IKET)*(IKET-1))/2
C
            DWAHFB(IBRA,IKET)=CELMTS(NCOUNT)
            DWAHFB(IKET,IBRA)=CONJG(DWAHFB(IBRA,IKET))
C
         END DO
      END DO
C=======================================================================
C         CONSTRUCTING THE HFB MATRIX IN THE MEAN-FIELD BASIS
C=======================================================================
C         FIRST WE CALCULATE    DELTA * U^*
C=======================================================================
C Delta_{+}*U_{-}^{*}=DW(1:L,1+L:2L)*EW^*(1:L,1:LDM(1),1)
      AUXDUW(1:LDBASE,1+LDMEFI(0):LDMTOT)=
     *       MATMUL(DWAHFB(1       :  LDBASE,1+LDBASE:2*LDBASE),
     *        CONJG(EWASIM(1:LDBASE,1:LDMEFI(1),1)))
C-Delta_{-}^{*}*U_{+}=DW(1+L:2L,1:L)*EW(1:L,1:LDM(0),0)
      AUXDUW(1:LDBASE,1          :LDMEFI(0))=
     *       MATMUL(DWAHFB(1+LDBASE:2*LDBASE,1       :  LDBASE),
     *              EWASIM(1:LDBASE,1:LDMEFI(0),0))
C=======================================================================
C         NEXT WE CALCULATE  U^+ * DELTA * U^*
C         THE RESULTS ARE STORED IN THE UPPER ROWS OF THE HFB MATRIX
C=======================================================================
C U_{+}^{\dagger}*Delta_{+}*U_{-}^{*}=[EW^+(1:L,1:LDM(0),0)]*[DW(1:L,1+L:2L)*EW(1:L,1:LDM(1),1)]
      DWAHFB(1:2*LDBASE,1:2*LDBASE)=C_ZERO
C
      DWAHFB(1          :LDMEFI(0),1+LDMEFI(0):LDMTOT)=
     *       MATMUL(CONJG(TRANSPOSE(EWASIM(1:LDBASE,1:LDMEFI(0),0))),
     *       AUXDUW(1:LDBASE,1+LDMEFI(0):LDMTOT))
C U_{-}^{t}*(-Delta_{-}^{*})*U_{+}   =[EW^T(1:L,1:LDM(1),1)]*[DW(1+L:2L,1:L)*EW(1:L,1:LDM(0),0)]
      DWAHFB(1+LDMEFI(0):LDMTOT,   1          :LDMEFI(0))=
     *       MATMUL(      TRANSPOSE(EWASIM(1:LDBASE,1:LDMEFI(1),1)),
     *       AUXDUW(1:LDBASE,1          :LDMEFI(0)))
C put E-Lmbda to diagonal
      DO IREVER=0,NDREVE
         DO ISTATE=1,LDMEFI(IREVER)
            IF(IREVER.EQ.0)THEN
               DWAHFB(ISTATE,ISTATE)
     *       =(SPESVM(ISTATE,IREVER)-EFERMI)
            ELSE
               DWAHFB(ISTATE+LDMEFI(0),ISTATE+LDMEFI(0))
     * =-CONJG(SPESVM(ISTATE,IREVER)-EFERMI)
            END IF
         END DO
      END DO
C=======================================================================
C         PACKING THE HFB MATRIX IN THE MEAN-FIELD BASIS
C=======================================================================
C
      DO JSTATE=1,LDMTOT
         DO ISTATE=1,LDMTOT
C
            IF (JSTATE.GE.ISTATE) THEN
C
                NCOUNT=JSTATE+((2*LDMTOT-ISTATE)*(ISTATE-1))/2
C
                DELMTS(NCOUNT)=DWAHFB(JSTATE,ISTATE)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE LOWER  HALF  OF
C          THE SPECTRUM (NEGATIVE QUASIPARTICLE ENERGIES) WILL BE  USED.
C          THEREFORE, BELOW  WE  REQUEST ONLY HALF OF EIGENVECTORS.
C=======================================================================
C
      CALL DIAMAT(DELMTS,DQUHFB,DWAHFB,LDMTOT,2*NDBASE,LDMTOT)
C
C=======================================================================
C         REBUILDING  THE  HFB  MATRICES  OF  QUASIPARTICLE  STATES  AND
C         QUASIPARTICLE ENERGIES IN THE HO BASIS
C=======================================================================
C
      EWAHFB(1:2*LDBASE,1:LDMTOT)=C_ZERO
C
      EWAHFB(1:LDBASE,1:LDMTOT)=
     *       MATMUL(EWASIM(1:LDBASE,1:LDMEFI(0),0),
     *       DWAHFB(1:LDMEFI(0),1:LDMTOT))
C
      EWAHFB(1+LDBASE:2*LDBASE,1:LDMTOT)=
     *       MATMUL(CONJG(EWASIM(1:LDBASE,1:LDMEFI(1),1)),
     *       DWAHFB(1+LDMEFI(0):LDMTOT,1 :LDMTOT))
C
      EQUHFB(1:LDMTOT)=DQUHFB(1:LDMTOT)
C=======================================================================
      IF(LDMEFI(0).NE.LDMEFI(1))THEN!FIND orbit number in case of unbalance simplex block
         ISTATE=1
         LHALFP=0
         DO WHILE(DQUHFB(ISTATE).LT.0.0d0)
            LHALFP=LHALFP+1
            ISTATE=ISTATE+1
         END DO
         LDMEFI(0)=LHALFP
         LDMEFI(1)=LDMTOT-LHALFP
         LDMEFM(0:NDREVE)=LDMEFI(0:NDREVE)
      END IF
C=======================================================================
      DEALLOCATE (DELMTS,DWAHFB,AUXDUW)
C=======================================================================
C
      CALL CPUTIM('TWOSIM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TWOSIQ(IPARIT,CELMTS,EQUHFB,EWAHFB,EFERMI)
C Parity iteration will be done in hfbsiq
C LEFIPT=LDMEFI(IPARIT)
C EQUHFB=PQUHFB(1:2*NDBASP,IPARIT)
C EWAHFB=PWAHFB(1:4*NDBASP,1:4*NDBASP,IPARIT)
C=======================================================================
      USE ALLSIQ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DELMTS,DWAHFB,C_ZERO
C=======================================================================
      ALLOCATABLE DWAHFB(:,:)
      ALLOCATABLE DELMTS(:)
C=======================================================================
      DIMENSION
     *          EQUHFB(1:2*NDBASP)
      DIMENSION
     *          DQUHFB(1:2*NDBASP)
C=======================================================================
      COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
      COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
C=======================================================================
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENP/ LDBASP(0:NDPARI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('TWOSIQ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (DELMTS(1:(4*NDBASP+1)*2*NDBASP),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DELMTS','TWOSIQ')
      ALLOCATE (DWAHFB(1:4*NDBASP,1:4*NDBASP),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DWAHFB','TWOSIQ')
C=======================================================================
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HFB MATRIX IN THE  MEAN-FIELD
C         BASIS FOR THE CONSERVED-PARITY CASE
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      LDPARI=LDBASP(IPARIT)
C
      LEFIPT=LDMEFQ(IPARIT)
C=======================================================================
C         UNPACKING THE PAIRING PART OF THE HFB MATRIX
C=======================================================================
C
      DO IKET=1,2*LDPARI
         DO IBRA=2*LDPARI+1,4*LDPARI
C
            NCOUNT=IBRA+((8*LDPARI-IKET)*(IKET-1))/2
C
            DWAHFB(IBRA,IKET)=CELMTS(NCOUNT)
            DWAHFB(IKET,IBRA)=CONJG(DWAHFB(IBRA,IKET))
C
         END DO
      END DO
C
C=======================================================================
C         CONSTRUCTING THE HFB MATRIX IN THE MEAN-FIELD BASIS
C=======================================================================
C         FIRST WE CALCULATE    DELTA * U^*
C         THE RESULTS ARE STORED IN THE LOWER ROWS OF THE HFB MATRIX
C=======================================================================
C
      DO IBRA=1,2*LDPARI
         DO ISTATE=1,LEFIPT
C
            DWAHFB(IBRA+2*LDPARI,ISTATE+LEFIPT)=C_ZERO
C
            DO IMID=1,2*LDPARI
C
               DWAHFB(IBRA+2*LDPARI,ISTATE+LEFIPT)
     *        =DWAHFB(IBRA+2*LDPARI,ISTATE+LEFIPT)
     *        +DWAHFB(IBRA,IMID+2*LDPARI)
     *        *CONJG(EWASIQ(IMID,ISTATE,IPARIT))
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         NEXT WE CALCULATE  U^+ * DELTA * U^*
C         THE RESULTS ARE STORED IN THE UPPER ROWS OF THE HFB MATRIX
C=======================================================================
C
      DO JSTATE=1,LEFIPT
         DO ISTATE=1,LEFIPT
C
            DWAHFB(JSTATE,ISTATE       )=C_ZERO
            DWAHFB(JSTATE,ISTATE+LEFIPT)=C_ZERO
C
            DO IMID=1,2*LDPARI
C
               DWAHFB(JSTATE,ISTATE+LEFIPT)
     *        =DWAHFB(JSTATE,ISTATE+LEFIPT)
     *        +CONJG(EWASIQ(IMID,JSTATE,IPARIT))
     *        *DWAHFB(IMID+2*LDPARI,ISTATE+LEFIPT)
C
            END DO
C
         END DO
C
         DWAHFB(JSTATE,JSTATE)=SPESVQ(JSTATE,IPARIT)-EFERMI
C
      END DO
C
C=======================================================================
C         THEN WE CALCULATE LOWER ROWS OF THE HFB MATRIX
C=======================================================================
C
      DO JSTATE=1,LEFIPT
         DO ISTATE=1,LEFIPT
C
            DWAHFB(JSTATE+LEFIPT,ISTATE       )
     *                             =-CONJG(DWAHFB(JSTATE,ISTATE+LEFIPT))
C
            DWAHFB(JSTATE+LEFIPT,ISTATE+LEFIPT)
     *                             =-CONJG(DWAHFB(JSTATE,ISTATE       ))
C
         END DO
      END DO
C
C=======================================================================
C         PACKING THE HFB MATRIX IN THE MEAN-FIELD BASIS
C=======================================================================
C
      DO JSTATE=1,2*LEFIPT
         DO ISTATE=1,2*LEFIPT
C
            IF (JSTATE.GE.ISTATE) THEN
C
                NCOUNT=JSTATE+((4*LEFIPT-ISTATE)*(ISTATE-1))/2
C
                DELMTS(NCOUNT)=DWAHFB(JSTATE,ISTATE)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE LOWER  HALF  OF
C          THE SPECTRUM (NEGATIVE QUASIPARTICLE ENERGIES) WILL BE  USED.
C          THEREFORE, BELOW  WE  REQUEST ONLY HALF OF EIGENVECTORS.
C=======================================================================
C
      CALL DIAMAT(DELMTS,DQUHFB,DWAHFB,2*LEFIPT,4*NDBASP,LEFIPT)
C
C=======================================================================
C         REBUILDING  THE  HFB  MATRICES  OF  QUASIPARTICLE  STATES  AND
C         QUASIPARTICLE ENERGIES IN THE HO BASIS
C=======================================================================
C
      DO JSTATE=1,LEFIPT
C
         DO IBRA=1,2*LDPARI
C
            EWAHFB(IBRA         ,JSTATE)=C_ZERO
            EWAHFB(IBRA+2*LDPARI,JSTATE)=C_ZERO
C
            DO ISTATE=1,LEFIPT
C
               EWAHFB(IBRA       ,JSTATE)=EWAHFB(IBRA       ,JSTATE)
     *        +EWASIQ(IBRA,ISTATE,IPARIT)*DWAHFB(ISTATE    ,JSTATE)
C
               EWAHFB(IBRA+2*LDPARI,JSTATE)=EWAHFB(IBRA+2*LDPARI,JSTATE)
     *  +CONJG(EWASIQ(IBRA,ISTATE,IPARIT))*DWAHFB(ISTATE+LEFIPT ,JSTATE)
C
            END DO
C
         END DO
C
         EQUHFB(JSTATE)=DQUHFB(JSTATE)
C
      END DO
C
C=======================================================================
      DEALLOCATE (DELMTS,DWAHFB)
C=======================================================================
C
      CALL CPUTIM('TWOSIQ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE TWOSIZ(CELMTS,EQUHFB,EWAHFB,LDMEFI,EFERMI)
C=======================================================================
      USE ALLSIZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DELMTS,DWAHFB,C_ZERO
C=======================================================================
      ALLOCATABLE DWAHFB(:,:)
      ALLOCATABLE DELMTS(:)
C=======================================================================
      DIMENSION
     *          EQUHFB(1:4*NDBASE)
      DIMENSION
     *          DQUHFB(1:4*NDBASE)
C=======================================================================
      COMPLEX, DIMENSION(:), INTENT(INOUT) :: CELMTS
      COMPLEX, DIMENSION(:,:), INTENT(INOUT) :: EWAHFB
C=======================================================================
      COMMON
     *       /SIZSPE/ SPESIZ(1:4*NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('TWOSIZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (DELMTS(1:(4*NDBASE+1)*2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DELMTS','TWOSIZ')
      ALLOCATE (DWAHFB(1:4*NDBASE,1:4*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DWAHFB','TWOSIZ')
C=======================================================================
C
C=======================================================================
C         THIS SUBROUTINE DIAGONALIZES THE HFB MATRIX IN THE  MEAN-FIELD
C         BASIS FOR THE NO-SYMMETRY CASE
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C         UNPACKING THE PAIRING PART OF THE HFB MATRIX
C=======================================================================
C
      DO IKET=1,2*LDBASE
         DO IBRA=2*LDBASE+1,4*LDBASE
C
            NCOUNT=IBRA+((8*LDBASE-IKET)*(IKET-1))/2
C
            DWAHFB(IBRA,IKET)=CELMTS(NCOUNT)
            DWAHFB(IKET,IBRA)=CONJG(DWAHFB(IBRA,IKET))
C
         END DO
      END DO
C
C=======================================================================
C         CONSTRUCTING THE HFB MATRIX IN THE MEAN-FIELD BASIS
C=======================================================================
C         FIRST WE CALCULATE    DELTA * U^*
C         THE RESULTS ARE STORED IN THE LOWER ROWS OF THE HFB MATRIX
C=======================================================================
C
      DO IBRA=1,2*LDBASE
         DO ISTATE=1,LDMEFI
C
            DWAHFB(IBRA+2*LDBASE,ISTATE+LDMEFI)=C_ZERO
C
            DO IMID=1,2*LDBASE
C
               DWAHFB(IBRA+2*LDBASE,ISTATE+LDMEFI)
     *        =DWAHFB(IBRA+2*LDBASE,ISTATE+LDMEFI)
     *        +DWAHFB(IBRA,IMID+2*LDBASE)
     *        *CONJG(EWASIZ(IMID,ISTATE))
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         NEXT WE CALCULATE  U^+ * DELTA * U^*
C         THE RESULTS ARE STORED IN THE UPPER ROWS OF THE HFB MATRIX
C=======================================================================
C
      DO JSTATE=1,LDMEFI
         DO ISTATE=1,LDMEFI
C
            DWAHFB(JSTATE,ISTATE       )=C_ZERO
            DWAHFB(JSTATE,ISTATE+LDMEFI)=C_ZERO
C
            DO IMID=1,2*LDBASE
C
               DWAHFB(JSTATE,ISTATE+LDMEFI)
     *        =DWAHFB(JSTATE,ISTATE+LDMEFI)
     *        +CONJG(EWASIZ(IMID,JSTATE))
     *        *DWAHFB(IMID+2*LDBASE,ISTATE+LDMEFI)
C
            END DO
C
         END DO
C
         DWAHFB(JSTATE,JSTATE)=SPESIZ(JSTATE)-EFERMI
C
      END DO
C
C=======================================================================
C         THEN WE CALCULATE LOWER ROWS OF THE HFB MATRIX
C=======================================================================
C
      DO JSTATE=1,LDMEFI
         DO ISTATE=1,LDMEFI
C
            DWAHFB(JSTATE+LDMEFI,ISTATE       )
     *                             =-CONJG(DWAHFB(JSTATE,ISTATE+LDMEFI))
C
            DWAHFB(JSTATE+LDMEFI,ISTATE+LDMEFI)
     *                             =-CONJG(DWAHFB(JSTATE,ISTATE       ))
C
         END DO
      END DO
C
C=======================================================================
C         PACKING THE HFB MATRIX IN THE MEAN-FIELD BASIS
C=======================================================================
C
      DO JSTATE=1,2*LDMEFI
         DO ISTATE=1,2*LDMEFI
C
            IF (JSTATE.GE.ISTATE) THEN
C
                NCOUNT=JSTATE+((4*LDMEFI-ISTATE)*(ISTATE-1))/2
C
                DELMTS(NCOUNT)=DWAHFB(JSTATE,ISTATE)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C          CALLING THE DIAGONALIZATION ROUTINE. ONLY THE LOWER  HALF  OF
C          THE SPECTRUM (NEGATIVE QUASIPARTICLE ENERGIES) WILL BE  USED.
C          THEREFORE, BELOW  WE  REQUEST ONLY HALF OF EIGENVECTORS.
C=======================================================================
C
      CALL DIAMAT(DELMTS,DQUHFB,DWAHFB,2*LDMEFI,4*NDBASE,LDMEFI)
C
C=======================================================================
C         REBUILDING  THE  HFB  MATRICES  OF  QUASIPARTICLE  STATES  AND
C         QUASIPARTICLE ENERGIES IN THE HO BASIS
C=======================================================================
C
      DO JSTATE=1,LDMEFI
C
         DO IBRA=1,2*LDBASE
C
            EWAHFB(IBRA         ,JSTATE)=C_ZERO
            EWAHFB(IBRA+2*LDBASE,JSTATE)=C_ZERO
C
            DO ISTATE=1,LDMEFI
C
               EWAHFB(IBRA       ,JSTATE)=EWAHFB(IBRA       ,JSTATE)
     *        +      EWASIZ(IBRA,ISTATE) *DWAHFB(ISTATE       ,JSTATE)
C
               EWAHFB(IBRA+2*LDBASE,JSTATE)=EWAHFB(IBRA+2*LDBASE,JSTATE)
     *        +CONJG(EWASIZ(IBRA,ISTATE))*DWAHFB(ISTATE+LDMEFI,JSTATE)
C
            END DO
C
         END DO
C
         EQUHFB(JSTATE)=DQUHFB(JSTATE)
C
      END DO
C
C=======================================================================
      DEALLOCATE (DELMTS,DWAHFB)
C=======================================================================
C
      CALL CPUTIM('TWOSIZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE BLOSIG(ICHARG,INSIGB,IPSIGB,ISSIGB,IDSIGB,
     *                                       IREQPB,INUQPB,
     *                                       IFIBLB,ISABLB)
C=======================================================================
      USE ALLWAV
      USE ALLQUA
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          OVRLAP,QOVERL,WAVACT,WAVBLO,WAVAUX,C_ZERO
C
      DIMENSION
     *          OVRLAP(1:NDSTAT),QOVERL(0:NDRHFB),QNORMA(0:NDRHFB)
      DIMENSION
     *          WAVACT(1:NDBASE,0:NDREVE)
C
C=======================================================================
      COMMON
     *       /SIGSTA/ ISTSIG(1:NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /BLOWAV/ WAVBLO(1:2*NDBASE,0:NDISOS,0:NDREVE,1:NDBLOC)
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('BLOSIG',1)
C
C=======================================================================
C     THIS SUBROUTINE SELECTS THE QUASIPARTICLE STATE TO BE BLOCKED
C     IN THE CASE OF CONSERVED PARITY/SIGNATURE SYMMETRY
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C     INSIGB = THE NUMBER OF SINGLE-PARTICLE STATE THAT DEFINES  BLOCKED
C              QUASIPARTICLE STATE THROUGH THE LARGEST OVERLAP
C     IPSIGB = THE PARITY    OF THE ABOVE SINGLE-PARTICLE STATE
C     ISSIGB = THE SIGNATURE OF THE ABOVE SINGLE-PARTICLE STATE
C
C     INUQPB = THE NUMBER OF QUASIPARTICLE STATE TO BE BLOCKED
C
C     IREQPB = THE SIMPLEX OF THE ABOVE QUASIPARTICLE STATE
C     IFIBLB = USE  (1) OR NOT (0) THE SAVED SINGLE-PARTICLE  STATE
C              FOR BLOCKING
C     ISABLB = SAVE (1) OR NOT (0) THE  SINGLE-PARTICLE  STATE  FOR
C              LATER BLOCKING
C=======================================================================
C
C=======================================================================
C        DETERMINING THE SIMPLEX OF THE SINGLE-PARTICLE STATE
C=======================================================================
C
      IF (IPSIGB.EQ.0.AND.ISSIGB.EQ.0.OR.
     *    IPSIGB.EQ.1.AND.ISSIGB.EQ.1) THEN
C
          IRSIGB=0
      ELSE
          IRSIGB=1
C
      END IF
C
      JSTATE=ISTSIG(INSIGB,IPSIGB,IRSIGB)
C
C=======================================================================
C        DETERMINING THE SIMPLEX OF THE QUASIPARTICLE STATE
C=======================================================================
C
      IF (IDSIGB.EQ.1) THEN
C
          IRSIGC=IRSIGB
      ELSE
          IRSIGC=1-IRSIGB
C
      END IF
C
C=======================================================================
C         SAVING THE SINGLE-PARTICLE WAVE FUNCTION. FLAGS IDEBLO ARE
C         USED TO PASS INFORMATION TO  THE  SUBROUTINE  "RECORD"  ON
C         WHETHER THE MATRIX "WAVBLO" HAS BEEN INITIALISED.
C=======================================================================
C
      IF (ISABLB.EQ.1) THEN
C
          IDEBLO(ICHARG)=1
C
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
C
                WAVBLO(IBASE,ICHARG,IREVER,1)=
     *          WAVOCC(IBASE,JSTATE+IRSIGB*NUMBSP(0,ICHARG),IREVER)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         DEFINING THE SINGLE-PARTICLE WAVE FUNCTION, WHICH WILL BE USED
C         TO CALCULATE THE OVERLAP
C=======================================================================
C
      IF (IFIBLB.EQ.1) THEN
C
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
                WAVACT(IBASE,IREVER)=WAVBLO(IBASE,ICHARG,IREVER,1)
             END DO
          END DO
      ELSE
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
                WAVACT(IBASE,IREVER)=
     *          WAVOCC(IBASE,JSTATE+IRSIGB*NUMBSP(0,ICHARG),IREVER)
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         REVERSING THE TIME FOR THE SINGLE-PARTICLE WAVE FUNCTION
C=======================================================================
C          ATTENTION: FOR IDSIGB = -1, OPERATIONS BELOW WERE NOT CORRECT
C          NO. 3      THIS BUG WAS  CORRECTED  ON  04/11/10  IN  VERSION
C                     (2.48U).
C=======================================================================
C
      IF (IDSIGB.EQ.-1) THEN
C
         DO IBASE=1,LDBASE
C
             WAVAUX         = CONJG(WAVACT(IBASE,0))
             WAVACT(IBASE,0)=-CONJG(WAVACT(IBASE,1))
             WAVACT(IBASE,1)= WAVAUX
C
         END DO
C
      END IF
C
C=======================================================================
C        CALCULATING OVERLAP OF SINGLE-PARTICLE AND QUASIPARTICLE STATES
C=======================================================================
C        SEE COMMENTS IN SUBROUTINE "BLOSIZ"
C=======================================================================
C
      DO ISTATE=1,NUMBQP(IRSIGC,ICHARG)
C
         DO IREHFB=0,NDRHFB
C
            QOVERL(IREHFB)=C_ZERO
            QNORMA(IREHFB)=0.0D0
C
            IF (IREHFB.EQ.IRSIGC) THEN
C
                DO IBASE=1,LDBASE
C
C=======================================================================
C          ATTENTION: REFERENCES TO NATRICES "BWAQUA" AND "AWAQUA" BELOW
C          NO. 1      WERE INCORECTLY MADE WITH  THE  ARGUMENT  "IRSIGC"
C                     INSTEAD OF "IREHFB". AS A CONSEQUENCE, FOR  QUASI-
C                     PARTICLE STATES OF A PARTICLE TYPE ABOVE THE FERMI
C                     LEVEL, OVERLAPS WITH SINGLE-PARTICLE  STATES  WERE
C                     CALCULATED INCORRECTLY. THIS BUG  HAS  BEEN  FOUND
C                     BY GILLIS CARLSSON AND CORRECTED  ON  20/02/08  IN
C                     VERSION (2.33D).
C=======================================================================
C
                   QOVERL(IREHFB)=QOVERL(IREHFB)
     *                           +CONJG(WAVACT(IBASE,IRSIGB))
     *                           *BWAQUA(IBASE,ISTATE,IREHFB)
C
                   QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(BWAQUA(IBASE,ISTATE,IREHFB))**2
C
                END DO
C
            ELSE
C
                DO IBASE=1,LDBASE
C
C=======================================================================
C          ATTENTION: OVERLAPS  BELOW  WERE  CALCULATED  WITH   MATRICES
C          NO. 2      CONJG(AWAQUA) INSTEAD OF AWAQUA. AS A CONSEQUENCE,
C                     FOR QUASI-PARTICLE STATES OF A PARTICLE TYPE ABOVE
C                     THE FERMI LEVEL, INCORRECT  QUASI-PARTICLE  STATES
C                     WERE SELECTED FOR BLOCKING. THE  REASON  FOR  THIS
C                     CORRECTION IS UNKNOWN YET. THIS BUG HAS BEEN FOUND
C                     BY GILLIS CARLSSON AND CORRECTED  ON  20/02/08  IN
C                     VERSION (2.33D).
C=======================================================================
C
                   QOVERL(IREHFB)=QOVERL(IREHFB)
     *                           +CONJG(WAVACT(IBASE,IRSIGB))
     *                           *AWAQUA(IBASE,ISTATE,IREHFB)
C
                   QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(AWAQUA(IBASE,ISTATE,IREHFB))**2
C
                END DO
C
            END IF
C
            IF (QNORMA(IREHFB).GT.0.0D0) THEN
C
                QOVERL(IREHFB)=QOVERL(IREHFB)/SQRT(QNORMA(IREHFB))
            ELSE
                QOVERL(IREHFB)=C_ZERO
C
            END IF
C
         END DO
C
         IF (QNORMA(0).GT.QNORMA(1)) THEN
C
             OVRLAP(ISTATE)=QOVERL(0)
         ELSE
             OVRLAP(ISTATE)=QOVERL(1)
C
         END IF
C
      END DO
C
C=======================================================================
C        SELECTING QUASIPARTICLE STATE THAT HAS THE LARGEST OVERLAP WITH
C        THE GIVEN SINGLE-PARTICLE STATE
C=======================================================================
C
      IREQPB=IRSIGC
      INUQPB=1
C
      DO ISTATE=1,NUMBQP(IRSIGC,ICHARG)
C
         IF (ABS(OVRLAP(ISTATE)).GT.
     *       ABS(OVRLAP(INUQPB))) THEN
C
             INUQPB=ISTATE
C
         END IF
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('BLOSIG',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE BLOSIM(ICHARG,INSIMB,IRSIMB,IDSIMB,INUQPB,IREQPB,
     *                                              IFIBLB,ISABLB)
C=======================================================================
      USE ALLWAV
      USE ALLQUA
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          OVRLAP,QOVERL,WAVACT,WAVBLO,WAVAUX,C_ZERO
C
      DIMENSION
     *          OVRLAP(1:NDSTAT),QOVERL(0:NDRHFB),QNORMA(0:NDRHFB)
      DIMENSION
     *          WAVACT(1:NDBASE,0:NDREVE)
C
C=======================================================================
      COMMON
     *       /BLOWAV/ WAVBLO(1:2*NDBASE,0:NDISOS,0:NDREVE,1:NDBLOC)
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('BLOSIM',1)
C
C=======================================================================
C     THIS SUBROUTINE SELECTS THE QUASIPARTICLE STATE TO BE BLOCKED
C     IN CASE OF CONSERVED SIMPLEX SYMMETRY
C=======================================================================
C=======================================================================
C     INSIMB = THE NUMBER OF SINGLE-PARTICLE STATE THAT DEFINES  BLOCKED
C              QUASIPARTICLE STATE THROUGH THE LARGEST OVERLAP
C     IRSIMB = THE SIMPLEX OF THE ABOVE SINGLE-PARTICLE STATE
C
C     INUQPB = THE NUMBER OF QUASIPARTICLE STATE TO BE BLOCKED
C
C     IREQPB = THE SIMPLEX OF THE ABOVE QUASIPARTICLE STATE
C     IFIBLB = USE  (1) OR NOT (0) THE SAVED SINGLE-PARTICLE  STATE
C              FOR BLOCKING
C     ISABLB = SAVE (1) OR NOT (0) THE  SINGLE-PARTICLE  STATE  FOR
C              LATER BLOCKING
C=======================================================================
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        DETERMINING THE SIMPLEX OF THE QUASIPARTICLE STATE
C=======================================================================
C
      IF (IDSIMB.EQ.1) THEN
C
          IRSIMC=IRSIMB
      ELSE
          IRSIMC=1-IRSIMB
C
      END IF
C
C=======================================================================
C         SAVING THE SINGLE-PARTICLE WAVE FUNCTION. FLAGS IDEBLO ARE
C         USED TO PASS INFORMATION TO  THE  SUBROUTINE  "RECORD"  ON
C         WHETHER THE MATRIX "WAVBLO" HAS BEEN INITIALISED.
C=======================================================================
C
      IF (ISABLB.EQ.1) THEN
C
          IDEBLO(ICHARG)=1
C
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
C
                WAVBLO(IBASE,ICHARG,IREVER,1)=
     *          WAVOCC(IBASE,INSIMB+IRSIMB*NUMBSP(0,ICHARG),IREVER)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         DEFINING THE SINGLE-PARTICLE WAVE FUNCTION, WHICH WILL BE USED
C         TO CALCULATE THE OVERLAP
C=======================================================================
C
      IF (IFIBLB.EQ.1) THEN
C
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
C
                WAVACT(IBASE,IREVER)=WAVBLO(IBASE,ICHARG,IREVER,1)
C
             END DO
          END DO
      ELSE
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
C
                WAVACT(IBASE,IREVER)=
     *          WAVOCC(IBASE,INSIMB+IRSIMB*NUMBSP(0,ICHARG),IREVER)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         REVERSING THE TIME FOR THE SINGLE-PARTICLE WAVE FUNCTION
C=======================================================================
C          ATTENTION: FOR IDSIMB = -1, OPERATIONS BELOW WERE NOT CORRECT
C          NO. 3      THIS BUG WAS  CORRECTED  ON  04/11/10  IN  VERSION
C                     (2.48U).
C=======================================================================
C
      IF (IDSIMB.EQ.-1) THEN
C
         DO IBASE=1,LDBASE
C
             WAVAUX         = CONJG(WAVACT(IBASE,0))
             WAVACT(IBASE,0)=-CONJG(WAVACT(IBASE,1))
             WAVACT(IBASE,1)= WAVAUX
C
         END DO
C
      END IF
C
C=======================================================================
C        CALCULATING OVERLAP OF SINGLE-PARTICLE AND QUASIPARTICLE STATES
C=======================================================================
C        SEE COMMENTS IN SUBROUTINE "BLOSIZ"
C=======================================================================
C
      DO ISTATE=1,NUMBQP(IRSIMC,ICHARG)
C
         DO IREHFB=0,NDRHFB
C
            QOVERL(IREHFB)=C_ZERO
            QNORMA(IREHFB)=0.0D0
C
            IF (IREHFB.EQ.IRSIMC) THEN
C
                DO IBASE=1,LDBASE
C
C=======================================================================
C          ATTENTION: BUG CORRECTED ON 20/02/08 IN VERSION (2.33D),  SEE
C                     COMMENTS NO. 1 IN BLOSIG
C=======================================================================
C
                   QOVERL(IREHFB)=QOVERL(IREHFB)
     *                           +CONJG(WAVACT(IBASE,IRSIMB))
     *                           *BWAQUA(IBASE,ISTATE,IREHFB)
C
                   QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(BWAQUA(IBASE,ISTATE,IREHFB))**2
C
                END DO
C
            ELSE
C
                DO IBASE=1,LDBASE
C
C=======================================================================
C          ATTENTION: BUG CORRECTED ON 20/02/08 IN VERSION (2.33D),  SEE
C                     COMMENTS NO. 2 IN BLOSIG
C=======================================================================
C
                   QOVERL(IREHFB)=QOVERL(IREHFB)
     *                           +CONJG(WAVACT(IBASE,IRSIMB))
     *                           *AWAQUA(IBASE,ISTATE,IREHFB)
C
                   QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(AWAQUA(IBASE,ISTATE,IREHFB))**2
C
                END DO
C
            END IF
C
            IF (QNORMA(IREHFB).GT.0.0D0) THEN
C
                QOVERL(IREHFB)=QOVERL(IREHFB)/SQRT(QNORMA(IREHFB))
            ELSE
                QOVERL(IREHFB)=C_ZERO
C
            END IF
C
         END DO
C
         IF (QNORMA(0).GT.QNORMA(1)) THEN
C
             OVRLAP(ISTATE)=QOVERL(0)
         ELSE
             OVRLAP(ISTATE)=QOVERL(1)
C
         END IF
C
      END DO
C
C=======================================================================
C        SELECTING QUASIPARTICLE STATE THAT HAS THE LARGEST OVERLAP WITH
C        THE GIVEN SINGLE-PARTICLE STATE
C=======================================================================
C
      IREQPB=IRSIMC
      INUQPB=1
C
      DO ISTATE=1,NUMBQP(IRSIMC,ICHARG)
C
         IF (ABS(OVRLAP(ISTATE)).GT.
     *       ABS(OVRLAP(INUQPB))) THEN
C
             INUQPB=ISTATE
C
         END IF
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('BLOSIM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE BLOSIQ(ICHARG,INSIQB,IPSIQB,IDSIQB,INUQPB,IREQPB,
     *                                              IFIBLB,ISABLB)
C=======================================================================
      USE ALLWAV
      USE ALLQUZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          OVRLAP,QOVERL,WAVACT,WAVBLO,WAVAUX,C_ZERO
C
      DIMENSION
     *          OVRLAP(1:2*NDSTAT),QOVERL(0:NDRHFB),QNORMA(0:NDRHFB)
      DIMENSION
     *          WAVACT(1:NDBASE,0:NDREVE)
      DIMENSION
     *          INSIQB(1:NDBLOC),IPSIQB(1:NDBLOC),IDSIQB(1:NDBLOC)
C
C=======================================================================
      COMMON
     *       /BLOWAV/ WAVBLO(1:2*NDBASE,0:NDISOS,0:NDREVE,1:NDBLOC)
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /SIQSTA/ ISTSIQ(1:2*NDSTAT,0:NDPARI)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('BLOSIQ',1)
C
C=======================================================================
C     THIS SUBROUTINE SELECTS THE QUASIPARTICLE STATE TO BE BLOCKED
C     IN THE CASE OF NO SYMMETRY CONSERVED
C=======================================================================
C=======================================================================
C     INSIQB = THE NUMBER OF SINGLE-PARTICLE STATE THAT DEFINES  BLOCKED
C              QUASIPARTICLE STATE THROUGH THE LARGEST OVERLAP
C     IPSIQB = THE PARITY    OF THE ABOVE SINGLE-PARTICLE STATE
C
C     INUQPB = THE NUMBER OF QUASIPARTICLE STATE TO BE BLOCKED
C
C     IREQPB = THE SIMPLEX OF THE ABOVE QUASIPARTICLE STATE
C     IFIBLB = USE  (1) OR NOT (0) THE SAVED SINGLE-PARTICLE  STATE
C              FOR BLOCKING
C     ISABLB = SAVE (1) OR NOT (0) THE  SINGLE-PARTICLE  STATE  FOR
C              LATER BLOCKING
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      JSTATE=ISTSIQ(INSIQB(1),IPSIQB(1))
C
C=======================================================================
C         SAVING THE SINGLE-PARTICLE WAVE FUNCTION. FLAGS IDEBLO ARE
C         USED TO PASS INFORMATION TO  THE  SUBROUTINE  "RECORD"  ON
C         WHETHER THE MATRIX "WAVBLO" HAS BEEN INITIALISED.
C=======================================================================
C
      IF (ISABLB.EQ.1) THEN
C
          IDEBLO(ICHARG)=1
C
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
C
               WAVBLO(IBASE,ICHARG,IREVER,1)=WAVOCC(IBASE,JSTATE,IREVER)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         DEFINING THE SINGLE-PARTICLE WAVE FUNCTION, WHICH WILL BE USED
C         TO CALCULATE THE OVERLAP
C=======================================================================
C
      IF (IFIBLB.EQ.1) THEN
C
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
C
                WAVACT(IBASE,IREVER)=WAVBLO(IBASE,ICHARG,IREVER,1)
C
             END DO
          END DO
      ELSE
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBASE
C
                WAVACT(IBASE,IREVER)=WAVOCC(IBASE,JSTATE,IREVER)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         REVERSING THE TIME FOR THE SINGLE-PARTICLE WAVE FUNCTION
C=======================================================================
C          ATTENTION: FOR IDSIQB = -1, OPERATIONS BELOW WERE NOT CORRECT
C          NO. 3      THIS BUG WAS  CORRECTED  ON  04/11/10  IN  VERSION
C                     (2.48U).
C=======================================================================
C
      IF (IDSIQB(1).EQ.-1) THEN
C
         DO IBASE=1,LDBASE
C
             WAVAUX         = CONJG(WAVACT(IBASE,0))
             WAVACT(IBASE,0)=-CONJG(WAVACT(IBASE,1))
             WAVACT(IBASE,1)= WAVAUX
C
         END DO
C
      END IF
C
C=======================================================================
C        CALCULATING OVERLAP OF SINGLE-PARTICLE AND QUASIPARTICLE STATES
C=======================================================================
C        SEE COMMENTS IN SUBROUTINE "BLOSIZ"
C=======================================================================
C
      DO ISTATE=1,NUMBQP(0,ICHARG)+NUMBQP(1,ICHARG)
C
         DO IREHFB=0,NDRHFB
C
            QOVERL(IREHFB)=C_ZERO
            QNORMA(IREHFB)=0.0D0
C
            IF (IREHFB.EQ.0) THEN
C
                DO IREVER=0,NDREVE
C
                   DO IBASE=1,LDBASE
C
                      QOVERL(IREHFB)=QOVERL(IREHFB)
     *                              +CONJG(WAVACT(IBASE,IREVER))
     *                *(2*IREVER-1)*CONJG(BWAQUZ(IBASE,ISTATE,1-IREVER))
C
                      QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(BWAQUZ(IBASE,ISTATE,IREVER))**2
C
                   END DO
C
                END DO
C
            ELSE
C
                DO IREVER=0,NDREVE
C
                   DO IBASE=1,LDBASE
C
                      QOVERL(IREHFB)=QOVERL(IREHFB)
     *                              +CONJG(WAVACT(IBASE,IREVER))
     *                              *CONJG(AWAQUZ(IBASE,ISTATE,IREVER))
C
                      QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(AWAQUZ(IBASE,ISTATE,IREVER))**2
C
                   END DO
C
                END DO
C
            END IF
C
            IF (QNORMA(IREHFB).GT.0.0D0) THEN
C
                QOVERL(IREHFB)=QOVERL(IREHFB)/SQRT(QNORMA(IREHFB))
            ELSE
                QOVERL(IREHFB)=C_ZERO
C
            END IF
C
         END DO
C
         IF (QNORMA(0).GT.QNORMA(1)) THEN
C
             OVRLAP(ISTATE)=QOVERL(0)
         ELSE
             OVRLAP(ISTATE)=QOVERL(1)
C
         END IF
C
      END DO
C
C=======================================================================
C        SELECTING QUASIPARTICLE STATE THAT HAS THE LARGEST OVERLAP WITH
C        THE GIVEN SINGLE-PARTICLE STATE
C=======================================================================
C
      IREQPB=0
      INUQPB=1
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
            IF(ABS(OVRLAP(ISTATE+IREVER*NUMBQP(0,ICHARG))).GT.
     *         ABS(OVRLAP(INUQPB+IREQPB*NUMBQP(0,ICHARG))))
     *                                                           THEN
C
                INUQPB=ISTATE
                IREQPB=IREVER
C
            END IF
C
         END DO
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('BLOSIQ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
      SUBROUTINE BLOSIZ(ICHARG,INSIZB,IDSIZB,INUQPB,IREQPB,
     *                                IFIBLB,ISABLB,NUBLOC,
     *                                              ITWCEN)
C=======================================================================
      USE ALLWAV
      USE ALLQUZ
      USE TWCWAV
      USE TWCQUZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          OVRLAP,QOVERL,WAVACT,WAVBLO,WAVAUX,C_ZERO
C
      DIMENSION
     *          OVRLAP(1:2*NDSTAT),QOVERL(0:NDRHFB),QNORMA(0:NDRHFB)
      DIMENSION
     *          WAVACT(1:NDBASE,0:NDREVE)
C
C=======================================================================
      COMMON
     *       /BLOWAV/ WAVBLO(1:2*NDBASE,0:NDISOS,0:NDREVE,1:NDBLOC)
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
C
C=======================================================================
C
      CALL CPUTIM('BLOSIZ',1)
C
C=======================================================================
C     THIS SUBROUTINE SELECTS THE QUASIPARTICLE STATE TO BE BLOCKED
C     IN THE CASE OF NO SYMMETRY CONSERVED
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C     INSIZB = THE NUMBER OF SINGLE-PARTICLE STATE THAT DEFINES THE
C              BLOCKED QUASIPARTICLE STATE THROUGH LARGEST  OVERLAP
C     INUQPB = THE NUMBER OF  QUASIPARTICLE  STATE  TO  BE  BLOCKED
C     IREQPB = THE SIMPLEX OF THE ABOVE QUASIPARTICLE STATE
C     IFIBLB = USE  (1) OR NOT (0) THE SAVED SINGLE-PARTICLE  STATE
C              FOR BLOCKING
C     ISABLB = SAVE (1) OR NOT (0) THE  SINGLE-PARTICLE  STATE  FOR
C              LATER BLOCKING
C=======================================================================
C
C               WRITE (*,'(A8,3I3,3X,4I4,/,20X,4I4)') 'BLOSIZ-A',
C    *                          NUBLOC,-1,ICHARG,
C    *                          INSIZB,IDSIZB,INUQPB,IREQPB
C
C=======================================================================
C         SAVING THE SINGLE-PARTICLE WAVE FUNCTION. FLAGS IDEBLO ARE
C         USED TO PASS INFORMATION TO  THE  SUBROUTINE  "RECORD"  ON
C         WHETHER THE MATRIX "WAVBLO" HAS BEEN INITIALISED.
C         ATTENTION: THE CODE WILL STORE MATRIX "WAVBLO" UP  TO  THE
C         MAXIMUM INDEX "NUBLOC"  OF  SINGLE-PARTICLE  WAVEFUNCTIONS
C         USED FOR BLOCKING. IF FOR A SMALLER  INDEX  "NUBLOC",  THE
C         CORRESPONDING SINGLE-PARTICLE WAVEFUNCTION  IS  NOT  USED,
C         EMPTY VALUES OF THE MATRIX "WAVBLO" WILL BE STORED.
C=======================================================================
C
      IF (ISABLB.EQ.1) THEN
C
          IF (NUBLOC.GT.NDBLOC)
     *        STOP 'INCREASE NDBLOC IN BLOSIZ)'
C
          IDEBLO(ICHARG)=NUBLOC
C
          DO IREVER=0,NDREVE
C
             IF (ITWCEN.EQ.1) THEN
C
                 DO IBASE=1,LDBASE
C
                    WAVBLO(IBASE,ICHARG,IREVER,NUBLOC)=
     *              WAVOCC(IBASE,INSIZB,IREVER)
C
                 END DO
C
             ELSEIF (ITWCEN.EQ.2) THEN
C
                 DO IBASE=1,LDBTOT
C
                    WAVBLO(IBASE,ICHARG,IREVER,NUBLOC)=
     *              TWCOCC(IBASE,INSIZB,IREVER,ICHARG)
C
                 END DO
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C         DEFINING THE SINGLE-PARTICLE WAVE FUNCTION, WHICH WILL BE USED
C         TO CALCULATE THE OVERLAP
C=======================================================================
C
      IF (IFIBLB.EQ.1) THEN
C
          DO IREVER=0,NDREVE
             DO IBASE=1,LDBTOT
C
                WAVACT(IBASE,IREVER)=WAVBLO(IBASE,ICHARG,IREVER,NUBLOC)
C
             END DO
          END DO
      ELSE
          DO IREVER=0,NDREVE
             IF (ITWCEN.EQ.1) THEN
                 DO IBASE=1,LDBASE
C
                    WAVACT(IBASE,IREVER)=WAVOCC(IBASE,INSIZB,IREVER)
C
                 END DO
             ELSEIF (ITWCEN.EQ.2) THEN
                 DO IBASE=1,LDBTOT
C
                    WAVACT(IBASE,IREVER)=
     *              TWCOCC(IBASE,INSIZB,IREVER,ICHARG)
C
                 END DO
             END IF
          END DO
C
      END IF
C
C=======================================================================
C         REVERSING THE TIME FOR THE SINGLE-PARTICLE WAVE FUNCTION
C=======================================================================
C          ATTENTION: FOR IDSIZB = -1, OPERATIONS BELOW WERE NOT CORRECT
C          NO. 3      THIS BUG WAS  CORRECTED  ON  04/11/10  IN  VERSION
C                     (2.48U).
C=======================================================================
C
      IF (IDSIZB.EQ.-1) THEN
C
         DO IBASE=1,LDBTOT
C
             WAVAUX         = CONJG(WAVACT(IBASE,0))
             WAVACT(IBASE,0)=-CONJG(WAVACT(IBASE,1))
             WAVACT(IBASE,1)= WAVAUX
C
         END DO
C
      END IF
C
C=======================================================================
C        CALCULATING OVERLAP OF SINGLE-PARTICLE AND QUASIPARTICLE STATES
C=======================================================================
C        THE OVERLAP IS CALCULATED:
C        1.WITH THE  L O W E R  COMPONENT OF  THE  QUASIPARTICLE  STATE.
C          NOTE THAT THE CODE USES  THE  QUASIPARTICLE  STATES  FOR  THE
C          N E G A T I V E    QUASIPARTICLE   ENERGIES.  THEREFORE,  THE
C          LOWER COMPONENT EQUALS TO THE "A*" BOGOLYUBOV  MATRIX,  WHICH
C          FOR BROKEN (CONSERVED) SIMPLEX IS STORED IN AWAQUZ  (AWAQUA).
C          SINCE IN THE BCS APPROXIMATION COLUMNS OF  THE "A" BOGOLYUBOV
C          MATRIX ARE EIGENSTATES OF  THE  MEAN-FIELD  HAMILTONIAN,  THE
C          OVERLAPS MUST BE CALCULATED WITH CONJG(AWAQUZ),CONJG(AWAQUA).
C        2.WITH THE TIME-REVERSED  U P P E R  COMPONENT  OF  THE  QUASI-
C          PARTICLE STATE.
C          NOTE THAT THE CODE USES  THE  QUASIPARTICLE  STATES  FOR  THE
C          N E G A T I V E    QUASIPARTICLE   ENERGIES.  THEREFORE,  THE
C          UPPER COMPONENT EQUALS TO THE "B*" BOGOLYUBOV  MATRIX,  WHICH
C          FOR BROKEN (CONSERVED) SIMPLEX IS STORED IN BWAQUZ  (BWAQUA).
C          SINCE IN THE BCS APPROXIMATION COLUMNS OF THE "B*" BOGOLYUBOV
C          MATRIX ARE EIGENSTATES OF  THE  MEAN-FIELD  HAMILTONIAN,  THE
C          OVERLAPS MUST BE CALCULATED WITH BWAQUZ,BWAQUA. IN  ADDITION,
C          THE TIME REVERSAL REQUIRES THE COMPLEX CONJUGATION,  FLIPPING
C          THE SIMPLEX, AND MULTIPLYING ONE SIMPLEX COMPONENT BY "-1".
C=======================================================================
C
      DO ISTATE=1,NUMBQP(0,ICHARG)+NUMBQP(1,ICHARG)
C
         DO IREHFB=0,NDRHFB
C
            QOVERL(IREHFB)=C_ZERO
            QNORMA(IREHFB)=0.0D0
C
            IF (IREHFB.EQ.0) THEN
C
                DO IREVER=0,NDREVE
C
                IF (ITWCEN.EQ.1) THEN
C
                   DO IBASE=1,LDBASE
C
C=======================================================================
C          ATTENTION: UP TO VERSION 2.48T, BELOW, THE TIME  REVERSAL  OF
C                     "BWAQUZ" WAS NOT INCLUDED. THIS BUG WAS REMOVED ON
C                     06/11/10 IN VERSION 2.48U.
C=======================================================================
C
                      QOVERL(IREHFB)=QOVERL(IREHFB)
     *                              +CONJG(WAVACT(IBASE,IREVER))
     *                *(2*IREVER-1)*CONJG(BWAQUZ(IBASE,ISTATE,1-IREVER))
C
                      QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(BWAQUZ(IBASE,ISTATE,IREVER))**2
C
                   END DO
C
                ELSEIF (ITWCEN.EQ.2) THEN
C
                   DO IBASE=1,LDBTOT
C
                      QOVERL(IREHFB)=QOVERL(IREHFB)
     *                              +CONJG(WAVACT(IBASE,IREVER))
     *                *(2*IREVER-1)*CONJG(BWATWC(IBASE,ISTATE,1-IREVER))
C
                      QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(BWATWC(IBASE,ISTATE,IREVER))**2
C
                   END DO
C
                END IF
C
                END DO
C
            ELSE
C
                DO IREVER=0,NDREVE
C
                IF (ITWCEN.EQ.1) THEN
C
                   DO IBASE=1,LDBASE
C
C=======================================================================
C          ATTENTION: BETWEEN VERSION 2.33D AND 2.48T, BELOW THE COMPLEX
C                     CONJUGATION OF "AWAQUZ" WAS REMOVED TO  COMPENSATE
C                     FOR OTHER BUGS. THIS INCONSISTENCY WAS REMOVED  ON
C                     06/11/10 IN VERSION 2.48U.
C=======================================================================
C
                      QOVERL(IREHFB)=QOVERL(IREHFB)
     *                              +CONJG(WAVACT(IBASE,IREVER))
     *                              *CONJG(AWAQUZ(IBASE,ISTATE,IREVER))
C
                      QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(AWAQUZ(IBASE,ISTATE,IREVER))**2
C
                   END DO
C
                ELSEIF (ITWCEN.EQ.2) THEN
C
                   DO IBASE=1,LDBASE
C
                      QOVERL(IREHFB)=QOVERL(IREHFB)
     *                              +CONJG(WAVACT(IBASE,IREVER))
     *                              *CONJG(AWATWC(IBASE,ISTATE,IREVER))
C
                      QNORMA(IREHFB)=QNORMA(IREHFB)+
     *                               ABS(AWATWC(IBASE,ISTATE,IREVER))**2
C
                   END DO
C
                END IF
                END DO
C
            END IF
C
            IF (QNORMA(IREHFB).GT.0.0D0) THEN
C
                QOVERL(IREHFB)=QOVERL(IREHFB)/SQRT(QNORMA(IREHFB))
            ELSE
                QOVERL(IREHFB)=C_ZERO
C
            END IF
C
         END DO
C
         IF (QNORMA(0).GT.QNORMA(1)) THEN
C
             OVRLAP(ISTATE)=QOVERL(0)
         ELSE
             OVRLAP(ISTATE)=QOVERL(1)
C
         END IF
C
      END DO
C
C=======================================================================
C        SELECTING QUASIPARTICLE STATE THAT HAS THE LARGEST OVERLAP WITH
C        THE GIVEN SINGLE-PARTICLE STATE
C=======================================================================
C
      INUQPB=1
      IREQPB=0
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
            IF(ABS(OVRLAP(ISTATE+IREVER*NUMBQP(0,ICHARG))).GT.
     *         ABS(OVRLAP(INUQPB+IREQPB*NUMBQP(0,ICHARG)))) THEN
C
                INUQPB=ISTATE
                IREQPB=IREVER
C
            END IF
C
C           IF (ISTATE.LE.5)
C    *          WRITE (*,'(A8,3I3,3X,4I4,3X,2I4,2D15.6)') 'BLOSIZ-C',
C    *                          NUBLOC,-1,ICHARG,
C    *                          INSIZB,IDSIZB,INUQPB,IREQPB,
C    *                          ISTATE,IREVER,
C    *         ABS(OVRLAP(ISTATE+IREVER*NUMBQP(0,ICHARG))),
C    *         ABS(OVRLAP(INUQPB+IREQPB*NUMBQP(0,ICHARG)))
C
         END DO
C
      END DO
C
C               WRITE (*,'(A8,3I3,3X,4I4,3X,2I4)') 'BLOSIZ-B',
C    *                          NUBLOC,-1,ICHARG,
C    *                          INSIZB,IDSIZB,INUQPB,IREQPB,
C    *                          NUMBQP(0,ICHARG),NUMBQP(1,ICHARG)
C
C=======================================================================
C
      CALL CPUTIM('BLOSIZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CANQUA(MREVER,ICHARG,IMFHFB,IREQPB,
     *                  LIPNOX,PARLIX,DISLIX,ENESUM)
C=======================================================================
      USE MAT_PP
      USE MAR_PP
      USE PAIDEL
      USE ALLWAV
      USE CANBAS
      USE ALLQUA
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,EWAVEF,RELPHA
      COMPLEX
     *          C_ZERO,C_UNIT
      COMPLEX
     *          ABLQUA,BBLQUA
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE EWAVEF(:,:)
C=======================================================================
      DIMENSION
     *          V2WORK(1:NDBASE)
      DIMENSION
     *          CANDEL(1:NDBASE)
C=======================================================================
      COMMON
     *       /XBLQUA/ ABLQUA(1:NDBASE,0:NDREVE,0:NDISOS),
     *                BBLQUA(1:NDBASE,0:NDREVE,0:NDISOS)
      COMMON
     *       /CORPAR/ V_CORR(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /CAOCCU/ V2OCCU(1:2*NDBASE)
     *       /CAOCNP/ V2OCNP(1:4*NDBASE,0:NDISOS)
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIMSPE/ SPESIM(1:NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C=======================================================================
C
      CALL CPUTIM('CANQUA',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(WAVOCC)) THEN
          ALLOCATE (WAVOCC(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVOCC','CANQUA')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(RHO_PP)) THEN
          ALLOCATE (RHO_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('RHO_PP','CANQUA')
      END IF
      IF (.NOT. ALLOCATED(WAVCAN)) THEN
          ALLOCATE (WAVCAN(1:NDBASE,1:NDSTAT,0:NDREVE,0:NDISOS),
     *              STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVCAN','CANQUA')
      END IF
C
      IF (.NOT. ALLOCATED(V_CAN)) THEN
          ALLOCATE (V_CAN(1:NDSTAT,0:NDREVE,0:NDISOS), STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO(' V_CAN','CANQUA')
      END IF
C
      IF (.NOT. ALLOCATED(U_CAN)) THEN
          ALLOCATE (U_CAN(1:NDSTAT,0:NDREVE,0:NDISOS), STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO(' U_CAN','CANQUA')
      END IF
C=======================================================================
      ALLOCATE (CELMTS(1:((NDBASE+1)*NDBASE)/2),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','CANQUA')
      ALLOCATE (EWAVEF(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAVEF','CANQUA')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE DETERMINES THE CANONICAL BASIS
C        FOR THE CONSERVED SIMPLEX CASE
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
C=======================================================================
C        ATTENTION: IN CASE OF THE CONSERVED TIME-REVERSAL  SYMMETRY
C                   THIS SUBROUTINE IS CALLED WITH MREVER=0, AND THE
C                   DIAGONALIZATION IN THE TIME-REVERSED BLOCK  WILL
C                   NOT BE PERFORMED.
C=======================================================================
C
      ENESUM=0.0D0
C
      DO IREVER=0,MREVER
C
C=======================================================================
C        CALCULATING THE DENSITY MATRIX
C=======================================================================
C
         RHO_PP(:,:,IREVER)=C_ZERO
C
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
            CALL ZCOPY(LDBASE,BWAQUA(1,ISTATE,IREVER),1,
     *                        EWAVEF(1,ISTATE),1)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
            IF (IFTEMP.EQ.0) THEN
                CORECT=V_CORR(ISTATE,IREVER)
            ELSE
                CORECT=SQRT(1.0D0-FERMFN(ISTATE,ICHARG))
            END IF
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
            CALL ZDSCAL(LDBASE,CORECT,EWAVEF(1,ISTATE),1)
C
         END DO
C
         CALL ZGEMM('N','C',LDBASE,LDBASE,NUMBQP(IREVER,ICHARG),
     *                      C_UNIT,EWAVEF,NDBASE,EWAVEF,NDBASE,
     *                      C_ZERO,RHO_PP(1,1,IREVER),NDBASE)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
         IF (IFTEMP.EQ.1) THEN
C
             DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      RHO_PP(IBRA,IKET,IREVER)=RHO_PP(IBRA,IKET,IREVER)
     *                                +CONJG(AWAQUA(IBRA,ISTATE,IREVER))
     *                                *     (AWAQUA(IKET,ISTATE,IREVER))
     *                                           *FERMFN(ISTATE,ICHARG)
C
                   END DO
                END DO
C
             END DO
C
         END IF
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C           PREPARING THE DIAGONALIZATION OF THE DENSITY MATRIX.
C           DIAGONALIZATION OF MINUS DENSITY MATRIX ENSURES THAT
C           THE ORDER OF EIGENSTATES IS THE SAME AS IN THE  CASE
C           WHEN THE MEAN-FIELD HAMILTONIAN IS DIAGONALIZED.
C=======================================================================
C
         DO IBRA=1,LDBASE
            DO IKET=1,IBRA
C
               NCOUNT=IBRA+((2*LDBASE-IKET)*(IKET-1))/2
C
               CELMTS(NCOUNT)=-RHO_PP(IBRA,IKET,IREVER)
C
            END DO
         END DO
C
C=======================================================================
C           CALLING THE DIAGONALIZATION ROUTINE
C=======================================================================
C
         CALL DIAMAT(CELMTS,V2WORK,EWAVEF,LDBASE,NDBASE,LDBASE)
C
C=======================================================================
C           REVERTING TO THE CORRECT SIGNS OF THE OCCUPATION FACTORS
C           AND TRIMMING THE OUT-OF-BOUNDS VALUES.
C=======================================================================
C
         DO I_BASE=1,LDBASE
C
            V2WORK(I_BASE              )       =-V2WORK(I_BASE)
C
            IF ((1.0-V2WORK(I_BASE)).LT.1.E-14)
     *           V2WORK(I_BASE)=1.0
C
            IF ( V2WORK(I_BASE).LT.1.E-14)
     *           V2WORK(I_BASE)=0.0
C
            V2OCCU(I_BASE+IREVER*LDBASE)       = ABS(V2WORK(I_BASE))
            V2OCNP(I_BASE+IREVER*LDBASE,ICHARG)= ABS(V2WORK(I_BASE))
C
         END DO
C
C=======================================================================
C           ATTENTION: SINCE THE DENSITY MATRIX IS DETERMINED FROM  A
C                      LIMITED NUMBER OF  THE  QUASIPARTICLE  STATES,
C                      SMALL OCCUPATION NUMBERS CAN BE SPURIOUS.
C           ATTENTION: THE HFB SIGNS OF THE "V" FACTORS ARE  NOT  YET
C                      IMPLEMENTED.
C           ATTENTION: "ABS" AND "SIGN" BELOW SERVE AS  A  PROTECTION
C                      AGAINST VERY SMALL NEGATIVE NOISE  EIGENVALUES
C                      OF THE DENSITY MATRIX
C=======================================================================
C           ATTENTION: THE SIZE OF THE SINGLE PARTICLE SPACE  DEFINED
C                      BY THE "NUMBSP" ARRAYS IS  IRRELEVANT  IN  THE
C                      HFB METHOD, BECAUSE  THE  SPACE  IS  THEN  CUT
C                      ACCORDING TO THE CUTOFF ENERGY.  NEVERTHELESS,
C                      BELOW WE EXTRACT ONLY THOSE  CANONICAL  STATES
C                      WHICH FALL WITHIN THE WINDOWS DEFINED  BY  THE
C                      "NUMBSP" ARRAYS. THIS IS  DONE  FOR  THE  SOLE
C                      PURPOSE OF  RENDERING  THE  CANONICAL  SPECTRA
C                      ANALOGOUS TO SPECTRA USED BY THE CODE WHEN HFB
C                      IS NOT SOLVED.
C
C                      => TL 19/09/2012: For particle-number
C                         projection, we need all canonical states, for
C                         both neutrons and protons. Below is
C                         alternate code for storing canonical wfs, u-
C                         and v- amplitudes.
C=======================================================================
C
         ONEONE=1.0D0
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))
     *            =SQRT(ABS(V2WORK(ISTATE)))*SIGN(ONEONE,V2WORK(ISTATE))
C
         END DO
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE WAVE FUNCTIONS
C=======================================================================
C
         IF (IMFHFB.NE.1) THEN
C
             DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                DO IBASE=1,LDBASE
C
                  WAVOCC(IBASE,ISTATE+IREVER*NUMBSP(0,ICHARG),1-IREVER)=
     *                                                            C_ZERO
                  WAVOCC(IBASE,ISTATE+IREVER*NUMBSP(0,ICHARG),  IREVER)=
     *                                              EWAVEF(IBASE,ISTATE)
C
                END DO
C
             END DO
C
         END IF
C
C=======================================================================
C           CALCULATING THE CANONICAL SINGLE-PARTICLE ENERGIES
C=======================================================================
C
         CALL AVEQUA(SPESIM,BIG_PP(1,1,IREVER),EWAVEF)
C
C=======================================================================
C           CALCULATING THE SUM OF SINGLE-PARTICLE ENERGIES
C=======================================================================
C
         DO ISTATE=1,LDBASE
C
            ENESUM=ENESUM+V2WORK(ISTATE)*SPESIM(ISTATE)
C
         END DO
C
C=======================================================================
C           STORING THE CANONICAL ENERGIES AND OCCUPATION FACTORS
C=======================================================================
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
            IF (IMFHFB.NE.1)
     *      SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)=SPESIM(ISTATE)
            SPOCCU(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)=
     *      V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))**2
         END DO
C
C=======================================================================
C           CALCULATING PAIRING GAPS OF CANONICAL WAVE FUNCTIONS
C=======================================================================
C
         CALL AVEQUA(CANDEL,HAMIDE(1,1,IREVER),EWAVEF)
C
C=======================================================================
C           STORING CANONICAL WAVE FUNCTIONS,
C           CALCULATING AND STORING U- AND V-FACTORS
C=======================================================================
C
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
C           Compute and store u and v
C           Detect v^2=0 or 1 condition as set above
C
            IF( V2WORK(ISTATE) .EQ. 0.0d0) THEN
               V_CAN(ISTATE,IREVER,ICHARG)= 0.0d0
            ELSE
               V_CAN(ISTATE,IREVER,ICHARG)=
     *              (1-2*IREVER)*SQRT(ABS(V2WORK(ISTATE)))
            END IF
C
            IF( V2WORK(ISTATE) .EQ. 1.0d0) THEN
               U_CAN(ISTATE,IREVER,ICHARG)= 0.0d0
            ELSE
C              Gap determines sign of u
               U_CAN(ISTATE,IREVER,ICHARG)=
     *              SIGN(SQRT(1.0d0-ABS(V2WORK(ISTATE))),CANDEL(ISTATE))
            END IF
C
            WAVCAN(1:LDBASE,ISTATE,IREVER,ICHARG)=
     *           EWAVEF(1:LDBASE,ISTATE)
C
C           Fix phase of time-down canonical wave functions relative to
C           time-up ones (for pairing energy in projection)
            IF (IREVER.EQ.1) THEN
               RELPHA = SUM(WAVCAN(1:LDBASE,ISTATE,IREVER,ICHARG)
     *              *       WAVCAN(1:LDBASE,ISTATE,1-IREVER,ICHARG))
               RELPHA=RELPHA/ABS(RELPHA)
               WAVCAN(1:LDBASE,ISTATE,IREVER,ICHARG)=
     *              CONJG(RELPHA)
     *              *       WAVCAN(1:LDBASE,ISTATE,IREVER,ICHARG)
C
            END IF
C
         END DO
C
      END DO ! IREVER
C
C=======================================================================
C        DEFINING THE OCCUPATION NUMBERS FOR TIME-REVERSED STATES
C        IN CASE OF NO ROTATION
C=======================================================================
C
      IF (MREVER.EQ.0) THEN
C
          DO ISTATE=1,LDBASE
             V2OCCU(ISTATE+LDBASE)       =V2OCCU(ISTATE)
             V2OCNP(ISTATE+LDBASE,ICHARG)=V2OCCU(ISTATE)
          END DO
C
          IREVER=0
          DO ISTATE=1,NUMBQP(IREVER,ICHARG)
             V_CAN(ISTATE,1-IREVER,ICHARG) =
     *            -V_CAN(ISTATE,IREVER,ICHARG)
             U_CAN(ISTATE,1-IREVER,ICHARG) =
     *            U_CAN(ISTATE,IREVER,ICHARG)
             WAVCAN(1:NDBASE,ISTATE,1-IREVER,ICHARG)=
     *            CONJG(WAVCAN(1:NDBASE,ISTATE,IREVER,ICHARG))
          END DO
C
          RHO_PP(:,:,1)=CONJG(RHO_PP(:,:,0))
C
      END IF
C
C=======================================================================
C         REMOVING THE TERM COMING FROM THE BLOCKED STATE
C=======================================================================
C
      IF (LIPNOX.EQ.1) THEN
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                RHO_PP(IBRA,IKET,1-IREQPB)=RHO_PP(IBRA,IKET,  1-IREQPB)-
     *                                     BBLQUA(IBRA,1-IREQPB,ICHARG)
     *                              *CONJG(BBLQUA(IKET,1-IREQPB,ICHARG))
                RHO_PP(IBRA,IKET,  IREQPB)=RHO_PP(IBRA,IKET,    IREQPB)+
     *                               CONJG(ABLQUA(IBRA,IREQPB,  ICHARG))
     *                                    *ABLQUA(IKET,IREQPB,  ICHARG)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         CALCULATING THE AVERAGE AND DISPERSION OF PARTICLE NUMBER
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.71N)  AND  (2.72H), CALCULATION
C                    OF  THE  PARTICLE-NUMBER   DISPERSION   BELOW   WAS
C                    INCORRECT,   AND  THUS  THE  LIPKIN-NOGAMI   ENERGY
C                    CORRECTION  WAS  INCORRECT  TOO.   THIS   BUG   WAS
C                    CORRECTED ON 27/04/2015 IN VERSION (2.72I).
C=======================================================================
C
      PARLIX=0.0D0
      DISLIX=0.0D0
C
      DO IKET=1,LDBASE
C
         DIARHO=REAL(RHO_PP(IKET,IKET,0)+RHO_PP(IKET,IKET,1))
         PARLIX=PARLIX+DIARHO
C
         DIADIS=0.0D0
         DO IBRA=1,LDBASE
C
            DIADIS=DIADIS+REAL(
     *             RHO_PP(IBRA,IKET,0)*CONJG(RHO_PP(IBRA,IKET,0))
     *            +RHO_PP(IBRA,IKET,1)*CONJG(RHO_PP(IBRA,IKET,1)))
C
         END DO
C
         DISLIX=DISLIX+DIARHO-DIADIS
C
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS,EWAVEF)
C=======================================================================
C
      CALL CPUTIM('CANQUA',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CANQUZ(ICHARG,IMFHFB,LIPNOX,PARLIX,DISLIX,ENESUM)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE MAR_PP
      USE MAR_PM
      USE ALLWAV
      USE ALLQUZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,EWAVEF,FWAVEF
      COMPLEX
     *          C_ZERO,C_UNIT
      COMPLEX
     *          ABLQUZ,BBLQUZ
C=======================================================================
      DIMENSION
     *          V2OCCU(1:2*NDBASE)
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE EWAVEF(:,:),FWAVEF(:,:)
C=======================================================================
      COMMON
     *       /XBLQUZ/ ABLQUZ(1:2*NDBASE,0:NDREVE,0:NDISOS,1:NDBLOC),
     *                BBLQUZ(1:2*NDBASE,0:NDREVE,0:NDISOS,1:NDBLOC)
      COMMON
     *       /CORPAR/ V_CORR(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /CAOCNP/ V2OCNP(1:4*NDBASE,0:NDISOS)
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZSPE/ SPESIZ(1:4*NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('CANQUZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(WAVOCC)) THEN
          ALLOCATE (WAVOCC(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVOCC','CANQUZ')
      END IF
      IF (.NOT.ALLOCATED(RHO_PP)) THEN
          ALLOCATE (RHO_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('RHO_PP','CANQUZ')
      END IF
      IF (.NOT.ALLOCATED(RHO_PM)) THEN
          ALLOCATE (RHO_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('RHO_PM','CANQUZ')
      END IF
C=======================================================================
C
C=======================================================================
      ALLOCATE (CELMTS(1:((2*NDBASE+1)*2*NDBASE)/2),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','CANQUZ')
C=======================================================================
      ALLOCATE (EWAVEF(1:NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAVEF','CANQUZ')
      ALLOCATE (FWAVEF(1:NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FWAVEF','CANQUZ')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE DETERMINES THE CANONICAL BASIS
C        FOR THE NO-SYMMETRY CASE
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
      ENESUM=0.0D0
C
C=======================================================================
C        CALCULATING THE DENSITY MATRIX
C=======================================================================
C
      ENESUM=0.0D0
C
      DO IREVER=0,NDREVE
C
         RHO_PP(:,:,IREVER)=C_ZERO
         RHO_PM(:,:,IREVER)=C_ZERO
C
         DO JREVER=0,NDREVE
C
            DO ISTATE=1,NUMBQP(JREVER,ICHARG)
C
               JSTATE=ISTATE+JREVER*NUMBQP(0,ICHARG)
C
               CALL ZCOPY(LDBASE,BWAQUZ(1,JSTATE,IREVER),1,
     *                           EWAVEF(1,JSTATE),1)
C
               CALL ZCOPY(LDBASE,BWAQUZ(1,JSTATE,1-IREVER),1,
     *                           FWAVEF(1,JSTATE),1)
C
               CORECT=V_CORR(ISTATE,JREVER)
C
               CALL ZDSCAL(LDBASE,CORECT,EWAVEF(1,JSTATE),1)
C
               CALL ZDSCAL(LDBASE,CORECT,FWAVEF(1,JSTATE),1)
C
            END DO
C
         END DO
C
         N_COLS = NUMBQP(0,ICHARG) + NUMBQP(1,ICHARG)
C
         CALL ZGEMM('N','C',LDBASE,LDBASE,N_COLS,
     *                      C_UNIT,EWAVEF,NDBASE,EWAVEF,NDBASE,
     *                      C_ZERO,RHO_PP(1,1,IREVER),NDBASE)
C
         CALL ZGEMM('N','C',LDBASE,LDBASE,N_COLS,
     *                     C_UNIT,EWAVEF,NDBASE,FWAVEF,NDBASE,
     *                     C_ZERO,RHO_PM(1,1,IREVER),NDBASE)
CC
C         DO JREVER=0,NDREVE
CC
C            DO ISTATE=1,NUMBQP(JREVER,ICHARG)
CC
C               JSTATE=ISTATE+JREVER*NUMBQP(0,ICHARG)
CC
C               DO IKET=1,LDBASE
C                  DO IBRA=1,LDBASE
CC
C                 RHO_PP(IBRA,IKET,IREVER)=RHO_PP(IBRA,IKET    ,IREVER)
C     *
C     *                             +      BWAQUZ(IBRA,JSTATE  ,IREVER)
C     *                             *CONJG(BWAQUZ(IKET,JSTATE  ,IREVER))
C     *                                        *V_CORR(ISTATE  ,JREVER)
C     *                                        *V_CORR(ISTATE  ,JREVER)
CC
C                 RHO_PM(IBRA,IKET,IREVER)=RHO_PM(IBRA,IKET    ,IREVER)
C     *
C     *                             +      BWAQUZ(IBRA,JSTATE  ,IREVER)
C     *                             *CONJG(BWAQUZ(IKET,JSTATE,1-IREVER))
C     *                                        *V_CORR(ISTATE  ,JREVER)
C     *                                        *V_CORR(ISTATE  ,JREVER)
CC
C                  END DO
C               END DO
CC
C            END DO
CC
C         END DO
C
      END DO
C
      DEALLOCATE(EWAVEF,FWAVEF)
C
      ALLOCATE (EWAVEF(1:2*NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAVEF','CANQUZ')
C
C=======================================================================
C           PREPARING THE DIAGONALIZATION OF THE DENSITY MATRIX.
C           DIAGONALIZATION OF MINUS DENSITY MATRIX ENSURES THAT
C           THE ORDER OF EIGENSTATES IS THE SAME AS IN THE  CASE
C           WHEN THE MEAN-FIELD HAMILTONIAN IS DIAGONALIZED.
C=======================================================================
C
      DO IBRA=1,2*LDBASE
         DO IKET=1,2*LDBASE
C
            IF (IBRA.GE.IKET) THEN
C
                NCOUNT=IBRA+((4*LDBASE-IKET)*(IKET-1))/2
C
                IF (IBRA.LE.LDBASE.AND.IKET.LE.LDBASE)
     *                 CELMTS(NCOUNT)=-RHO_PP(IBRA       ,IKET       ,0)
C
                IF (IBRA.GT.LDBASE.AND.IKET.LE.LDBASE)
     *                 CELMTS(NCOUNT)=-RHO_PM(IBRA-LDBASE,IKET       ,1)
C
                IF (IBRA.GT.LDBASE.AND.IKET.GT.LDBASE)
     *                 CELMTS(NCOUNT)=-RHO_PP(IBRA-LDBASE,IKET-LDBASE,1)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C           CALLING THE DIAGONALIZATION ROUTINE
C=======================================================================
C
      CALL DIAMAT(CELMTS,V2OCCU,EWAVEF,2*LDBASE,2*NDBASE,2*LDBASE)
C
C=======================================================================
C           REVERTING TO THE CORRECT SIGNS OF THE OCCUPATION FACTORS
C           AND TRIMMING THE OUT-OF-BOUNDS VALUES.
C=======================================================================
C          ATTENTION: BETWEEN VERSION 2.49P AND 2.70S, A TRIMMING OF THE
C                     CANONICAL OCCUPATION NUMBERS TO VALUES BELOW 1 AND
C                     ABOVE 0 WAS INTRODUCED ONLY IN "CANQUA" AND NOT IN
C                     "CANQUZ". THIS RESULTED IN DIFFERENCES OF  RESULTS
C                     OBTAINED WITH SIMPLEX CONSERVED OR NOT. SINCE  THE
C                     VALUES ABOVE 1 OR BELOW 0 APPEAR ONLY  BECAUSE  OF
C                     THE PARTICLE-NUMBER CORRECTION  FACTORS  "V_CORR",
C                     THE DIFFERENCES EXISTED ONLY DURING THE ITERATION,
C                     AND  DISAPPEARED  FOR  PARTICLE-NUMBER   CONVERGED
C                     RESULTS.  THIS  INCONSISTENCY   WAS   REMOVED   ON
C                     12/12/14 IN VERSION 2.70T, WHEN THE  TRIMMING  WAS
C                     ALSO INTRODUCED INTO "CANQUZ".
C=======================================================================
C
      DO I_BASE=1,2*LDBASE
C
         V2OCCU(I_BASE       )=-V2OCCU(I_BASE)
C
         IF ((1.0-V2OCCU(I_BASE)).LT.1.E-14)
     *        V2OCCU(I_BASE)=1.0
C
         IF ( V2OCCU(I_BASE).LT.1.E-14)
     *        V2OCCU(I_BASE)=0.0
C
         V2OCNP(I_BASE,ICHARG)= V2OCCU(I_BASE)
C
      END DO
C
C=======================================================================
C        SEE COMMENTS IN SUBROUTINE "CANQUA"
C=======================================================================
C
      ONEONE=1.0D0
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))
     *            =SQRT(ABS(V2OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))))
     *         *SIGN(ONEONE,V2OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG)))
C
         END DO
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE WAVE FUNCTIONS
C=======================================================================
C
         IF (IMFHFB.NE.1) THEN
C
             DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                DO IBASE=1,LDBASE
C
                   WAVOCC(IBASE,ISTATE+IREVER*NUMBSP(0,ICHARG),0)=
     *               EWAVEF(IBASE       ,ISTATE+IREVER*NUMBSP(0,ICHARG))
C
                   WAVOCC(IBASE,ISTATE+IREVER*NUMBSP(0,ICHARG),1)=
     *               EWAVEF(IBASE+LDBASE,ISTATE+IREVER*NUMBSP(0,ICHARG))
C
                END DO
C
             END DO
C
         END IF
C
      END DO
C
C=======================================================================
C           CALCULATING THE CANONICAL SINGLE-PARTICLE ENERGIES
C=======================================================================
C
         CALL AVEQUZ(SPESIZ,BIG_PP,BIG_PM,EWAVEF)
C
C=======================================================================
C           CALCULATING THE SUM OF SINGLE-PARTCLE ENERGIES
C=======================================================================
C
      DO ISTATE=1,2*LDBASE
C
         ENESUM=ENESUM+V2OCCU(ISTATE)*SPESIZ(ISTATE)
C
      END DO
C
C=======================================================================
C           STORING THE CANONICAL ENERGIES AND OCCUPATION FACTORS
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            IF (IMFHFB.NE.1)
     *      SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)=
     *      SPESIZ(ISTATE+IREVER*NUMBSP(0,ICHARG))
C
            SPOCCU(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)=
     *      V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))**2
C
         END DO
C
      END DO
C
C=======================================================================
C         REMOVING THE TERM COMING FROM THE BLOCKED STATE
C=======================================================================
C
      IF (LIPNOX.EQ.1) THEN
C
          DO NUBLOC=1,NDBLOC
C
             DO IKET=1,LDBASE
                DO IBRA=1,LDBASE
C
                   RHO_PP(IBRA,IKET,0)=RHO_PP(IBRA,IKET,0)-
     *                                    BBLQUZ(IBRA,0,ICHARG,NUBLOC)*
     *                              CONJG(BBLQUZ(IKET,0,ICHARG,NUBLOC))+
     *                              CONJG(ABLQUZ(IBRA,0,ICHARG,NUBLOC))*
     *                                    ABLQUZ(IKET,0,ICHARG,NUBLOC)
                   RHO_PP(IBRA,IKET,1)=RHO_PP(IBRA,IKET,1)-
     *                                    BBLQUZ(IBRA,1,ICHARG,NUBLOC)*
     *                              CONJG(BBLQUZ(IKET,1,ICHARG,NUBLOC))+
     *                              CONJG(ABLQUZ(IBRA,1,ICHARG,NUBLOC))*
     *                                    ABLQUZ(IKET,1,ICHARG,NUBLOC)
C
                   RHO_PM(IBRA,IKET,0)=RHO_PM(IBRA,IKET,0)-
     *                                    BBLQUZ(IBRA,0,ICHARG,NUBLOC)*
     *                              CONJG(BBLQUZ(IKET,1,ICHARG,NUBLOC))+
     *                              CONJG(ABLQUZ(IBRA,0,ICHARG,NUBLOC))*
     *                                    ABLQUZ(IKET,1,ICHARG,NUBLOC)
                   RHO_PM(IBRA,IKET,1)=RHO_PM(IBRA,IKET,1)-
     *                                    BBLQUZ(IBRA,1,ICHARG,NUBLOC)*
     *                              CONJG(BBLQUZ(IKET,0,ICHARG,NUBLOC))+
     *                              CONJG(ABLQUZ(IBRA,1,ICHARG,NUBLOC))*
     *                                    ABLQUZ(IKET,0,ICHARG,NUBLOC)
C
                END DO
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C         CALCULATING THE AVERAGE AND DISPERSION OF PARTICLE NUMBER
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.71N)  AND  (2.72H), CALCULATION
C                    OF  THE  PARTICLE-NUMBER   DISPERSION   BELOW   WAS
C                    INCORRECT,   AND  THUS  THE  LIPKIN-NOGAMI   ENERGY
C                    CORRECTION  WAS  INCORRECT  TOO.   THIS   BUG   WAS
C                    CORRECTED ON 27/04/2015 IN VERSION (2.72I).
C=======================================================================
C
      PARLIX=0.0D0
      DISLIX=0.0D0
C
      DO IKET=1,LDBASE
C
         DIARHO=REAL(RHO_PP(IKET,IKET,0)+RHO_PP(IKET,IKET,1))
         PARLIX=PARLIX+DIARHO
C
         DIADIS=0.0D0
         DO IBRA=1,LDBASE
C
            DIADIS=DIADIS+REAL(
     *             RHO_PP(IBRA,IKET,0)*CONJG(RHO_PP(IBRA,IKET,0))
     *            +RHO_PP(IBRA,IKET,1)*CONJG(RHO_PP(IBRA,IKET,1))
     *            +RHO_PM(IBRA,IKET,0)*CONJG(RHO_PM(IBRA,IKET,1))
     *            +RHO_PM(IBRA,IKET,1)*CONJG(RHO_PM(IBRA,IKET,0)))
C
         END DO
C
         DISLIX=DISLIX+DIARHO-DIADIS
C
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS,EWAVEF)
C=======================================================================
C
      CALL CPUTIM('CANQUZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CANMIZ(ICHARG,IMFHFB,LIPNOX,PARLIX,DISLIX,ENESUM)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE MAR_PP
      USE MAR_PM
      USE ALLQUZ
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,EWAVEF,FWAVEF
      COMPLEX
     *          C_ZERO,C_UNIT
      COMPLEX
     *          ABLMUZ,BBLMUZ
C=======================================================================
      DIMENSION
     *          V2OCCU(1:4*NDBASE)
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE EWAVEF(:,:),FWAVEF(:,:)
C=======================================================================
      COMMON
     *       /XBLMUZ/ ABLMUZ(1:2*NDBASE,0:NDREVE),
     *                BBLMUZ(1:2*NDBASE,0:NDREVE)
      COMMON
     *       /CORPAR/ V_CORR(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /CAOCNP/ V2OCNP(1:4*NDBASE,0:NDISOS)
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /SIZSPE/ SPESIZ(1:4*NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('CANMIZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(PNMOCC)) THEN
          ALLOCATE (PNMOCC(1:2*NDBASE,1:4*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PNMOCC','CANMIZ')
      END IF
      IF (.NOT.ALLOCATED(RHO_PP)) THEN
          ALLOCATE (RHO_PP(1:2*NDBASE,1:2*NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('RHO_PP','CANMIZ')
      END IF
      IF (.NOT.ALLOCATED(RHO_PM)) THEN
          ALLOCATE (RHO_PM(1:2*NDBASE,1:2*NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('RHO_PM','CANMIZ')
      END IF
C=======================================================================
C
C=======================================================================
      ALLOCATE (CELMTS(1:((4*NDBASE+1)*4*NDBASE)/2),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','CANMIZ')
C=======================================================================
      ALLOCATE (EWAVEF(1:2*NDBASE,1:4*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAVEF','CANMIZ')
      ALLOCATE (FWAVEF(1:2*NDBASE,1:4*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FWAVEF','CANMIZ')
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE DETERMINES THE CANONICAL BASIS
C        FOR THE NO-SYMMETRY CASE
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
      ENESUM=0.0D0
C
C=======================================================================
C        CALCULATING THE DENSITY MATRIX
C=======================================================================
C
      ENESUM=0.0D0
C
      DO IREVER=0,NDREVE
C
         RHO_PP(:,:,IREVER)=C_ZERO
         RHO_PM(:,:,IREVER)=C_ZERO
C
         DO JREVER=0,NDREVE
C
            DO ISTATE=1,NUMBQP(JREVER,ICHARG)
C
               JSTATE=ISTATE+JREVER*NUMBQP(0,ICHARG)
C
               CALL ZCOPY(2*LDBASE,BWAQUZ(1,JSTATE,IREVER),1,
     *                             EWAVEF(1,JSTATE),1)
C
               CALL ZCOPY(2*LDBASE,BWAQUZ(1,JSTATE,1-IREVER),1,
     *                             FWAVEF(1,JSTATE),1)
C
               CORECT=V_CORR(ISTATE,JREVER)
C
               CALL ZDSCAL(2*LDBASE,CORECT,EWAVEF(1,JSTATE),1)
C
               CALL ZDSCAL(2*LDBASE,CORECT,FWAVEF(1,JSTATE),1)
C
            END DO
C
         END DO
C
         N_COLS = NUMBQP(0,ICHARG) + NUMBQP(1,ICHARG)
C
         CALL ZGEMM('N','C',2*LDBASE,2*LDBASE,N_COLS,
     *                   C_UNIT,EWAVEF,2*NDBASE,EWAVEF,2*NDBASE,
     *                   C_ZERO,RHO_PP(1,1,IREVER),2*NDBASE)
C
         CALL ZGEMM('N','C',2*LDBASE,2*LDBASE,N_COLS,
     *                   C_UNIT,EWAVEF,2*NDBASE,FWAVEF,2*NDBASE,
     *                   C_ZERO,RHO_PM(1,1,IREVER),2*NDBASE)
CC
C         DO JREVER=0,NDREVE
CC
C            DO ISTATE=1,NUMBQP(JREVER,ICHARG)
CC
C               JSTATE=ISTATE+JREVER*NUMBQP(0,ICHARG)
CC
C               DO IKET=1,LDBASE
C                  DO IBRA=1,LDBASE
CC
C                 RHO_PP(IBRA,IKET,IREVER)=RHO_PP(IBRA,IKET    ,IREVER)
C     *
C     *                             +      BWAQUZ(IBRA,JSTATE  ,IREVER)
C     *                             *CONJG(BWAQUZ(IKET,JSTATE  ,IREVER))
C     *                                        *V_CORR(ISTATE  ,JREVER)
C     *                                        *V_CORR(ISTATE  ,JREVER)
CC
C                 RHO_PM(IBRA,IKET,IREVER)=RHO_PM(IBRA,IKET    ,IREVER)
C     *
C     *                             +      BWAQUZ(IBRA,JSTATE  ,IREVER)
C     *                             *CONJG(BWAQUZ(IKET,JSTATE,1-IREVER))
C     *                                        *V_CORR(ISTATE  ,JREVER)
C     *                                        *V_CORR(ISTATE  ,JREVER)
CC
C                  END DO
C               END DO
CC
C            END DO
CC
C         END DO
C
      END DO
C
      DEALLOCATE(EWAVEF,FWAVEF)
C
      ALLOCATE (EWAVEF(1:4*NDBASE,1:4*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAVEF','CANMIZ')
C
C=======================================================================
C           PREPARING THE DIAGONALIZATION OF THE DENSITY MATRIX.
C           DIAGONALIZATION OF MINUS DENSITY MATRIX ENSURES THAT
C           THE ORDER OF EIGENSTATES IS THE SAME AS IN THE  CASE
C           WHEN THE MEAN-FIELD HAMILTONIAN IS DIAGONALIZED.
C=======================================================================
C
      DO IBRA=1,4*LDBASE
         DO IKET=1,4*LDBASE
C
            IF (IBRA.GE.IKET) THEN
C
                NCOUNT=IBRA+((8*LDBASE-IKET)*(IKET-1))/2
C
                IF (IBRA.LE.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *             CELMTS(NCOUNT)=-RHO_PP(IBRA         ,IKET         ,0)
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.LE.2*LDBASE)
     *             CELMTS(NCOUNT)=-RHO_PM(IBRA-2*LDBASE,IKET         ,1)
C
                IF (IBRA.GT.2*LDBASE.AND.IKET.GT.2*LDBASE)
     *             CELMTS(NCOUNT)=-RHO_PP(IBRA-2*LDBASE,IKET-2*LDBASE,1)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C           CALLING THE DIAGONALIZATION ROUTINE
C=======================================================================
C
      CALL DIAMAT(CELMTS,V2OCCU,EWAVEF,4*LDBASE,4*NDBASE,4*LDBASE)
C
C=======================================================================
C           REVERTING TO THE CORRECT SIGNS OF THE OCCUPATION FACTORS
C           AND TRIMMING THE OUT-OF-BOUNDS VALUES.
C=======================================================================
C          ATTENTION: BETWEEN VERSION 2.49P AND 2.70S, A TRIMMING OF THE
C                     CANONICAL OCCUPATION NUMBERS TO VALUES BELOW 1 AND
C                     ABOVE 0 WAS INTRODUCED ONLY IN "CANQUA" AND NOT IN
C                     "CANQUZ". THIS RESULTED IN DIFFERENCES OF  RESULTS
C                     OBTAINED WITH SIMPLEX CONSERVED OR NOT. SINCE  THE
C                     VALUES ABOVE 1 OR BELOW 0 APPEAR ONLY  BECAUSE  OF
C                     THE PARTICLE-NUMBER CORRECTION  FACTORS  "V_CORR",
C                     THE DIFFERENCES EXISTED ONLY DURING THE ITERATION,
C                     AND  DISAPPEARED  FOR  PARTICLE-NUMBER   CONVERGED
C                     RESULTS.  THIS  INCONSISTENCY   WAS   REMOVED   ON
C                     12/12/14 IN VERSION 2.70T, WHEN THE  TRIMMING  WAS
C                     ALSO INTRODUCED INTO "CANQUZ".
C=======================================================================
C
      DO I_BASE=1,4*LDBASE
C
         V2OCCU(I_BASE       )=-V2OCCU(I_BASE)
C
         IF ((1.0-V2OCCU(I_BASE)).LT.1.E-14)
     *        V2OCCU(I_BASE)=1.0
C
         IF ( V2OCCU(I_BASE).LT.1.E-14)
     *        V2OCCU(I_BASE)=0.0
C
         V2OCNP(I_BASE,ICHARG)= V2OCCU(I_BASE)
C
      END DO
C
C=======================================================================
C        SEE COMMENTS IN SUBROUTINE "CANQUA"
C=======================================================================
C
      ONEONE=1.0D0
C
      DO IALLST=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
         V_OCCU(IALLST)=SQRT(ABS(V2OCCU(IALLST)))
     *              *SIGN(ONEONE,V2OCCU(IALLST))
      END DO
C
C=======================================================================
C        STORING THE SINGLE-PARTICLE WAVE FUNCTIONS
C=======================================================================
C
      IF (IMFHFB.NE.1) THEN
C
          DO IALLST=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
             DO IBASE=1,2*LDBASE
                PNMOCC(IBASE,IALLST,0)=EWAVEF(IBASE         ,IALLST)
                PNMOCC(IBASE,IALLST,1)=EWAVEF(IBASE+2*LDBASE,IALLST)
             END DO
          END DO
C
      END IF
C
C=======================================================================
C           CALCULATING THE CANONICAL SINGLE-PARTICLE ENERGIES
C=======================================================================
C
         CALL AVEMIZ(SPESIZ,BIG_PP,BIG_PM,EWAVEF)
C
C=======================================================================
C           CALCULATING THE SUM OF SINGLE-PARTCLE ENERGIES
C=======================================================================
C
      DO ISTATE=1,4*LDBASE
C
         ENESUM=ENESUM+V2OCCU(ISTATE)*SPESIZ(ISTATE)
C
      END DO
C
C=======================================================================
C           STORING THE CANONICAL ENERGIES AND OCCUPATION FACTORS
C=======================================================================
C
      DO IALLST=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
         PNENER(IALLST)=SPESIZ(IALLST)
         PNOCCU(IALLST)=V_OCCU(IALLST)**2
      END DO
C
C=======================================================================
C         REMOVING THE TERM COMING FROM THE BLOCKED STATE
C=======================================================================
C
      IF (LIPNOX.EQ.1) THEN
C
          STOP ' NOT IMPLEMENTED YET'
C
          DO IKET=1,2*LDBASE
             DO IBRA=1,2*LDBASE
C
                RHO_PP(IBRA,IKET,0)=RHO_PP(IBRA,IKET,0)-
     *                                           BBLMUZ(IBRA,0)*
     *                                     CONJG(BBLMUZ(IKET,0))+
     *                                     CONJG(ABLMUZ(IBRA,0))*
     *                                           ABLMUZ(IKET,0)
                RHO_PP(IBRA,IKET,1)=RHO_PP(IBRA,IKET,1)-
     *                                           BBLMUZ(IBRA,1)*
     *                                     CONJG(BBLMUZ(IKET,1))+
     *                                     CONJG(ABLMUZ(IBRA,1))*
     *                                           ABLMUZ(IKET,1)
C
                RHO_PM(IBRA,IKET,0)=RHO_PM(IBRA,IKET,0)-
     *                                           BBLMUZ(IBRA,0)*
     *                                     CONJG(BBLMUZ(IKET,1))+
     *                                     CONJG(ABLMUZ(IBRA,0))*
     *                                           ABLMUZ(IKET,1)
                RHO_PM(IBRA,IKET,1)=RHO_PM(IBRA,IKET,1)-
     *                                           BBLMUZ(IBRA,1)*
     *                                     CONJG(BBLMUZ(IKET,0))+
     *                                     CONJG(ABLMUZ(IBRA,1))*
     *                                           ABLMUZ(IKET,0)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         CALCULATING THE AVERAGE AND DISPERSION OF PARTICLE NUMBER
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.71N)  AND  (2.72H), CALCULATION
C                    OF  THE  PARTICLE-NUMBER   DISPERSION   BELOW   WAS
C                    INCORRECT,   AND  THUS  THE  LIPKIN-NOGAMI   ENERGY
C                    CORRECTION  WAS  INCORRECT  TOO.   THIS   BUG   WAS
C                    CORRECTED ON 27/04/2015 IN VERSION (2.72I).
C=======================================================================
C
      PARLIX=0.0D0
      DISLIX=0.0D0
C
      DO IKET=1,2*LDBASE
C
         DIARHO=REAL(RHO_PP(IKET,IKET,0)+RHO_PP(IKET,IKET,1))
         PARLIX=PARLIX+DIARHO
C
         DIADIS=0.0D0
         DO IBRA=1,2*LDBASE
C
            DIADIS=DIADIS+REAL(
     *             RHO_PP(IBRA,IKET,0)*CONJG(RHO_PP(IBRA,IKET,0))
     *            +RHO_PP(IBRA,IKET,1)*CONJG(RHO_PP(IBRA,IKET,1))
     *            +RHO_PM(IBRA,IKET,0)*CONJG(RHO_PM(IBRA,IKET,1))
     *            +RHO_PM(IBRA,IKET,1)*CONJG(RHO_PM(IBRA,IKET,0)))
C
         END DO
C
         DISLIX=DISLIX+DIARHO-DIADIS
C
      END DO
C
C=======================================================================
      DEALLOCATE (CELMTS,EWAVEF)
C=======================================================================
C
      CALL CPUTIM('CANMIZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE QUABCS(EFERMI,NOPART,FERFIX,IFEFIX,ICHARG,
     *                         IDSIGB,IDSIMB,IDSIQB,IDSIZB,
     *                                IPRGCM,NUQEVE,ITWOBA,
     *                                FERALM,IFERAL,PARNUM,
     *                                IREMQB,INUMQB,JNUMQB,
     *                                       ISIMPY,ISIQTY)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
#if(SWITCH_QUAD==1)
      REAL*16
     *          V2ACTU,ONE_16
#endif
#if(USE_MPI==1)
      INTEGER :: escapeSignal
#endif
      DIMENSION
     *          IDSIQB(1:NDBLOC)
      DIMENSION
     *          IDSIZB(1:NDBLOC)
      DIMENSION
     *          IREMQB(1:NDBLOC),INUMQB(1:NDBLOC),JNUMQB(1:NDBLOC)
      DIMENSION
     *          EHIGQP(0:NDREVE),KEPTQP(0:NDREVE),LASTQP(0:NDREVE)
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
      COMMON
     *       /GCTEMP/ TEMP_T
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /XEQUIV/ EEQUIV(1:2*NDSTAT,0:NDREVE),
     *                DEQUIV(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /CORPAR/ V_CORR(1:2*NDSTAT,0:NDREVE),
     *       /CORISO/ VCOISO(1:2*NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /LIMOCC/ NOTOCC(1:2*NDSTAT,0:NDREVE),
     *       /OCCISO/ NOCISO(1:2*NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /QUOCCU/ PARACC,CORLIM,DERLIM,OCCLIM,MAXQUA,IPQBCS
      COMMON
     *       /CUSIZN/ NCUSIZ(0:NDISOS)
      COMMON
     *       /CUSIQN/ NCUSIQ(0:NDISOS,0:NDPARI)
      COMMON
     *       /CFIPRI/ NFIPRI
#if(USE_MPI==1)
      COMMON
     *       /SIGNAL/ escapeSignal
#endif
C
C=======================================================================
C
      CALL CPUTIM('QUABCS',1)
C
C=======================================================================
C         THIS SUBROUTINE DETERMINES THE NEW VALUE OF THE FERMI ENERGY
C=======================================================================
C
      ONE_16=1.0
C
      IF (IFEFIX.NE.1) THEN
C
          IF (IFERAL.NE.1) THEN
C
C=======================================================================
C         BEGINING THE CONDITIONAL LOOP WHICH ITERATES THE FERMI ENERGY
C=======================================================================
C
              ITEBCS=0
C
              EFEINF=-1000.
              EFESUP=+1000.
C
    1         CONTINUE
C
              PARNUM=0.0D0
              DERFER=0.0D0
              DERAUX=0.0D0
C
              ITEBCS=ITEBCS+1
C
C=======================================================================
C         CHECKING WHETHER THE MAXIMUM NUMBER OF ITERATIONS EXCEEDED.
C=======================================================================
C
              IF (ITEBCS.GT.MAXQUA) THEN
C
                  WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),'' MAXIMUM NUMBER OF ITERATIONS ''
     *                                                  ,6X,20(1H/),/,
     *                     1X,20(1H/),'' EXCEEDED IN QUABCS           ''
     *                                                  ,6X,20(1H/),/)')
C
#if(USE_MPI==1)
C
                  CALL CPUTIM('QUABCS',0)
C
                  escapeSignal = 1
                  RETURN
#else
                  GO TO 2
#endif
C
              END IF
C
C=======================================================================
C         CALCULATING THE OCCUPATION FACTORS, PARTICLE NUMBER, AND THE
C         DERIVATIVE OF THE PARTICLE NUMBER OVER THE FERMI ENERGY.
C=======================================================================
C
              DO IREVER=0,NDREVE
                 DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
C                    BCS form of the q.p. energy
C
                    EQPEQU=SQRT((EEQUIV(ISTATE,IREVER)-EFERMI)**2
     *                          +DEQUIV(ISTATE,IREVER)**2)
C
C=======================================================================
C                IF T>0, THE VARIATIONS OF THE f_i (FERMI-DIRAC OCCUPA-
C                TION FACTORS)  WITH  RESPECT TO  \LAMBDA  MUST ALSO BE
C                CONSIDERED. BELOW THEY ARE  REDEFINED AT EACH STEP AND
C                AN  ADDITIONAL  TERM IS INCLUDED IN THE  DERIVATIVE OF
C                THE PARTICLE NUMBER WITH RESPECT TO \LAMBDA. IN SUCH A
C                WAY, THE PHASE TRANSITION PAIRED -> UNPAIRED SYSTEM IS
C                REPRODUCED.
C=======================================================================
C                HERE AND BELOW,  ICOUNT AVOIDS DOUBLE COUNTING IN  CASE
C                OF MULTIBLOCKING.
C=======================================================================
C
                    IF (IFTEMP.EQ.1) THEN
C
                        FERDIR=0.5D0*(1.0D0-TANH(EQPEQU/TEMP_T/2.0D0))
                        FERMFN(ISTATE,ICHARG)=FERDIR
C
                        DFACTU=(EEQUIV(ISTATE,IREVER)-EFERMI)
     *                         /EQPEQU/TEMP_T*FERDIR*(1.0-FERDIR)
C
                    ELSE
C
                        FERDIR=0.0
                        DFACTU=0.0
C
                    END IF
C
C=======================================================================
C           THE SECURITY BELOW ENSURES THAT "V2ACTU" DOES NOT BECOME 0/0
C
                    IF (EQPEQU     .LT.1.E-14) THEN
C
                        V2ACTU=0.5
                    ELSE
                        V2ACTU=(ONE_16-(EEQUIV(ISTATE,IREVER)-EFERMI)/
     *                                                        EQPEQU)/2
                    END IF
C
C=======================================================================
C
                    IF( V2ACTU     .LT.1.E-14) V2ACTU=0
                    IF((V2ACTU-1.0).GT.1.E-14) V2ACTU=1
C
                    U2ACTU=1.0-V2ACTU
C
C                    Derivative of v_i^2 with respect to \lambda
C
                    DEACTU=0.5*DEQUIV(ISTATE,IREVER)**2/(EQPEQU**3.0)
C
                    IF (IABS(IDSIGB).NE.1.AND.IABS(IDSIMB).NE.1.AND.
     *                  MAXVAL(IABS(IDSIQB)).NE.1.AND.
     *                  MAXVAL(IABS(IDSIZB)).NE.1)
     *                                                              THEN
                        PARNUM=PARNUM+(1.0D0-FERDIR)*V2ACTU
     *                                      +FERDIR *U2ACTU
C
                        DERFER=DERFER+(1.0D0-2.0*FERDIR)*DEACTU
                        DERAUX=DERAUX+(1.0D0-2.0*V2ACTU)*DFACTU
C
                    ELSE
C
                        IF (IFTEMP.NE.0)
     *                      STOP 'BLOCKING OF QP AT T>0 NOT IMPLEMENTED'
C
                        ICOUNT=0
                        DO NUBLOC=1,NDBLOC
C
                           IF (IABS(IDSIQB(1)).EQ.1.OR.
     *                         IABS(IDSIZB(NUBLOC)).EQ.1) THEN
C
                               IF (IREVER.EQ.IREMQB(NUBLOC).AND.
     *                             ISTATE.EQ.JNUMQB(NUBLOC)) THEN
C
                                   PARNUM=PARNUM+1-V2ACTU
                                   DERFER=DERFER-DEACTU
                                   ICOUNT=1
C
                               END IF
C
                           ELSE IF (IABS(IDSIGB).EQ.1.OR.
     *                              IABS(IDSIMB).EQ.1) THEN
C
                               IF ((IREVER.EQ.IREMQB(NUBLOC).AND.
     *                              ISTATE.EQ.INUMQB(NUBLOC))) THEN
C
                                   ICOUNT=1
C
                               END IF
C
                               IF (IREVER.NE.IREMQB(NUBLOC).AND.
     *                             ISTATE.EQ.JNUMQB(NUBLOC)) THEN
C
                                   PARNUM=PARNUM+1-V2ACTU
                                   DERFER=DERFER-DEACTU
                                   ICOUNT=1
C
                               END IF
C
                           END IF
C
                        END DO
C
                        IF (ICOUNT.EQ.0) THEN
C
                            PARNUM=PARNUM+V2ACTU
                            DERFER=DERFER+DEACTU
C
                        END IF
C
                    END IF
C
                 END DO
              END DO
C
              DERFER=DERFER+DERAUX
C
C=======================================================================
C         THIS IF PROTECTS AGAINST THE DIVISION BY VANISHING  DERIVATIVE
C=======================================================================
C
              IF (ABS(DERFER).LT.DERLIM) DERFER=DERLIM
C
C=======================================================================
C         CHECKING WHETHER THE REQUIRED ACCURACY OF THE PARTICLE  NUMBER
C         HAS BEEN REACHED.
C=======================================================================
C
              IF (ABS((PARNUM-NOPART)/NOPART).GT.PARACC) THEN
C
C=======================================================================
C         ADJUSTING THE UPPER AND LOWER BOUNDS ON THE FERMI ENERGY
C=======================================================================
C
                  IF (PARNUM-NOPART.LT.0) THEN
C
                     EFEINF=MAX(EFEINF,EFERMI)
                  ELSE
                     EFESUP=MIN(EFESUP,EFERMI)
C
                  END IF
C
C=======================================================================
C         CORRECTING THE FERMI ENERGY ACCORDING TO THE NEWTON METHOD.
C=======================================================================
C
                  EFERMI=EFERMI-(PARNUM-NOPART)/DERFER
C
C=======================================================================
C         WHENEVER THE NEWTON METHOD SENDS THE FERMI ENERGY OUTSIDE  THE
C         BOUNDS, THE ARITHMETIC MEAN OF THE BOUNDS IS USED IN THE  NEXT
C         ITERATION.
C=======================================================================
C
                  IF (EFERMI.LT.EFEINF.OR.EFERMI.GT.EFESUP) THEN
C
                      EFERMI=(EFEINF+EFESUP)/2
C
                  END IF
C
                  GO TO 1
C
              END IF
C
          ELSE ! HERE BEGINS THE CASE OF IFERAL.EQ.1
C
C=======================================================================
C         CALCULATING THE PARTICLE NUMBER.
C=======================================================================
C
              PARNUM=0.0D0
C
              DO IREVER=0,NDREVE
                 DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
C                    BCS form of the q.p. energy
C
                    EQPEQU=SQRT((EEQUIV(ISTATE,IREVER)-EFERMI)**2
     *                          +DEQUIV(ISTATE,IREVER)**2)
C
C=======================================================================
C                IF T>0, THE VARIATIONS OF THE f_i (FERMI-DIRAC OCCUPA-
C                TION FACTORS)  WITH  RESPECT TO  \LAMBDA  MUST ALSO BE
C                CONSIDERED. BELOW THEY ARE  REDEFINED AT EACH STEP AND
C                AN  ADDITIONAL  TERM IS INCLUDED IN THE  DERIVATIVE OF
C                THE PARTICLE NUMBER WITH RESPECT TO \LAMBDA. IN SUCH A
C                WAY, THE PHASE TRANSITION PAIRED -> UNPAIRED SYSTEM IS
C                REPRODUCED.
C=======================================================================
C                ICOUNT AVOIDS DOUBLE COUNTING IN CASE OF MULTIBLOCKING.
C=======================================================================
C
                    IF (IFTEMP.EQ.1) THEN
C
                        FERDIR=0.5D0*(1.0D0-TANH(EQPEQU/TEMP_T/2.0D0))
                        FERMFN(ISTATE,ICHARG)=FERDIR
C
                    ELSE
C
                        FERDIR=0.0
                        DFACTU=0.0
C
                    END IF
C
C=======================================================================
C           THE SECURITY BELOW ENSURES THAT "V2ACTU" DOES NOT BECOME 0/0
C
                    IF (EQPEQU     .LT.1.E-14) THEN
C
                        V2ACTU=0.5
                    ELSE
                        V2ACTU=(ONE_16-(EEQUIV(ISTATE,IREVER)-EFERMI)/
     *                                                        EQPEQU)/2
                    END IF
C
C=======================================================================
C
                    IF( V2ACTU     .LT.1.E-14) V2ACTU=0
                    IF((V2ACTU-1.0).GT.1.E-14) V2ACTU=1
C
                    U2ACTU=1.0-V2ACTU
C
                    IF (IABS(IDSIGB).NE.1.AND.IABS(IDSIMB).NE.1.AND.
     *                  MAXVAL(IABS(IDSIQB)).NE.1.AND.
     *                  MAXVAL(IABS(IDSIZB)).NE.1) THEN
C
                        PARNUM=PARNUM+(1.0D0-FERDIR)*V2ACTU
     *                                      +FERDIR *U2ACTU
C
                    ELSE
C
                        IF (IFTEMP.NE.0)
     *                      STOP 'BLOCKING OF QP AT T>0 NOT IMPLEMENTED'
C
                        ICOUNT=0
                        DO NUBLOC=1,NDBLOC
C
                           IF (IABS(IDSIQB(1)).EQ.1.OR.
     *                         IABS(IDSIZB(NUBLOC)).EQ.1) THEN
C
                               IF (IREVER.EQ.IREMQB(NUBLOC).AND.
     *                             ISTATE.EQ.JNUMQB(NUBLOC)) THEN
C
                                   PARNUM=PARNUM+1-V2ACTU
                                   ICOUNT=1
C
                               END IF
C
                           ELSE IF (IABS(IDSIGB).EQ.1.OR.
     *                              IABS(IDSIMB).EQ.1) THEN
C
                               IF ((IREVER.EQ.IREMQB(NUBLOC).AND.
     *                              ISTATE.EQ.INUMQB(NUBLOC))) THEN
C
                                   ICOUNT=1
C
                               END IF
C
                               IF (IREVER.NE.IREMQB(NUBLOC).AND.
     *                             ISTATE.EQ.JNUMQB(NUBLOC)) THEN
C
                                   PARNUM=PARNUM+1-V2ACTU
                                   ICOUNT=1
C
                               END IF
C
                           END IF
C
                        END DO
C
                        IF (ICOUNT.EQ.0) THEN
C
                            PARNUM=PARNUM+V2ACTU
C
                        END IF
C
                    END IF
C
                 END DO
              END DO
C
C=======================================================================
C         CORRECTING THE FERMI ENERGY ACCORDING TO THE AUGMENTED
C         LAGRANGE METHOD.
C=======================================================================
C
              EFERMI=EFERMI-2*FERALM*(PARNUM-NOPART)
C
          END IF
C
      ELSE
C
C=======================================================================
C         HERE THE FERMI ENERGY IS SET TO THE FIXED VALUE
C=======================================================================
C
          EFERMI=FERFIX
C
      END IF
C
  2   CONTINUE
C
C=======================================================================
C         CALCULATING THE CORRECTIVE FACTORS WHICH WILL BE USED WHEN
C         CONSTRUCTING THE DENSITIY MATRICES.
C=======================================================================
C         ATTENTION: NO CORRECTION IS POSSIBLE WHENEVER THE NORM  OF
C                    THE FIRST COMPONENT VANISHES. IT IS ALSO RATHER
C                    DANGEROUS TO USE SUCH CORRECTION METHOD FOR THE
C                    QUSIPARTICLES WITH VERY SMALL NORMS. THEREFORE,
C                    WE HERE ADOPT ARBITRARY CUT-OFF LIMIT  "CORLI_"
C                    BELOW WHICH THE CORRECTION IS   NOT  PERFORMED.
C                    SUCH QUASIPARTICLES ARE BEING KEPT IN THE SPACE
C                    BY SETTING V_CORR=1. THESE REMARKS ARE PARTICU-
C                    LARLY PERTINENT WHEN THIS ROUTINE IS RUN FOR  A
C                    VANISHING PAIRING OR WHEN THE PAIRING GRADUALLY
C                    DECREASES DURING THE HFB ITERATION.
C=======================================================================
C         ATTENTION: THE VALUE OF CORLI_=10. BELOW IS USED TO SWITCH
C                    THE CALCULATION OF THE CORRECTIVE FACTORS  OFF.
C=======================================================================
C
      CORLI_=CORLIM
C
      IF (IFERAL.EQ.1) CORLI_=10.
C
      DO IREVER=0,NDREVE
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
C            BCS form of the q.p. energy
C
            EQPEQU=SQRT((EEQUIV(ISTATE,IREVER)-EFERMI)**2
     *                          +DEQUIV(ISTATE,IREVER)**2)
C
C=======================================================================
C           THE SECURITY BELOW ENSURES THAT "V2ACTU" DOES NOT BECOME 0/0
C
            IF (EQPEQU     .LT.1.E-14) THEN
C
                V2ACTU=0.5
            ELSE
                V2ACTU=(ONE_16-(EEQUIV(ISTATE,IREVER)-EFERMI)/EQPEQU)/2
C
            END IF
C
C=======================================================================
C
            IF(V2ACTU.LT.0) V2ACTU=0
            IF(V2ACTU.GT.1) V2ACTU=1
C
            IF (V2QUAP(ISTATE,IREVER).GT.CORLI_) THEN
C
                IF (IABS(IDSIGB).NE.1.AND.IABS(IDSIMB).NE.1.AND.
     *              MAXVAL(IABS(IDSIQB)).NE.1.AND.
     *              MAXVAL(IABS(IDSIZB)).NE.1)THEN
C
                    V_CORR(ISTATE,IREVER)=
     *                                SQRT(V2ACTU/V2QUAP(ISTATE,IREVER))
                ELSE
C
                    ICOUNT=0
                    DO NUBLOC=1,NDBLOC
C
                       IF (IABS(IDSIQB(1)).EQ.1.OR.
     *                     IABS(IDSIZB(NUBLOC)).EQ.1) THEN
C
                           IF (IREVER.EQ.IREMQB(NUBLOC).AND.
     *                         ISTATE.EQ.JNUMQB(NUBLOC)) THEN
C
                               V_CORR(ISTATE,IREVER)=
     *                         SQRT((1-V2ACTU)/V2QUAP(ISTATE,IREVER))
                               ICOUNT=1
C
                           END IF
C
                       ELSE IF (IABS(IDSIGB).EQ.1.OR.
     *                          IABS(IDSIMB).EQ.1) THEN
C
                           IF (IREVER.EQ.IREMQB(NUBLOC).AND.
     *                          ISTATE.EQ.INUMQB(NUBLOC))
     *                         ICOUNT=1
C
                           IF (IREVER.NE.IREMQB(NUBLOC).AND.
     *                         ISTATE.EQ.JNUMQB(NUBLOC)) THEN
C
                               V_CORR(ISTATE,IREVER)=
     *                         SQRT((1-V2ACTU)/V2QUAP(ISTATE,IREVER))
                               ICOUNT=1
C
                           END IF
C
                       END IF
C
                    END DO
C
                    IF (ICOUNT.EQ.0) THEN
C
                        V_CORR(ISTATE,IREVER)=
     *                         SQRT(V2ACTU/V2QUAP(ISTATE,IREVER))
C
                    END IF
C
                END IF
C
            ELSE
C
                V_CORR(ISTATE,IREVER)=1.0D0
C
            END IF
C
            VCOISO(ISTATE,IREVER,ICHARG)=V_CORR(ISTATE,IREVER)
C
         END DO
      END DO
C
C=======================================================================
C         DEFINING QUASIPARTICLE STATES WHICH ARE NOT SIGNIFICANTLY
C         OCCUPIED AND ARE NOT TAKEN INTO ACCOUNT WHEN  CALCULATING
C         DENSITIES IN "DENSHF". THIS SAVES A LOT OF TIME WHEN  THE
C         CODE IS RUN IN THE HARTREE-FOCK MODE, OR WHEN THE PAIRING
C         GRADUALLY DECREASES DURING THE HFB ITERATION, OR WHEN THE
C         PAIRING VAHISHES FOR ONE KIND OF PARTICLES.
C         ATTENTION:
C                - THIS MAY HOWEVER LEAD TO UNCONTROLLED CHANGES OF
C                  DENSITIES, AT THE LEVEL DEFIND BY "OCCLIM"
C                - ALL Q.P. MUST BE RETAINED IF:
C                  > THE TEMPERATURE IS DIFFERENT FROM 0 (IFTEMP=1) OR
C                  > THE TWO-BASIS METHOD IS USED (ITWOBA=1).
C                - THE BLOCKED QUASIPARTICLE MUST BE RETAINED
C=======================================================================
C
      IF (IFTEMP.EQ.0.AND.ITWOBA.EQ.0.AND.
     *   ((ISIMPY.EQ.0.AND.ISIQTY.EQ.0.AND.NCUSIZ(ICHARG)  .EQ.0).OR.
     *    (ISIMPY.EQ.0.AND.ISIQTY.EQ.1.AND.NCUSIQ(ICHARG,0).EQ.0).AND.
     *                                     NCUSIQ(ICHARG,1).EQ.0)) THEN
C
          KEPTQP(:)=0
          LASTQP(:)=0
          EHIGQP(:)=-10000.
C
          DO IREVER=0,NDREVE
             DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
                ICUTQU=-1
C
                IF (IABS(IDSIGB).NE.1.AND.IABS(IDSIMB).NE.1.AND.
     *              MAXVAL(IABS(IDSIQB)).NE.1.AND.
     *              MAXVAL(IABS(IDSIZB)).NE.1) THEN
C
                    ICUTQU=1
C
                ELSE
C
                    ICOUNT=0
                    DO NUBLOC=1,NDBLOC
C
                       IF (IABS(IDSIQB(1)).EQ.1.OR.
     *                     IABS(IDSIZB(NUBLOC)).EQ.1) THEN
C
                           IF (IREVER.EQ.IREMQB(NUBLOC).AND.
     *                         ISTATE.EQ.JNUMQB(NUBLOC)) THEN
C
                               ICUTQU=0
                               ICOUNT=1
C
                           END IF
C
                       ELSE IF (IABS(IDSIGB).EQ.1.OR.
     *                          IABS(IDSIMB).EQ.1) THEN
C
                           IF (IREVER.NE.IREMQB(NUBLOC).AND.
     *                         ISTATE.EQ.JNUMQB(NUBLOC)) THEN
C
                               ICUTQU=0
                               ICOUNT=1
C
                           END IF
C
                       END IF
C
                    END DO
C
                    IF (ICOUNT.EQ.0) ICUTQU=1
C
                END IF
C
                IF (ICUTQU.EQ.-1) STOP 'ICUTQU NOT SET IN QUABCS'
C
                IF (V2QUAP(ISTATE,IREVER).LT.OCCLIM.AND.ICUTQU.EQ.1)THEN
                    NOTOCC(ISTATE,IREVER)=1
                ELSE
                    NOTOCC(ISTATE,IREVER)=0
                    KEPTQP(IREVER)=KEPTQP(IREVER)+1
                    IF (EHIGQP(IREVER).LT.EEQUIV(ISTATE,IREVER)) THEN
                        EHIGQP(IREVER) =  EEQUIV(ISTATE,IREVER)
                        LASTQP(IREVER) =  ISTATE
                    END IF
                END IF
C
                NOCISO(ISTATE,IREVER,ICHARG)=NOTOCC(ISTATE,IREVER)
C
             END DO
          END DO
C
C=======================================================================
C         HERE WE ENSURE THAT THE NUMBER OF KEPT QUASIPARTICLES IS EVEN.
C         THIS IS ESSENTIAL FOR CALCULATING OVERLAPS USING THE  PFAFFIAN
C         METHOD IN PROANG. THIS BUG  WAS  CORRECTED  ON  10/09/2020  IN
C         VERSION (2.99R).
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.99R) AND (3.15P), THE TREATMENT
C                    OF "NUQUVE" IN "QUABCS" WAS ACTIVE FOR ITWOBA=1 TOO
C                    AND ACTED ON TOP OF THAT IMPLEMENTED IN HFBSI_ WHEN
C                    THE TWO-BASIS METHOD WAS ACTIVE. ON  RARE  ANNOYING
C                    OCCASIONS, THIS WAS  CAUSING  PROBLEMS  IN  PROANG.
C                    THIS BUG WAS CORRECTED  ON  29/11/2022  IN  VERSION
C                    (3.15Q) WHEN THE ADDITIONAL "OCCLIM" CUTOFF WAS FOR
C                    ITWOBA=1 SWITCHED OFF ENTIRELY.  IN  ADDITION,  FOR
C                    ITWOBA=0, THE TREATMENT OF "NUQUVE" IN "QUABCS"  IS
C                    NOW  PERFORMED  INDEPENDENTLY  OF  "IPRGCM",  WHICH
C                    ENSURES A SMOOTH CONTINUATION BETWEEN THE RUNS WITH
C                    AND WITHOUT PROJECTION. THIS LATTER CORRECTION  MAY
C                    BECOME  RELEVANT  ONLY  IF  PROJECTIONS  COULD   BE
C                    PERFORMED WITHOUT THE TWO-BASIS METHOD.
C=======================================================================
C
          IF (NUQEVE.EQ.1) THEN
C
              IF (MOD(KEPTQP(0)+KEPTQP(1),2).EQ.1) THEN
C
                  IF (LASTQP(0).GT.LASTQP(1)) THEN
C
                      NOTOCC(LASTQP(0),0)=1
                      NOCISO(LASTQP(0),0,ICHARG)=1
                  ELSE
                      NOTOCC(LASTQP(1),1)=1
                      NOCISO(LASTQP(1),1,ICHARG)=1
C
                  END IF
C
              END IF
C
          END IF
C
      ELSE
C
          DO IREVER=0,NDREVE
             DO ISTATE=1,NUMBQP(IREVER,ICHARG)
                NOTOCC(ISTATE,IREVER)=0
                NOCISO(ISTATE,IREVER,ICHARG)=NOTOCC(ISTATE,IREVER)
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('QUABCS',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DISPER(DN2QUA,DN2STA,DZ2QUA,DZ2STA)
C=======================================================================
      USE SAVQUA
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO,C_UNIT,C_MINU
      COMPLEX
     *          FN20PL,FP20PL,FN11PL,FP11PL,FN11MI,FP11MI
C=======================================================================
      ALLOCATABLE FN20PL(:,:),FP20PL(:,:)
      ALLOCATABLE FN11PL(:,:),FP11PL(:,:)
      ALLOCATABLE FN11MI(:,:),FP11MI(:,:)
C=======================================================================
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C        THIS SUBROUTINE DETERMINES THE QUANTUM AND STATISTICAL (FOR
C        T>0) COMPONENT OF THE PARTICLE NUMBER DISPERSION.
C        REFERENCE: J. L. Egido, Phys. Rev. Lett. 61, 767 (1988)
C=======================================================================
C
      R_ZERO=0.0D0
      R_UNIT=1.0D0
C
      C_UNIT=CMPLX( R_UNIT,R_ZERO)
      C_ZERO=CMPLX( R_ZERO,R_ZERO)
      C_MINU=CMPLX(-R_UNIT,R_ZERO)
C
      IALLOC=0
C
      ALLOCATE (FN20PL(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FN20PL','DISPER')
      ALLOCATE (FP20PL(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FP20PL','DISPER')
C
      FN20PL(:,:) = C_ZERO
      FP20PL(:,:) = C_ZERO
C
      ALLOCATE (FN11PL(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FN11PL','DISPER')
      ALLOCATE (FP11PL(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FP11PL','DISPER')
      ALLOCATE (FN11MI(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FN11MI','DISPER')
      ALLOCATE (FP11MI(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FP11MI','DISPER')
C
      FN11PL(:,:) = C_ZERO
      FP11PL(:,:) = C_ZERO
      FN11MI(:,:) = C_ZERO
      FP11MI(:,:) = C_ZERO
C
C      Computing \tilde{N}^{11}^{T} for positive simplex
C
C      Contribution from the neutrons
C
C      Second term: V_{+}^{+} V_{+}
C                 = ( B_{+}^{+}B_{+} )^{T}
C
      CALL ZGEMM('C','N',NUMBQP(0,0),NUMBQP(0,0),LDBASE,
     *                    C_UNIT,BSVQUA(1,1,0,0),NDBASE,
     *                           BSVQUA(1,1,0,0),NDBASE,
     *                             C_ZERO,FN11PL,NDSTAT)
C
C      First term:  U_{-}^{+} U_{-}
C                 = ( A_{-}^{+}A_{-} )^{T}
C
      CALL ZGEMM('C','N',NUMBQP(1,0),NUMBQP(1,0),LDBASE,
     *                    C_UNIT,ASVQUA(1,1,1,0),NDBASE,
     *                           ASVQUA(1,1,1,0),NDBASE,
     *                             C_UNIT,FN11PL,NDSTAT)
C
C      Contribution from the protons
C
      CALL ZGEMM('C','N',NUMBQP(0,1),NUMBQP(0,1),LDBASE,
     *                    C_ZERO,BSVQUA(1,1,0,1),NDBASE,
     *                           BSVQUA(1,1,0,1),NDBASE,
     *                             C_ZERO,FP11PL,NDSTAT)
C
      CALL ZGEMM('C','N',NUMBQP(1,1),NUMBQP(1,1),LDBASE,
     *                    C_UNIT,ASVQUA(1,1,1,1),NDBASE,
     *                           ASVQUA(1,1,1,1),NDBASE,
     *                             C_UNIT,FP11PL,NDSTAT)
C
C      Computing \tilde{N}^{11}^{T} for negative simplex
C
C      Contribution from the neutrons
C
      CALL ZGEMM('C','N',NUMBQP(1,0),NUMBQP(1,0),LDBASE,
     *                    C_UNIT,BSVQUA(1,1,1,0),NDBASE,
     *                           BSVQUA(1,1,1,0),NDBASE,
     *                             C_ZERO,FN11MI,NDSTAT)
C
      CALL ZGEMM('C','N',NUMBQP(0,0),NUMBQP(0,0),LDBASE,
     *                    C_UNIT,ASVQUA(1,1,0,0),NDBASE,
     *                           ASVQUA(1,1,0,0),NDBASE,
     *                             C_UNIT,FN11MI,NDSTAT)
C
C      Contribution from the protons
C
      CALL ZGEMM('C','N',NUMBQP(1,1),NUMBQP(1,1),LDBASE,
     *                    C_ZERO,BSVQUA(1,1,1,1),NDBASE,
     *                           BSVQUA(1,1,1,1),NDBASE,
     *                             C_ZERO,FP11MI,NDSTAT)
C
      CALL ZGEMM('C','N',NUMBQP(0,1),NUMBQP(0,1),LDBASE,
     *                    C_UNIT,ASVQUA(1,1,0,1),NDBASE,
     *                           ASVQUA(1,1,0,1),NDBASE,
     *                             C_UNIT,FP11MI,NDSTAT)
C
C
C      Computing \tilde{N}^{20}^{T} for positive simplex
C
C      Contribution from the neutrons
C
C      U_{+}^{+} V_{*} = A_{T}^{+}B_{+}
C
      CALL ZGEMM('T','N',NUMBQP(0,0),NUMBQP(0,0),LDBASE,
     *                    C_UNIT,ASVQUA(1,1,0,0),NDBASE,
     *                           BSVQUA(1,1,0,0),NDBASE,
     *                             C_ZERO,FN20PL,NDSTAT)
C
C      Contribution from the protons
C
      CALL ZGEMM('T','N',NUMBQP(0,1),NUMBQP(0,1),LDBASE,
     *                    C_UNIT,ASVQUA(1,1,0,1),NDBASE,
     *                           BSVQUA(1,1,0,1),NDBASE,
     *                             C_ZERO,FP20PL,NDSTAT)
C
      DN2QUA=0.0D0
      DN2STA=0.0D0
C
C      Attention: FN11PL and FN11MI contain the transposed matrix
C                 of N^{11} for the positive and negative simplex
C                 blocks
C      Attention: In the loops below, we assume that
C                 NUMBQP(0,ICHARG)=NUMBQP(1,ICHARG)
C                 This is *not* true in the most general case, in
C                 particular when time-reversal symmetry or simplex
C                 is broken. As of version 250i, these cases can not
C                 be combined with T>0, so it's OK.
C
      DO J=1,NUMBQP(0,0)
         DO I=1,NUMBQP(0,0)
C
            DN2QUA = DN2QUA + (ABS(FN11PL(J,I))**2
     *                       + ABS(FN11MI(J,I))**2)
     *                          * (FERMFN(I,0) - FERMFN(J,0))
     *                      +  ABS(FN20PL(I,J))**2*
     *                      (1.0D0-FERMFN(I,0) - FERMFN(J,0))
C
            DN2STA = DN2STA + 2.0D0*(ABS(FN11PL(J,I))**2
     *                             + ABS(FN11MI(J,I))**2)
     *           * (FERMFN(J,0)*(1.0D0 - FERMFN(I,0)))
     *                      + 2.0D0* ABS(FN20PL(I,J))**2
     *                      *FERMFN(I,0)*FERMFN(J,0)
C
         END DO
      END DO
C
      DO I=1,NUMBQP(0,0)
         DN2STA = DN2STA + (ABS(FN11PL(I,I))**2 + ABS(FN11MI(I,I))**2)
     *                       * (FERMFN(I,0)*(1.0D0 -  FERMFN(I,0)))
      END DO
C
      DZ2QUA=0.0
      DZ2STA=0.0
C
      DO J=1,NUMBQP(0,1)
         DO I=1,NUMBQP(0,1)
C
            DZ2QUA = DZ2QUA + (ABS(FP11PL(J,I))**2
     *                       + ABS(FP11MI(J,I))**2)
     *                          * (FERMFN(I,1) - FERMFN(J,1))
     *                      +  ABS(FP20PL(I,J))**2*
     *                      (1.0D0-FERMFN(I,1) - FERMFN(J,1))
C
            DZ2STA = DZ2STA + 2.0D0*(ABS(FP11PL(J,I))**2
     *                             + ABS(FP11MI(J,I))**2)
     *           * (FERMFN(J,1)*(1.0D0 - FERMFN(I,1)))
     *                      + 2.0D0* ABS(FP20PL(I,J))**2
     *                      *FERMFN(I,1)*FERMFN(J,1)
C
         END DO
      END DO
C
      DO I=1,NUMBQP(0,1)
         DZ2STA = DZ2STA + (ABS(FP11PL(I,I))**2 + ABS(FP11MI(I,I))**2)
     *                       * (FERMFN(I,1)*(1.0D0 -  FERMFN(I,1)))
      END DO
C
C=======================================================================
      DEALLOCATE(FP20PL,FN20PL)
      DEALLOCATE(FN11PL,FN11MI)
      DEALLOCATE(FP11PL,FP11MI)
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PRI_FT()
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /GCTEMP/ TEMP_T
      COMMON
     *       /SENTRO/ ENTRPY(0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C      Calculating the particle number dispersions (quantum and
C      statistical)
C
      DZ2QUA=0.0D0
      DN2QUA=0.0D0
      DZ2STA=0.0D0
      DN2STA=0.0D0
C
      CALL DISPER(DN2QUA,DN2STA,DZ2QUA,DZ2STA)
C
      WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *       ''*  FINITE-TEMPERATURE HFB CALCULATIONS AT '',
     *       ''T = '',F8.4,'' MEV                    *'',/,
     *       ''*'',77X,''*'',/,
     *       ''*  ENTROPY       PROTONS: '',F11.6,
     *       '' MEV   NEUTRONS: '',F11.6,'' MEV         *'',/,
     *       ''*  <dN^2>_QF     PROTONS: '',F11.6,
     *       ''       NEUTRONS: '',F11.6,''             *'',/,
     *       ''*  <dN^2>_SF     PROTONS: '',F11.6,
     *       ''       NEUTRONS: '',F11.6,''             *'',/,
     *               ''*'',77X,''*'',/,79(''*''),/)')
     *            TEMP_T,ENTRPY(1),ENTRPY(0),DZ2QUA,DN2QUA,
     *                                       DZ2STA,DN2STA
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LIPCOR(G_PAIR,FACTGX,FE2FIX,IF2FIX,I_SLOW,SLOWLI,
     *                                       EFER2X,NUMITE,ICHARG)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CAOCNP/ V2OCNP(1:4*NDBASE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMAT/ NOIINP,MIXMAT
C
C=======================================================================
C        THIS SUBROUTINE DETERMINES THE LIPKIN-NOGAMI LAMBDA2 AND ENERGY
C=======================================================================
C
                       NBROYD=IBROYD
      IF (NUMITE.LE.0) NBROYD=0
C
      IF (NUMITE.LE.0.OR.NBROYD.GE.1.OR.I_SLOW.EQ.1) THEN
          XOLDLI=0.0
      ELSE
          XOLDLI=SLOWLI
      END IF
C
      XNEWLI=1.0-XOLDLI
C
C=======================================================================
C        ATTENTION: IN CASE OF THE CONSERVED TIME-REVERSAL  SYMMETRY
C                   THIS SUBROUTINE IS CALLED WITH MREVER=0, AND THE
C                   LIPKIN-NOGAMI SUMS ARE DOUBLED.
C=======================================================================
C
      S_U1V1=0.0D0
      S_U1V3=0.0D0
      S_U2V2=0.0D0
      S_U3V1=0.0D0
      S_U4V4=0.0D0
C
C=======================================================================
C        CALCULATING THE LIPKIN-NOGAMI SUMS
C=======================================================================
C
      DO ISTATE=1,2*LDBASE
C
         IF (V2OCNP(ISTATE,ICHARG).GE.0.0D0) THEN
             V_ACTU=SQRT(V2OCNP(ISTATE,ICHARG))
         ELSE
             V_ACTU=0.0D0
         END IF
C
         IF (V2OCNP(ISTATE,ICHARG).LE.1.0D0) THEN
             U_ACTU=SQRT(1.0D0-V2OCNP(ISTATE,ICHARG))
         ELSE
             U_ACTU=0.0D0
             V_ACTU=1.0D0
         END IF
C
         S_U1V1 = S_U1V1 + U_ACTU    * V_ACTU
         S_U1V3 = S_U1V3 + U_ACTU    * V_ACTU**3
         S_U2V2 = S_U2V2 + U_ACTU**2 * V_ACTU**2
         S_U3V1 = S_U3V1 + U_ACTU**3 * V_ACTU
         S_U4V4 = S_U4V4 + U_ACTU**4 * V_ACTU**4
C
      END DO
C
C=======================================================================
C
      DENUME=S_U3V1*S_U1V3 - 2.0*S_U4V4
      DENOMI=S_U2V2*S_U2V2 - 2.0*S_U4V4
C
      IF (DENOMI.LE.0.0D0) THEN
C
          EFER2Y=0.0D0
      ELSE
          EFER2Y=0.25D0*G_PAIR*FACTGX*DENUME/DENOMI
C
      END IF
C
      IF (IF2FIX.EQ.1) THEN
C
          EFER2X=FE2FIX
      ELSE
          EFER2X=XOLDLI*EFER2X + XNEWLI*EFER2Y
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVOBSE(MREVER,ICHARG,IPNMIX,NRAORD)
C=======================================================================
      USE ALLWAV
      USE PNMWAV
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      CHARACTER
     *          SPKART*10,SPNILS*15,SPORDE*13
      CHARACTER
     *          PNKART*10,PNNILS*15,PNORDE*13
C
C=======================================================================
      ALLOCATABLE HAUXPP(:,:)
C=======================================================================
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /SPLABS/ SPKART(1:2*NDSTAT,0:NDISOS),
     *                SPNILS(1:2*NDSTAT,0:NDISOS),
     *                SPORDE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPRADI/ SPSIZE(1:2*NDSTAT,0:NDISOS,0:NDKART)
      COMMON
     *       /SPRHIG/ SPRORD(1:2*NDSTAT,0:NDISOS,1:NDMORD)
      COMMON
     *       /SPMOME/ SPMO20(1:2*NDSTAT,0:NDISOS),
     *                SPMO22(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /PNLABS/ PNKART(1:4*NDSTAT),
     *                PNNILS(1:4*NDSTAT),
     *                PNORDE(1:4*NDSTAT)
      COMMON
     *       /PNRADI/ PNSIZE(1:4*NDSTAT,0:NDKART)
      COMMON
     *       /PNMOME/ PNMO20(1:4*NDSTAT),
     *                PNMO22(1:4*NDSTAT)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('AVOBSE',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPP','AVOBSE')
C=======================================================================
C
C=======================================================================
C     THIS ROUTINE CALCULATES VARIOUS SINGLE-PARTICLE AVERAGES
C=======================================================================
C
C=======================================================================
C     CALCULATING THE 'DOMINATING' CARTESIAN LABELS
C=======================================================================
C
      IF (IPNMIX.NE.1) THEN
C
          LSTATE=NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG)
C
          DO ISTATE=1,LSTATE
C
             INDMAX=0
             ELEMAX=-1.0
C
             DO IBASE=1,LDBASE
C
                AMPLT2=REAL(WAVOCC(IBASE,ISTATE,0)
     *               *CONJG(WAVOCC(IBASE,ISTATE,0))
     *                     +WAVOCC(IBASE,ISTATE,1)
     *               *CONJG(WAVOCC(IBASE,ISTATE,1)))
C
                IF (ELEMAX.LT.AMPLT2) THEN
                    INDMAX=IBASE
                    ELEMAX=AMPLT2
                END IF
C
             END DO
C
             IF (INDMAX.LE.0.OR.INDMAX.GT.LDBASE) THEN
                 WRITE(NFIPRI,'(''INDMAX = '',I10,'' LDBASE = '',I10)')
     *                            INDMAX,LDBASE
                 STOP '  WRONG INDEX 1 IN AVOBSE'
             END IF
C
             WRITE(SPKART(ISTATE,ICHARG),
     *             '(''|'',I2,'','',I2,'','',I2,''>'')')
     *          NXVECT(INDMAX,1),NYVECT(INDMAX,1),NZVECT(INDMAX,1)
C
          END DO
C
      ELSE
C
          LSTATE=NUMBSP(0,0)+NUMBSP(0,1)
     *                                 +MREVER*(NUMBSP(1,0)+NUMBSP(1,1))
C
          DO ISTATE=1,LSTATE
C
             INDMAX=0
             ELEMAX=-1.0
C
             DO IBASE=1,2*LDBASE
C
                AMPLT2=REAL(PNMOCC(IBASE,ISTATE,0)
     *               *CONJG(PNMOCC(IBASE,ISTATE,0))
     *                     +PNMOCC(IBASE,ISTATE,1)
     *               *CONJG(PNMOCC(IBASE,ISTATE,1)))
C
                IF (ELEMAX.LT.AMPLT2) THEN
                    INDMAX=IBASE
                    ELEMAX=AMPLT2
                END IF
C
             END DO
C
             IF (INDMAX.GT.LDBASE.AND.INDMAX.LE.2*LDBASE)
     *                                              INDMAX=INDMAX-LDBASE
C
             IF (INDMAX.LE.0.OR.INDMAX.GT.LDBASE) THEN
                 WRITE(NFIPRI,'(''INDMAX = '',I10,'' LDBASE = '',I10)')
     *                            INDMAX,LDBASE
                 STOP '  WRONG INDEX 2 IN AVOBSE'
             END IF
C
             WRITE(PNKART(ISTATE),
     *             '(''|'',I2,'','',I2,'','',I2,''>'')')
     *          NXVECT(INDMAX,1),NYVECT(INDMAX,1),NZVECT(INDMAX,1)
C
          END DO
C
      END IF
C
C=======================================================================
C     CALCULATING RADII
C=======================================================================
C
      IMAREA=+1
      ISIPAR=+1
      ITIPAR=+1
      IHERMI=+1
C
      DO KARTEZ=1,NDKART
C
         CALL INTRAD(HAUXPP,KARTEZ,1)
C
         IF (IPNMIX.NE.1) THEN
C
             CALL SPAVER(SPSIZE(1,ICHARG,KARTEZ),HAUXPP,MREVER,
     *                   ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
         ELSE
             CALL PNAVER(PNSIZE(1,KARTEZ),HAUXPP,MREVER,
     *                   IMAREA,ISIPAR,ITIPAR,IHERMI)
         END IF
C
      END DO
C
      IF (IPNMIX.NE.1) THEN
C
          DO ISTATE=1,LSTATE
C
             SPSIZE(ISTATE,ICHARG,0)=0.0D0
C
             DO KARTEZ=1,NDKART
C
                SPSIZE(ISTATE,ICHARG,0)=SPSIZE(ISTATE,ICHARG,0)
     *                                 +SPSIZE(ISTATE,ICHARG,KARTEZ)
C
             END DO
C
          END DO
      ELSE
          DO ISTATE=1,LSTATE
C
             PNSIZE(ISTATE,0)=0.0D0
C
             DO KARTEZ=1,NDKART
C
                PNSIZE(ISTATE,0)=PNSIZE(ISTATE,0)
     *                          +PNSIZE(ISTATE,KARTEZ)
C
             END DO
C
          END DO
C
      END IF
C
      SPRORD(ISTATE,ICHARG,:)=0.0D0
C
      DO NUMORD=1,NRAORD
C
         CALL INTRAD(HAUXPP,0,NUMORD)
C
         IF (IPNMIX.NE.1) THEN
C
             CALL SPAVER(SPRORD(1,ICHARG,NUMORD),HAUXPP,MREVER,
     *                   ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
         ELSE
             STOP 'FOR IPNMIX=1, NRAORD>0 NOT YET IMPLEMENTED IN AVOBSE'
         END IF
C
      END DO
C
C=======================================================================
C     CALCULATING MULTIPOLE MOMENTS Q20 AND Q22 (REAL PART)
C=======================================================================
C
      LAMBDA=2
      MIU=0
C
      CALL INTMUL(IPHAPP(0,0,0),HAUXPP,COMULT,LAMBDA,MIU,IMAREA)
C
      IF (IPNMIX.NE.1) THEN
C
          CALL SPAVER(SPMO20(1,ICHARG),HAUXPP,MREVER,
     *                ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
      ELSE
          CALL PNAVER(PNMO20(1),HAUXPP,MREVER,
     *                IMAREA,ISIPAR,ITIPAR,IHERMI)
C
      END IF
C
      LAMBDA=2
      MIU=2
C
      CALL INTMUL(IPHAPP(0,0,0),HAUXPP,COMULT,LAMBDA,MIU,IMAREA)
C
      IF (IPNMIX.NE.1) THEN
C
          CALL SPAVER(SPMO22(1,ICHARG),HAUXPP,MREVER,
     *                ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
      ELSE
          CALL PNAVER(PNMO22(1),HAUXPP,MREVER,
     *                IMAREA,ISIPAR,ITIPAR,IHERMI)
C
      END IF
C
C=======================================================================
      DEALLOCATE (HAUXPP)
C=======================================================================
C
      CALL CPUTIM('AVOBSE',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVANGY(MREVER,ICHARG,IPNMIX,ISIMPY,ITWCEN)
C=======================================================================
      USE hfodd_sizes
      USE hfodd_twocen
C=======================================================================
      ALLOCATABLE HAUXPP(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNSTAT/ PNXALI(1:4*NDSTAT),
     *                PNZALI(1:4*NDSTAT),
     *                PNXSPI(1:4*NDSTAT),
     *                PNZSPI(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
C
C=======================================================================
C
      CALL CPUTIM('AVANGY',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPP','AVANGY')
C=======================================================================
C
C=======================================================================
C     THIS ROUTINE CALCULATES TOTAL AND INTRINSIC ALIGNMENTS
C=======================================================================
C     TWO-CENTRE BASIS OPTION: AS NOW SIMPLEX IS IN GENERAL BROKEN AND
C     THE MATRICES CONTAIN 4 CENTRE INNER BLOCKS IN EACH SIMPLEX BLOCK
C     WE CANNOT USE THE REDUCTIONS MADE IN ONE-CENTRE CALCULATIONS.
C     THE STRUCTURE IS AS FOLLOWS:
C     1. OBTAIN MATRIX ELEMENTS OF THE OPERATORS IN TWO-CENTRE BASIS
C        (TWC_LX,...) WHERE THE SIMPLEX PHASE FACTOR ARE NOT INCLUDED.
C     2. WE BUILD THE SIMPLEX MATRIX IN TWC_BIGSIM SPECIFYING WHETHER
C        THE OPERATOR IS REAL/IMAGINARY (IMAREA) AND THE SPIN CARTESIAN
C        COORDINATE 0-3 (KARTEZ).
C     3. WE PUT ALL TOGETHER (SIMPLEX+CENTRES) IN TWC_BIGOBO
C
C     AS WE COMPUTE EXPLICITLY THE PRODUCT OF THE OPERATOR TIMES
C     WAVE FUNCTIONS WE DON'T USE ANY MORE THE SYMMETRY PROPERTIES TO
C     REDUCE THE SIZE OF THE PRODUCTS.
C
C     THE SAME PROCEDURE IS USED WHEN OBTAINING ONE-BODY OPERATOR MEAN
C     VALUES (EKINET, SPIMOM, ETC.)
C=======================================================================
C
      FACTOR=1.0D0
C
      IHERMI=+1
      ITIPAR=-1
C
      ISIPAR=+1
C
C=======================================================================
C         Y-DIRECTION
C=======================================================================
C
      IMAREA=-1
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_LY(IPHAPP(0,0,0),HAUXPP,FACTOR)
C
          IF (IPNMIX.NE.1) THEN
C
              CALL SPAVER(SPALIG(1,ICHARG),HAUXPP,MREVER,
     *                    ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
          ELSE
              CALL PNAVER(PNALIG(1),HAUXPP,MREVER,
     *                    IMAREA,ISIPAR,ITIPAR,IHERMI)
C
          END IF
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          KARTEZ=0
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_LY(HAUXPP,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPP,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
          CALL TWC_SPAVER(SPALIG(1,ICHARG),ICHARG,IMAREA,IHERMI)
C
      END IF
C
      IMAREA=+1
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_SY(HAUXPP,FACTOR)
C
          IF (IPNMIX.NE.1) THEN
C
              CALL SPAVER(SPSPAL(1,ICHARG),HAUXPP,MREVER,
     *                    ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
          ELSE
              CALL PNAVER(PNSPAL(1),HAUXPP,MREVER,
     *                    IMAREA,ISIPAR,ITIPAR,IHERMI)
C
          END IF
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          KARTEZ=2
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_SY(HAUXPP,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPP,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
          CALL TWC_SPAVER(SPSPAL(1,ICHARG),ICHARG,IMAREA,IHERMI)
C
      END IF
C
      IF (ISIMPY.NE.1) THEN
C
          ISIPAR=-1
C
C=======================================================================
C         X-DIRECTION
C=======================================================================
C
          IMAREA=-1
C
          IF (ITWCEN.EQ.1) THEN
C
              CALL INT_LX(IPHAPM(0,0,0),HAUXPP,FACTOR)
C
              IF (IPNMIX.NE.1) THEN
C
                  CALL SPAVER(SPXALI(1,ICHARG),HAUXPP,MREVER,
     *                        ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
              ELSE
                  CALL PNAVER(PNXALI(1),HAUXPP,MREVER,
     *                        IMAREA,ISIPAR,ITIPAR,IHERMI)
C
              END IF
C
          ELSEIF (ITWCEN.EQ.2) THEN
C
              KARTEZ=0
              DO LTWCEN=1,NDTWBL
C
                 CALL TWC_LX(HAUXPP,FACTOR,LTWCEN)
                 CALL TWC_BIGSIM(HAUXPP,LTWCEN,IMAREA,KARTEZ)
C
              END DO
C
              CALL TWC_BIGOBO
              CALL TWC_SPAVER(SPXALI(1,ICHARG),ICHARG,IMAREA,IHERMI)
C
          END IF
C
          IMAREA=+1
C
          IF (ITWCEN.EQ.1) THEN
C
              CALL INT_SX(HAUXPP,FACTOR)
C
              IF (IPNMIX.NE.1) THEN
C
                  CALL SPAVER(SPXSPI(1,ICHARG),HAUXPP,MREVER,
     *                        ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
              ELSE
                  CALL PNAVER(PNXSPI(1),HAUXPP,MREVER,
     *                        IMAREA,ISIPAR,ITIPAR,IHERMI)
              END IF
C
          ELSEIF (ITWCEN.EQ.2) THEN
C
              KARTEZ=1
              DO LTWCEN=1,NDTWBL
C
                 CALL TWC_SX(HAUXPP,FACTOR,LTWCEN)
                 CALL TWC_BIGSIM(HAUXPP,LTWCEN,IMAREA,KARTEZ)
C
              END DO
C
              CALL TWC_BIGOBO
              CALL TWC_SPAVER(SPXSPI(1,ICHARG),ICHARG,IMAREA,IHERMI)
C
          END IF
C
C=======================================================================
C         Z-DIRECTION
C=======================================================================
C
          IMAREA=-1
C
          IF (ITWCEN.EQ.1) THEN
C
              CALL INT_LZ(IPHAPM(0,0,0),HAUXPP,FACTOR)
C
              IF (IPNMIX.NE.1) THEN
C
                  CALL SPAVER(SPZALI(1,ICHARG),HAUXPP,MREVER,
     *                        ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
              ELSE
                  CALL PNAVER(PNZALI(1),HAUXPP,MREVER,
     *                        IMAREA,ISIPAR,ITIPAR,IHERMI)
C
              END IF
C
              CALL INT_SZ(HAUXPP,FACTOR)
C
              IF (IPNMIX.NE.1) THEN
C
                  CALL SPAVER(SPZSPI(1,ICHARG),HAUXPP,MREVER,
     *                        ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
              ELSE
                  CALL PNAVER(PNZSPI(1),HAUXPP,MREVER,
     *                        IMAREA,ISIPAR,ITIPAR,IHERMI)
C
              END IF
C
          ELSEIF (ITWCEN.EQ.2) THEN
C
              KARTEZ=0
              DO LTWCEN=1,NDTWBL
C
                 CALL TWC_LZ(HAUXPP,FACTOR,LTWCEN)
                 CALL TWC_BIGSIM(HAUXPP,LTWCEN,IMAREA,KARTEZ)
C
              END DO
C
              CALL TWC_BIGOBO
              CALL TWC_SPAVER(SPZALI(1,ICHARG),ICHARG,IMAREA,IHERMI)
C
              KARTEZ=3
              DO LTWCEN=1,NDTWBL
C
                CALL TWC_SZ(HAUXPP,FACTOR,LTWCEN)
                CALL TWC_BIGSIM(HAUXPP,LTWCEN,IMAREA,KARTEZ)
C
              END DO
C
              CALL TWC_BIGOBO
              CALL TWC_SPAVER(SPZSPI(1,ICHARG),ICHARG,IMAREA,IHERMI)

          END IF
C
      END IF
C
C=======================================================================
C
      IF (IPNMIX.NE.1) THEN
C
          LSTATE=NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG)
C
          DO ISTATE=1,LSTATE
C
             SPALIG(ISTATE,ICHARG)=SPALIG(ISTATE,ICHARG)
     *                            +SPSPAL(ISTATE,ICHARG)
             SPXALI(ISTATE,ICHARG)=SPXALI(ISTATE,ICHARG)
     *                            +SPXSPI(ISTATE,ICHARG)
             SPZALI(ISTATE,ICHARG)=SPZALI(ISTATE,ICHARG)
     *                            +SPZSPI(ISTATE,ICHARG)
C
          END DO
C
      ELSE
C
          LSTATE=NUMBSP(0,0)+NUMBSP(0,1)
     *                                 +MREVER*(NUMBSP(1,0)+NUMBSP(1,1))
          DO ISTATE=1,LSTATE
C
             PNALIG(ISTATE)=PNALIG(ISTATE)
     *                     +PNSPAL(ISTATE)
             PNXALI(ISTATE)=PNXALI(ISTATE)
     *                     +PNXSPI(ISTATE)
             PNZALI(ISTATE)=PNZALI(ISTATE)
     *                     +PNZSPI(ISTATE)
C
          END DO
C
      END IF
C
C=======================================================================
      DEALLOCATE (HAUXPP)
C=======================================================================
C
      CALL CPUTIM('AVANGY',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE OLSTOR
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          SPKART*10,SPNILS*15,SPORDE*13,QPORDD*13
      CHARACTER
     *          OLKART*10,OLNILS*15,OLORDE*13,QLNILS*15,QLORDD*13
      CHARACTER
     *          PNKART*10,PNNILS*15,PNORDE*13
      CHARACTER
     *          ONKART*10,ONNILS*15,ONORDE*13
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLABS/ SPKART(1:2*NDSTAT,0:NDISOS),
     *                SPNILS(1:2*NDSTAT,0:NDISOS),
     *                SPORDE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLOLD/ OLALIG(1:2*NDSTAT,0:NDISOS),
     *                OLSPAL(1:2*NDSTAT,0:NDISOS),
     *                OLPARI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSOLD/ OLXALI(1:2*NDSTAT,0:NDISOS),
     *                OLZALI(1:2*NDSTAT,0:NDISOS),
     *                OLXSPI(1:2*NDSTAT,0:NDISOS),
     *                OLZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPKOLD/ OLKART(1:2*NDSTAT,0:NDISOS),
     *                OLNILS(1:2*NDSTAT,0:NDISOS),
     *                OLORDE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNSTAT/ PNXALI(1:4*NDSTAT),
     *                PNZALI(1:4*NDSTAT),
     *                PNXSPI(1:4*NDSTAT),
     *                PNZSPI(1:4*NDSTAT)
      COMMON
     *       /PNLABS/ PNKART(1:4*NDSTAT),
     *                PNNILS(1:4*NDSTAT),
     *                PNORDE(1:4*NDSTAT)
      COMMON
     *       /PNLOLD/ ONALIG(1:4*NDSTAT),
     *                ONSPAL(1:4*NDSTAT),
     *                ONPARI(1:4*NDSTAT)
      COMMON
     *       /PNSOLD/ ONXALI(1:4*NDSTAT),
     *                ONZALI(1:4*NDSTAT),
     *                ONXSPI(1:4*NDSTAT),
     *                ONZSPI(1:4*NDSTAT)
      COMMON
     *       /PNKOLD/ ONKART(1:4*NDSTAT),
     *                ONNILS(1:4*NDSTAT),
     *                ONORDE(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
C
C=======================================================================
C         THIS SUBROUTINE STORES SINGLE-PARTICLE  PROPERTIES
C         TO MAKE IT AVAILABLE FOR USE IN THE NEXT ITERATION.
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            OLALIG(ISTATE,ICHARG)=SPALIG(ISTATE,ICHARG)
            OLSPAL(ISTATE,ICHARG)=SPSPAL(ISTATE,ICHARG)
            OLPARI(ISTATE,ICHARG)=SPPARI(ISTATE,ICHARG)
C
            OLXALI(ISTATE,ICHARG)=SPXALI(ISTATE,ICHARG)
            OLZALI(ISTATE,ICHARG)=SPZALI(ISTATE,ICHARG)
            OLXSPI(ISTATE,ICHARG)=SPXSPI(ISTATE,ICHARG)
            OLZSPI(ISTATE,ICHARG)=SPZSPI(ISTATE,ICHARG)
C
            OLKART(ISTATE,ICHARG)=SPKART(ISTATE,ICHARG)
            OLNILS(ISTATE,ICHARG)=SPNILS(ISTATE,ICHARG)
            OLORDE(ISTATE,ICHARG)=SPORDE(ISTATE,ICHARG)
C
         END DO
C
      END DO
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         ONALIG(ISTATE)=PNALIG(ISTATE)
         ONSPAL(ISTATE)=PNSPAL(ISTATE)
         ONPARI(ISTATE)=PNPARI(ISTATE)
C
         ONXALI(ISTATE)=PNXALI(ISTATE)
         ONZALI(ISTATE)=PNZALI(ISTATE)
         ONXSPI(ISTATE)=PNXSPI(ISTATE)
         ONZSPI(ISTATE)=PNZSPI(ISTATE)
C
         ONKART(ISTATE)=PNKART(ISTATE)
         ONNILS(ISTATE)=PNNILS(ISTATE)
         ONORDE(ISTATE)=PNORDE(ISTATE)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SPZERO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /QPLEVS/ QPENER(1:4*NDSTAT,0:NDISOS),
     *                QPOCCU(1:4*NDSTAT,0:NDISOS),
     *                QPPARR(1:4*NDSTAT,0:NDISOS),
     *                QPEEQU(1:4*NDSTAT,0:NDISOS),
     *                QPDEQU(1:4*NDSTAT,0:NDISOS),
     *                QPCORR(1:4*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPRADI/ SPSIZE(1:2*NDSTAT,0:NDISOS,0:NDKART)
      COMMON
     *       /SPRHIG/ SPRORD(1:2*NDSTAT,0:NDISOS,1:NDMORD)
      COMMON
     *       /SPMOME/ SPMO20(1:2*NDSTAT,0:NDISOS),
     *                SPMO22(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNSTAT/ PNXALI(1:4*NDSTAT),
     *                PNZALI(1:4*NDSTAT),
     *                PNXSPI(1:4*NDSTAT),
     *                PNZSPI(1:4*NDSTAT)
      COMMON
     *       /PNRADI/ PNSIZE(1:4*NDSTAT,0:NDKART)
      COMMON
     *       /PNMOME/ PNMO20(1:4*NDSTAT),
     *                PNMO22(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
C
C=======================================================================
C         THIS SUBROUTINE PUTS ZEROS INTO THE SINGLE-PARTICLE PROPERTIES
C                                         AND  QUASI-PARTICLE PROPERTIES
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            SPENER(ISTATE,ICHARG)=0.0D0
            SPOCCU(ISTATE,ICHARG)=0.0D0
            SPALIG(ISTATE,ICHARG)=0.0D0
            SPSPAL(ISTATE,ICHARG)=0.0D0
            SPPARI(ISTATE,ICHARG)=0.0D0
            SPSIMP(ISTATE,ICHARG)=0.0D0
C
            SPXALI(ISTATE,ICHARG)=0.0D0
            SPZALI(ISTATE,ICHARG)=0.0D0
            SPXSPI(ISTATE,ICHARG)=0.0D0
            SPZSPI(ISTATE,ICHARG)=0.0D0
C
            SPMO20(ISTATE,ICHARG)=0.0D0
            SPMO22(ISTATE,ICHARG)=0.0D0
C
            SPSIZE(ISTATE,ICHARG,1)=0.0D0
            SPSIZE(ISTATE,ICHARG,2)=0.0D0
            SPSIZE(ISTATE,ICHARG,3)=0.0D0
C
            SPRORD(ISTATE,ICHARG,:)=0.0D0
C
         END DO
C
      END DO
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         PNENER(ISTATE)=0.0D0
         PNOCCU(ISTATE)=0.0D0
         PNALIG(ISTATE)=0.0D0
         PNSPAL(ISTATE)=0.0D0
         PNPARI(ISTATE)=0.0D0
         PNSIMP(ISTATE)=0.0D0
         PNISOS(ISTATE)=0.0D0
C
         PNXALI(ISTATE)=0.0D0
         PNZALI(ISTATE)=0.0D0
         PNXSPI(ISTATE)=0.0D0
         PNZSPI(ISTATE)=0.0D0
C
         PNMO20(ISTATE)=0.0D0
         PNMO22(ISTATE)=0.0D0
C
         PNSIZE(ISTATE,1)=0.0D0
         PNSIZE(ISTATE,2)=0.0D0
         PNSIZE(ISTATE,3)=0.0D0
C
      END DO
C
      QPENER=0.0D0
      QPOCCU=0.0D0
      QPPARR=0.0D0
      QPEEQU=0.0D0
      QPDEQU=0.0D0
      QPCORR=0.0D0
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SPTALL(EMINAL,EMAXAL,SPMODL,NAMEPN,
     *                  ISIGNY,ISIMPY,ISIQTY,MPAHFB,
     *                         MREVER,ICHARG,NILXYZ,
     *                  IDSIGB,IDSIMB,IDSIQB,IDSIZB,NRAORD,
     *                                              ITWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      CHARACTER
     *          SPKART*10,SPNILS*15,SPORDE*13
      CHARACTER
     *          NAMEPN*8,GFACTO*7,NAMSYM(0:3)*13,NAMLAB(3)*10
      CHARACTER
     *          SPMODL*14
      CHARACTER
     *          BLOLIN*80,LINE*80
C
      DIMENSION
     *          EORDER(1:2*NDSTAT),NORDER(1:2*NDSTAT),
     *          NSTATE(1:2*NDSTAT),NREVER(1:2*NDSTAT)
      DIMENSION
     *          N_PPRP(1:2*NDSTAT),N_PPRM(1:2*NDSTAT),
     *          N_PMRP(1:2*NDSTAT),N_PMRM(1:2*NDSTAT),
     *          NSIGVP(1:2*NDSTAT),NSIGVS(1:2*NDSTAT)
      DIMENSION
     *          N_SIMP(1:2*NDSTAT),N_SIMM(1:2*NDSTAT),NSIMVA(1:2*NDSTAT)
      DIMENSION
     *          N_SIQP(1:2*NDSTAT),N_SIQM(1:2*NDSTAT),NSIQVA(1:2*NDSTAT)
      DIMENSION
     *          IDSIQB(1:NDBLOC)
      DIMENSION
     *          IDSIZB(1:NDBLOC)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLABS/ SPKART(1:2*NDSTAT,0:NDISOS),
     *                SPNILS(1:2*NDSTAT,0:NDISOS),
     *                SPORDE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPRHIG/ SPRORD(1:2*NDSTAT,0:NDISOS,1:NDMORD)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /LINBLO/ BLOLIN(1:3*NDBLOC,0:NDISOS),NLIBLO(0:NDISOS)
      COMMON
     *       /SPBNUM/ INUSPB(1:NDBLOC,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /TWCDIA/ TWCSPE(1:2*NDSTAT,0:NDISOS)
C
      DATA
     *      NAMSYM /'  (S=+,S=-)  ','(++,+-,-+,--)',
     *              ' <Y-SIMPLEX> ','  (P=+,P=-)  '/
      DATA
     *      NAMLAB /'nx,lx,OMEx',
     *              'ny,ly,OMEy',
     *              'nz,lz,OMEz'/
C
C=======================================================================
C         THIS ROUTINE TABULATES SINGLE-PARTICLE RESULTS IN THE FORM
C         OF A COMMON TABLE FOR ALL SYMMETRIES
C=======================================================================
C
C=======================================================================
C         DETERMINING THE ORDERED SINGLE-PARTICLE SPECTRUM
C=======================================================================
C
      IF (ITWCEN.EQ.2) THEN
C
         DO IALLST=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            SPENER(IALLST,ICHARG)=TWCSPE(IALLST,ICHARG)
C
         END DO
C
      END IF
C
      IORDER=0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            IORDER=IORDER+1
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
            NSTATE(IORDER)=ISTATE
            NREVER(IORDER)=IREVER
C
         END DO
C
      END DO
C
      LDORDE=IORDER
C
      CALL ORDER1(EORDER,NORDER,LDORDE)
C
C=======================================================================
C         DETERMINING LABELS "SPORDE" IN THE CASE OF CONSERVED SIMPLEX
C=======================================================================
C
      IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C         CALCULATING THE NUMBERS OF OCCUPIED STATES
C         IN EVERY PARITY/TIME-REVERSAL BLOCK, AND
C         IN EVERY SIMPLEX BLOCK.
C=======================================================================
C
          NUPPRP=0
          NUPPRM=0
          NUPMRP=0
          NUPMRM=0
C
          NUSIMP=0
          NUSIMM=0
C
          DO IALLST=1,LDORDE
C
             ISTATE=NSTATE(NORDER(IALLST))
             IREVER=NREVER(NORDER(IALLST))
C
C=======================================================================
C        HERE THE PARITY/TIME-REVERSAL BLOCKS ARE CONSIDERED
C=======================================================================
C
             IF (ISIGNY.EQ.1) THEN
C
                 N_PPRP(IALLST)=0
                 N_PPRM(IALLST)=0
                 N_PMRP(IALLST)=0
                 N_PMRM(IALLST)=0
C
                 IF (SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                                     .GT.0.0) THEN
C
                     NSIGVP(IALLST)=0
C
                     IF (IREVER.EQ.0) THEN
C
                         NUPPRP=NUPPRP+1
                         N_PPRP(IALLST)=NUPPRP
                         NSIGVS(IALLST)=0
                     ELSE
                         NUPPRM=NUPPRM+1
                         N_PPRM(IALLST)=NUPPRM
                         NSIGVS(IALLST)=1
C
                     END IF
C
                 ELSE
C
                     NSIGVP(IALLST)=1
C
                     IF (IREVER.EQ.0) THEN
C
                         NUPMRP=NUPMRP+1
                         N_PMRP(IALLST)=NUPMRP
                         NSIGVS(IALLST)=1
                     ELSE
                         NUPMRM=NUPMRM+1
                         N_PMRM(IALLST)=NUPMRM
                         NSIGVS(IALLST)=0
C
                     END IF
C
                 END IF
C
             ELSE
C
C=======================================================================
C        HERE THE SIMPLEX BLOCKS ARE CONSIDERED
C=======================================================================
C
                 N_SIMP(IALLST)=0
                 N_SIMM(IALLST)=0
C
                 IF (IREVER.EQ.0) THEN
C
                     NUSIMP=NUSIMP+1
                     N_SIMP(IALLST)=NUSIMP
                     NSIMVA(IALLST)=0
                 ELSE
                     NUSIMM=NUSIMM+1
                     N_SIMM(IALLST)=NUSIMM
                     NSIMVA(IALLST)=1
C
                 END IF
C
             END IF
C
             IF (ISIGNY.EQ.1) THEN
C
C=======================================================================
C            PARITY/SIGNATURE CASE:
C                       THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                       THE "SPORDE" LABELS WITH THE  (PARITY,IREVER)
C                       BLOCKS ORDERED AS: (+,+)  (+,-)  (-,-)  (-,+)
C=======================================================================
C
                 IF (MREVER.EQ.1) THEN
C
                     WRITE(SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                  ,'(''('',I2,3('','',I2),'')'')')
     *
     *                 N_PPRP(IALLST),N_PPRM(IALLST),
     *                 N_PMRM(IALLST),N_PMRP(IALLST)
C
                 ELSE
C
                     WRITE(SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                               ,'(''('',I2,'' ----- '',I2,'')'')')
     *
     *                 N_PPRP(IALLST),N_PMRP(IALLST)
C
                 END IF
C
             ELSE
C
C=======================================================================
C            SIMPLEX CASE:
C                       THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                       THE "SPORDE" LABELS WITH THE  (SIMPLEX)
C                       BLOCKS ORDERED AS: (+) (-)
C=======================================================================
C
                 IF (MREVER.EQ.1) THEN
C
                     WRITE(SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                 ,'(''  ('',I3,'','',I3,'')  '')')
     *
     *                     N_SIMP(IALLST),N_SIMM(IALLST)
C
                 ELSE
C
                     WRITE(SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                      ,'(''  ('',I3,'',---)  '')')
     *
     *                     N_SIMP(IALLST)
C
                 END IF
C
             END IF
C
          END DO
C
      ELSE
C
C=======================================================================
C         DETERMINING LABELS "SPORDE" FOR NON CONSERVED SIMPLEX
C=======================================================================
C
          IF (ISIQTY.EQ.1) THEN
C
C=======================================================================
C             HERE THE PARITY BLOCKS ARE CONSIDERED
C=======================================================================
C
              NUPARP=0
              NUPARM=0
C
              DO IALLST=1,LDORDE
C
                 ISTATE=NSTATE(NORDER(IALLST))
                 IREVER=NREVER(NORDER(IALLST))
C
                 N_SIQP(IALLST)=0
                 N_SIQM(IALLST)=0
C
                 IF (SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                                     .GT.0.0) THEN
C
                     NUPARP=NUPARP+1
                     N_SIQP(IALLST)=NUPARP
                     NSIQVA(IALLST)=0
C
                 ELSE
C
                     NUPARM=NUPARM+1
                     N_SIQM(IALLST)=NUPARM
                     NSIQVA(IALLST)=1
C
                 END IF
C
C=======================================================================
C                THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                THE "SPORDE" LABELS WITH THE  (PARITY) BLOCKS
C                ORDERED AS: (+)  (-)
C=======================================================================
C
                 WRITE(SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                             ,'(''  ('',I3,'','',I3,'')  '')')
     *
     *                 N_SIQP(IALLST),N_SIQM(IALLST)
C
              END DO
C
          ELSE
C
C=======================================================================
C             HERE THE NO-SYMMETRY CASE IS CONSIDERED
C=======================================================================
C
              DO IALLST=1,LDORDE
C
                 ISTATE=NSTATE(NORDER(IALLST))
                 IREVER=NREVER(NORDER(IALLST))
C
                 WRITE(SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                     ,'(F10.4,3X)')
     *
     *                 SPSIMP(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C         PRINTING THE TABLE
C=======================================================================
C
      NLIBLO(ICHARG)=0
C
      IF (EMINAL.LT.EMAXAL) THEN
C
          IF (ISIMPY.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *                 1H*,2X,''SINGLE-PARTICLE PROPERTIES: '',
     *                               A14,''                 '',
     *                                          6X,A8,2X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*,/,
     *                 1H*,2X,''NO)   ENERGY '',A13,
     *                        '' | N,'',A10,''>   <P> '',
     *                    3X,''<JY>    <SY>   GFACT'',3X,1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *       SPMODL,NAMEPN,NAMSYM(ISIGNY),NAMLAB(NILXYZ)
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *                 1H*,2X,''SINGLE-PARTICLE PROPERTIES: '',
     *                               A14,''                 '',
     *                                          6X,A8,2X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*,/,
     *                 1H*,2X,''NO)   ENERGY '',A13,
     *                        '' | N,'',A10,''>   <P> '',
     *                    3X,''<JX>    <JY>    <JZ>'',3X,1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *       SPMODL,NAMEPN,NAMSYM(ISIQTY+2),NAMLAB(NILXYZ)
C
          END IF
C
      END IF
C
C=======================================================================
C
      DO IALLST=1,LDORDE
C
         ISTATE=NSTATE(NORDER(IALLST))
         IREVER=NREVER(NORDER(IALLST))
C
         IF (SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG).GT.EMINAL
     *                                                             .AND.
     *       SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG).LT.EMAXAL)
     *                                                              THEN
C
             ALIAUX=SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
             PARITY=SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
             IF (ABS(ALIAUX).GE.1.0D-10) THEN
C
                 FACTOR=SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                                           /ALIAUX
C
                 IF (ABS(FACTOR).GE.10.0D0)    THEN
                     WRITE(GFACTO,'(1PE7.0)') FACTOR
                 ELSE
                     WRITE(GFACTO,'(  F7.3)') FACTOR
                 END IF
C
             ELSE
                 GFACTO='  XXXXX'
             END IF
C
             IF (ISIMPY.EQ.1) THEN
C
                 WRITE(NFIPRI,'(1H*,I4,'')'',F9.3,1X,A13,1X,A15,I6,
     *                                             2F8.3,1X,A7,3X,1H*)')
     *
     *           IALLST,SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPNILS(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  INT(SIGN(ABS(PARITY)*100+0.1,PARITY)),
     *                  SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  GFACTO
C
             ELSE
C
                 WRITE(NFIPRI,'(1H*,I4,'')'',F9.3,1X,A13,1X,A15,I6,
     *                                                   3F8.3,3X,1H*)')
     *
     *           IALLST,SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPNILS(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  INT(SIGN(ABS(PARITY)*100+0.1,PARITY)),
     *                  SPXALI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPZALI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                 WRITE(NFIPRI,'(1H*,50X,3F8.3,3X,1H*)')
     *
     *                  SPXSPI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                  SPZSPI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
C=======================================================================
C                THIS RESTRICTION ON PRINTING THE BLOCKED-STATE DATA HAS
C                BEEN REMOVED IN VERSION (3.18I) ON 07/04/2023
C=======================================================================
C
C                IF (MPAHFB.LT.1) THEN
C
C=======================================================================
C
                     IPRBLO=0
C
                     IF (ISIQTY.EQ.1) THEN
C
                         IF (IABS(IDSIQB(1)).GE.1.AND.
     *                       INUSPB(1,ICHARG).EQ.IALLST) IPRBLO=1
C
                     ELSE
C
                         DO NUBLOC=1,NDBLOC
C
                            IF(IABS(IDSIZB(NUBLOC)).GE.1.AND.
     *                         INUSPB(NUBLOC,ICHARG).EQ.IALLST) IPRBLO=1
C
                         END DO
C
                     END IF
C
                     IF (IPRBLO.EQ.1) THEN
C
                         NLIBLO(ICHARG)=NLIBLO(ICHARG)+1
C
                         IF (NLIBLO(ICHARG).GT.3*NDBLOC)
     *                             STOP ' INCREASE NDBLOC IN SPTALL (1)'
C
                         WRITE(BLOLIN(NLIBLO(ICHARG),ICHARG),
     *                             '(1H*,I4,'')'',F9.3,1X,A13,1X,A15,I6,
     *                                                   3F8.3,3X,1H*)')
     *
     *                   IALLST,
     *                   SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                   SPORDE(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                   SPNILS(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                   INT(SIGN(ABS(PARITY)*100+0.1,PARITY)),
     *                   SPXALI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                   SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                   SPZALI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                         NLIBLO(ICHARG)=NLIBLO(ICHARG)+1
C
                         IF (NLIBLO(ICHARG).GT.3*NDBLOC)
     *                             STOP ' INCREASE NDBLOC IN SPTALL (2)'
C
                         WRITE(BLOLIN(NLIBLO(ICHARG),ICHARG),
     *                                         '(1H*,50X,3F8.3,3X,1H*)')
     *
     *                   SPXSPI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                   SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG),
     *                   SPZSPI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                         IF (NRAORD.GT.0) THEN
C
                             NLIBLO(ICHARG)=NLIBLO(ICHARG)+1
C
                             IF (NLIBLO(ICHARG).GT.3*NDBLOC)
     *                             STOP ' INCREASE NDBLOC IN SPTALL (3)'
C
                             WRITE (LINE,'(1H*,77X,1H*)')
C
                             IF (NRAORD.GE.1)
     *                           WRITE (LINE(02:24),'(''  SP_RAD**2 ='',
     *                                                          F10.6)')
     *                           SPRORD(ISTATE+IREVER*NUMBSP(0,ICHARG),
     *                                                         ICHARG,1)
                             IF (NRAORD.GE.2)
     *                           WRITE (LINE(25:49),'('', SP_RAD**4 ='',
     *                                                          F12.6)')
     *                           SPRORD(ISTATE+IREVER*NUMBSP(0,ICHARG),
     *                                                         ICHARG,2)
                             IF (NRAORD.GE.3)
     *                           WRITE (LINE(50:76),'('', SP_RAD**6 ='',
     *                                                          F14.6)')
     *                           SPRORD(ISTATE+IREVER*NUMBSP(0,ICHARG),
     *                                                         ICHARG,3)
C
                             WRITE(BLOLIN(NLIBLO(ICHARG),ICHARG),
     *                                                     '(A79)') LINE
                         END IF
C
                     END IF
C
C                END IF (MPAHFB.LT.1
C
             END IF
C
         END IF
C
      END DO
C
      IF (EMINAL.LT.EMAXAL) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE BLOPRI(SPMODL,ISIGNY,ISIMPY,ISIQTY,NILXYZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN*8,NAMSYM(0:3)*13,NAMLAB(3)*10
      CHARACTER
     *          SPMODL*14
      CHARACTER
     *          BLOLIN*80
C
      COMMON
     *       /LINBLO/ BLOLIN(1:3*NDBLOC,0:NDISOS),NLIBLO(0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *      NAMSYM /'  (S=+,S=-)  ','(++,+-,-+,--)',
     *              ' <Y-SIMPLEX> ','  (P=+,P=-)  '/
      DATA
     *      NAMLAB /'nx,lx,OMEx',
     *              'ny,ly,OMEy',
     *              'nz,lz,OMEz'/
C
C=======================================================================
C         THIS ROUTINE TABULATES SINGLE-PARTICLE RESULTS OF THE BLOCKED
C         STATES
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (ICHARG.EQ.0) NAMEPN='NEUTRONS'
         IF (ICHARG.EQ.1) NAMEPN=' PROTONS'
C
         IF (NLIBLO(ICHARG).GE.1) THEN
C
             IF (ISIMPY.EQ.1) THEN
C
                 WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *                 1H*,2X,''SINGLE-PARTICLE BLOCKED STATES: '',
     *                               A14,''                 '',
     *                                          2X,A8,2X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*,/,
     *                 1H*,2X,''NO)   ENERGY '',A13,
     *                        '' | N,'',A10,''>   <P> '',
     *                    3X,''<JY>    <SY>   GFACT'',3X,1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *           SPMODL,NAMEPN,NAMSYM(ISIGNY),NAMLAB(NILXYZ)
C
             ELSE
C
                 WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *                 1H*,2X,''SINGLE-PARTICLE BLOCKED STATES: '',
     *                               A14,''                 '',
     *                                          2X,A8,2X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*,/,
     *                 1H*,2X,''NO)   ENERGY '',A13,
     *                        '' | N,'',A10,''>   <P> '',
     *                    3X,''<JX>    <JY>    <JZ>'',3X,1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *           SPMODL,NAMEPN,NAMSYM(ISIQTY+2),NAMLAB(NILXYZ)
C
             END IF
C
             WRITE(NFIPRI,'(A80)') (BLOLIN(IPRBLO,ICHARG),
     *                                     IPRBLO=1,NLIBLO(ICHARG))
C
             WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
         END IF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PNTALL(EMINAL,EMAXAL,SPMODL,NAMEPN,
     *                         ISIGNY,ISIMPY,ISIQTY,
     *                         MREVER,       NILXYZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PNKART*10,PNNILS*15,PNORDE*13
      CHARACTER
     *          NAMEPN*8,GFACTO*7,NAMSYM(0:3)*13,NAMLAB(3)*10
      CHARACTER
     *          SPMODL*14
C
      DIMENSION
     *          EORDER(1:4*NDSTAT),NORDER(1:4*NDSTAT),
     *          NSTATE(1:4*NDSTAT),NREVER(1:4*NDSTAT)
      DIMENSION
     *          N_PPRP(1:4*NDSTAT),N_PPRM(1:4*NDSTAT),
     *          N_PMRP(1:4*NDSTAT),N_PMRM(1:4*NDSTAT)
      DIMENSION
     *          N_SIMP(1:4*NDSTAT),N_SIMM(1:4*NDSTAT)
      DIMENSION
     *          N_SIQP(1:4*NDSTAT),N_SIQM(1:4*NDSTAT)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNSTAT/ PNXALI(1:4*NDSTAT),
     *                PNZALI(1:4*NDSTAT),
     *                PNXSPI(1:4*NDSTAT),
     *                PNZSPI(1:4*NDSTAT)
      COMMON
     *       /PNLABS/ PNKART(1:4*NDSTAT),
     *                PNNILS(1:4*NDSTAT),
     *                PNORDE(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *      NAMSYM /'  (S=+,S=-)  ','(++,+-,-+,--)',
     *              ' <Y-SIMPLEX> ','  (P=+,P=-)  '/
      DATA
     *      NAMLAB /'nx,lx,OMEx',
     *              'ny,ly,OMEy',
     *              'nz,lz,OMEz'/
C
C=======================================================================
C         THIS ROUTINE TABULATES SINGLE-PARTICLE RESULTS IN THE FORM
C         OF A COMMON TABLE FOR PROTON-NEUTRON MIXED STATES
C=======================================================================
C
C=======================================================================
C         DETERMINING THE ORDERED SINGLE-PARTICLE SPECTRUM
C=======================================================================
C
      IORDER=0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IORDER=IORDER+1
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=PNENER(ISTATE
     *                                +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
            NSTATE(IORDER)=ISTATE
            NREVER(IORDER)=IREVER
C
         END DO
C
      END DO
C
      LDORDE=IORDER
C
      CALL ORDER1(EORDER,NORDER,LDORDE)
C
C=======================================================================
C         DETERMINING LABELS "SPORDE" IN THE CASE OF CONSERVED SIMPLEX
C=======================================================================
C
      IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C         CALCULATING THE NUMBERS OF OCCUPIED STATES
C         IN EVERY PARITY/TIME-REVERSAL BLOCK, AND
C         IN EVERY SIMPLEX BLOCK.
C=======================================================================
C
          NUPPRP=0
          NUPPRM=0
          NUPMRP=0
          NUPMRM=0
C
          NUSIMP=0
          NUSIMM=0
C
          DO IALLST=1,LDORDE
C
             ISTATE=NSTATE(NORDER(IALLST))
             IREVER=NREVER(NORDER(IALLST))
C
C=======================================================================
C        HERE THE PARITY/TIME-REVERSAL BLOCKS ARE CONSIDERED
C=======================================================================
C
             IF (ISIGNY.EQ.1) THEN
C
                 N_PPRP(IALLST)=0
                 N_PPRM(IALLST)=0
                 N_PMRP(IALLST)=0
                 N_PMRM(IALLST)=0
C
                 IF (PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                     .GT.0.0) THEN
C
                     IF (IREVER.EQ.0) THEN
C
                         NUPPRP=NUPPRP+1
                         N_PPRP(IALLST)=NUPPRP
                     ELSE
                         NUPPRM=NUPPRM+1
                         N_PPRM(IALLST)=NUPPRM
C
                     END IF
C
                 ELSE
C
                     IF (IREVER.EQ.0) THEN
C
                         NUPMRP=NUPMRP+1
                         N_PMRP(IALLST)=NUPMRP
                     ELSE
                         NUPMRM=NUPMRM+1
                         N_PMRM(IALLST)=NUPMRM
C
                     END IF
C
                 END IF
C
             ELSE
C
C=======================================================================
C        HERE THE SIMPLEX BLOCKS ARE CONSIDERED
C=======================================================================
C
                 N_SIMP(IALLST)=0
                 N_SIMM(IALLST)=0
C
                 IF (IREVER.EQ.0) THEN
C
                     NUSIMP=NUSIMP+1
                     N_SIMP(IALLST)=NUSIMP
                 ELSE
                     NUSIMM=NUSIMM+1
                     N_SIMM(IALLST)=NUSIMM
C
                 END IF
C
             END IF
C
             IF (ISIGNY.EQ.1) THEN
C
C=======================================================================
C            PARITY/SIGNATURE CASE:
C                       THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                       THE "SPORDE" LABELS WITH THE  (PARITY,IREVER)
C                       BLOCKS ORDERED AS: (+,+)  (+,-)  (-,-)  (-,+)
C=======================================================================
C
                 IF (MREVER.EQ.1) THEN
C
                     WRITE(PNORDE(ISTATE
     *                                +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                  ,'(''('',I2,3('','',I2),'')'')')
     *
     *                 N_PPRP(IALLST),N_PPRM(IALLST),
     *                 N_PMRM(IALLST),N_PMRP(IALLST)
C
                 ELSE
C
                     WRITE(PNORDE(ISTATE
     *                                +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                               ,'(''('',I2,'' ----- '',I2,'')'')')
     *
     *                 N_PPRP(IALLST),N_PMRP(IALLST)
C
                 END IF
C
             ELSE
C
C=======================================================================
C            SIMPLEX CASE:
C                       THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                       THE "SPORDE" LABELS WITH THE  (SIMPLEX)
C                       BLOCKS ORDERED AS: (+) (-)
C=======================================================================
C
                 IF (MREVER.EQ.1) THEN
C
                     WRITE(PNORDE(ISTATE
     *                                +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                 ,'(''  ('',I3,'','',I3,'')  '')')
     *
     *                     N_SIMP(IALLST),N_SIMM(IALLST)
C
                 ELSE
C
                     WRITE(PNORDE(ISTATE
     *                                +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                      ,'(''  ('',I3,'',---)  '')')
     *
     *                     N_SIMP(IALLST)
C
                 END IF
C
             END IF
C
          END DO
C
      ELSE
C
C=======================================================================
C         DETERMINING LABELS "SPORDE" FOR NON CONSERVED SIMPLEX
C=======================================================================
C
          IF (ISIQTY.EQ.1) THEN
C
C=======================================================================
C             HERE THE PARITY BLOCKS ARE CONSIDERED
C=======================================================================
C
              NUPARP=0
              NUPARM=0
C
              DO IALLST=1,LDORDE
C
                 ISTATE=NSTATE(NORDER(IALLST))
                 IREVER=NREVER(NORDER(IALLST))
C
                 N_SIQP(IALLST)=0
                 N_SIQM(IALLST)=0
C
                 IF (PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                     .GT.0.0) THEN
C
                     NUPARP=NUPARP+1
                     N_SIQP(IALLST)=NUPARP
C
                 ELSE
C
                     NUPARM=NUPARM+1
                     N_SIQM(IALLST)=NUPARM
C
                 END IF
C
C=======================================================================
C                THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                THE "SPORDE" LABELS WITH THE  (PARITY) BLOCKS
C                ORDERED AS: (+)  (-)
C=======================================================================
C
                 WRITE(PNORDE(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                             ,'(''  ('',I3,'','',I3,'')  '')')
     *
     *                 N_SIQP(IALLST),N_SIQM(IALLST)
C
              END DO
C
          ELSE
C
C=======================================================================
C             HERE THE NO-SYMMETRY CASE IS CONSIDERED
C=======================================================================
C
              DO IALLST=1,LDORDE
C
                 ISTATE=NSTATE(NORDER(IALLST))
                 IREVER=NREVER(NORDER(IALLST))
C
                 WRITE(PNORDE(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                     ,'(F10.4,3X)')
     *
     *                 PNSIMP(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C         PRINTING THE TABLE
C=======================================================================
C
      IF (EMINAL.LT.EMAXAL) THEN
C
          IF (ISIMPY.EQ.1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *                 1H*,2X,''SINGLE-PARTICLE PROPERTIES: '',
     *                               A14,''                 '',
     *                                          6X,A8,2X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*,/,
     *                 1H*,2X,''NO)   ENERGY '',A13,
     *                        '' | N,'',A10,''>   <T> '',
     *                    3X,''<JY>    <SY>   GFACT'',3X,1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *       SPMODL,NAMEPN,NAMSYM(ISIGNY),NAMLAB(NILXYZ)
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *                 1H*,2X,''SINGLE-PARTICLE PROPERTIES: '',
     *                               A14,''                 '',
     *                                          6X,A8,2X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*,/,
     *                 1H*,2X,''NO)   ENERGY '',A13,
     *                        '' | N,'',A10,''>   <T> '',
     *                    3X,''<JX>    <JY>    <JZ>'',3X,1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *       SPMODL,NAMEPN,NAMSYM(ISIQTY+2),NAMLAB(NILXYZ)
C
          END IF
C
      END IF
C
C=======================================================================
C
      DO IALLST=1,LDORDE
C
         ISTATE=NSTATE(NORDER(IALLST))
         IREVER=NREVER(NORDER(IALLST))
C
         IF (PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))).GT.EMINAL
     *                                                             .AND.
     *       PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))).LT.EMAXAL)
     *                                                              THEN
C
             ALIAUX=PNALIG(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
             T_ISOS=PNISOS(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
             IF (ABS(ALIAUX).GE.1.0D-10) THEN
C
                 FACTOR=PNSPAL(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                           /ALIAUX
C
                 IF (ABS(FACTOR).GE.10.0D0)    THEN
                     WRITE(GFACTO,'(1PE7.0)') FACTOR
                 ELSE
                     WRITE(GFACTO,'(  F7.3)') FACTOR
                 END IF
C
             ELSE
                 GFACTO='  XXXXX'
             END IF
C
             IF (ISIMPY.EQ.1) THEN
C
                 WRITE(NFIPRI,'(1H*,I4,'')'',F9.3,1X,A13,1X,A15,I6,
     *                                             2F8.3,1X,A7,3X,1H*)')
     *
     *           IALLST,PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNORDE(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNNILS(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  INT(SIGN(ABS(T_ISOS)*100+0.1,T_ISOS)),
     *                  PNALIG(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNSPAL(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  GFACTO
C
             ELSE
C
                 WRITE(NFIPRI,'(1H*,I4,'')'',F9.3,1X,A13,1X,A15,I6,
     *                                                   3F8.3,3X,1H*)')
     *
     *           IALLST,PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNORDE(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNNILS(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  INT(SIGN(ABS(T_ISOS)*100+0.1,T_ISOS)),
     *                  PNXALI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNALIG(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNZALI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                 WRITE(NFIPRI,'(1H*,50X,3F8.3,3X,1H*)')
     *
     *                  PNXSPI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNSPAL(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),
     *                  PNZSPI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
             END IF
C
         END IF
C
      END DO
C
      IF (EMINAL.LT.EMAXAL) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SPTQUA(EMAXQU,ICHARG,NAMEPN,NILXYZ,
     *                  IQUNIL,ISIGNY,ISIMPY,ISIQTY,
     *                  IDSIGB,IDSIMB,IDSIQB,IDSIZB,
     *                         IREMQB,INUMQB,JNUMQB)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN*8,NAMSYM(1:4)*13,NAMLAB(3)*10
      CHARACTER
     *          QPNILS*15,QPORDD*13,QPORDE*13,QPNIL2*9
      CHARACTER
     *          QPLAST*21,BLOTYP*4
C
      DIMENSION
     *          EORDER(1:2*NDSTAT),NORDER(1:2*NDSTAT),
     *          NSTATE(1:2*NDSTAT),NREVER(1:2*NDSTAT),
     *          NPARIT(1:2*NDSTAT)
      DIMENSION
     *          N_PPRP(1:2*NDSTAT),N_PPRM(1:2*NDSTAT),
     *          N_PMRP(1:2*NDSTAT),N_PMRM(1:2*NDSTAT)
      DIMENSION
     *          N_SIMP(1:2*NDSTAT),N_SIMM(1:2*NDSTAT)
      DIMENSION
     *          N_PARP(1:2*NDSTAT),N_PARM(1:2*NDSTAT)
      DIMENSION
     *          QPORDE(1:2*NDSTAT,0:NDREVE)
      DIMENSION
     *          IDSIQB(1:NDBLOC)
      DIMENSION
     *          IDSIZB(1:NDBLOC)
      DIMENSION
     *          IREMQB(1:NDBLOC),INUMQB(1:NDBLOC),JNUMQB(1:NDBLOC)
C
      COMMON
     *       /XEQUIV/ EEQUIV(1:2*NDSTAT,0:NDREVE),
     *                DEQUIV(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /PARIQU/ QPPARI(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /SIMPQU/ QPSIMP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /CORPAR/ V_CORR(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QPLEVS/ QPENER(1:4*NDSTAT,0:NDISOS),
     *                QPOCCU(1:4*NDSTAT,0:NDISOS),
     *                QPPARR(1:4*NDSTAT,0:NDISOS),
     *                QPEEQU(1:4*NDSTAT,0:NDISOS),
     *                QPDEQU(1:4*NDSTAT,0:NDISOS),
     *                QPCORR(1:4*NDSTAT,0:NDISOS)
      COMMON
     *       /QPLABS/ QPORDD(1:4*NDSTAT,0:NDISOS),
     *                QPNILS(1:4*NDSTAT,0:NDISOS),
     *                QPNIL2(1:4*NDSTAT,0:NDISOS),
     *                QPNORM(1:4*NDSTAT,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *      NAMSYM / '(++,+-,-+,--)' , '  (S=+,S=-)  ' ,
     *               '  (P=+,P=-)  ' , '    SIMPLEX  ' /
      DATA
     *      NAMLAB /'nx,lx,OMEx',
     *              'ny,ly,OMEy',
     *              'nz,lz,OMEz'/
C
C=======================================================================
C         THIS ROUTINE TABULATES THE SINGLE-QUASIPARTICLE RESULTS IN THE
C         FORM OF A COMMON TABLE FOR ALL SYMMETRIES
C=======================================================================
C
      NUMSYM=0
C
      IORDER=0
C
      QPORDE='             '
      QPLAST='                     '
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
            IORDER=IORDER+1
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=EEQUIV(ISTATE,IREVER)
            NSTATE(IORDER)=ISTATE
            NREVER(IORDER)=IREVER
C
            IF (QPPARI(ISTATE,IREVER).GT.0.0) THEN
C
                IPARIT=0
            ELSE
                IPARIT=1
C
            END IF
C
            NPARIT(IORDER)=IPARIT
C
         END DO
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
C=======================================================================
C         CALCULATING THE NUMBERS OF OCCUPIED STATES
C         IN EVERY SIMPLEX BLOCK.
C=======================================================================
C
      NUPPRP=0
      NUPPRM=0
      NUPMRP=0
      NUPMRM=0
C
      NUSIMP=0
      NUSIMM=0
C
      NUPARP=0
      NUPARM=0
C
      NALLST=NUMBQP(0,ICHARG)+NUMBQP(1,ICHARG)
C
      DO IALLST=1,NALLST
C
         ISTATE=NSTATE(NORDER(IALLST))
         IREVER=NREVER(NORDER(IALLST))
         IPARIT=NPARIT(NORDER(IALLST))
C
C=======================================================================
C        HERE THE PARITY/TIME-REVERSAL BLOCKS ARE CONSIDERED
C=======================================================================
C
         IF (ISIMPY.EQ.1.AND.ISIGNY.EQ.1) THEN
C
             NUMSYM=1
C
             N_PPRP(IALLST)=0
             N_PPRM(IALLST)=0
             N_PMRP(IALLST)=0
             N_PMRM(IALLST)=0
C
             IF (IABS(IDSIGB).NE.1.OR.
     *          (IABS(IDSIGB).EQ.1.AND.(IREVER.NE.IREMQB(1).OR.
     *                                  ISTATE.NE.INUMQB(1)))) THEN
C
                 IF (IPARIT.EQ.0) THEN
C
                     IF (IREVER.EQ.0) THEN
C
                         NUPPRP=NUPPRP+1
                         N_PPRP(IALLST)=NUPPRP
                     ELSE
                         NUPPRM=NUPPRM+1
                         N_PPRM(IALLST)=NUPPRM
C
                     END IF
C
                 ELSE
C
                     IF (IREVER.EQ.0) THEN
C
                         NUPMRP=NUPMRP+1
                         N_PMRP(IALLST)=NUPMRP
                     ELSE
                         NUPMRM=NUPMRM+1
                         N_PMRM(IALLST)=NUPMRM
C
                     END IF
C
                 END IF
C
             END IF
C
C=======================================================================
C            PARITY/TIME-REVERSAL CASE:
C                       THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                       THE "QPORDE" LABELS WITH THE  (PARITY,IREVER)
C                       BLOCKS ORDERED AS: (+,+)  (+,-)  (-,-)  (-,+)
C=======================================================================
C
             IF (N_PPRP(IALLST).LE.99.AND.N_PPRM(IALLST).LE.99.AND.
     *           N_PMRM(IALLST).LE.99.AND.N_PMRP(IALLST).LE.99)
     *           WRITE(QPORDE(ISTATE,IREVER),
     *                               '(''('',I2,3('','',I2),'')'')')
     *
     *           N_PPRP(IALLST),N_PPRM(IALLST),
     *           N_PMRM(IALLST),N_PMRP(IALLST)
C
             IF (IALLST.EQ.NALLST) THEN
C
                 IF (NUPPRP.LE.9999.AND.NUPPRM.LE.9999.AND.
     *               NUPMRM.LE.9999.AND.NUPMRP.LE.9999)
     *               WRITE(QPLAST,'(''('',I4,3('','',I4),'')'')')
     *               NUPPRP,NUPPRM,NUPMRM,NUPMRP
C
                 IF (NUPPRP.LE.999.AND.NUPPRM.LE.999.AND.
     *               NUPMRM.LE.999.AND.NUPMRP.LE.999)
     *               WRITE(QPLAST,'(''('',I3,3('','',I3),'')'',4X)')
     *               NUPPRP,NUPPRM,NUPMRM,NUPMRP
C
                 IF (NUPPRP.LE.99.AND.NUPPRM.LE.99.AND.
     *               NUPMRM.LE.99.AND.NUPMRP.LE.99)
     *               WRITE(QPLAST,'(''('',I2,3('','',I2),'')'',8X)')
     *               NUPPRP,NUPPRM,NUPMRM,NUPMRP
C
             END IF
C
         END IF
C
C=======================================================================
C        HERE THE SIMPLEX BLOCKS ARE CONSIDERED
C=======================================================================
C
         IF (ISIMPY.EQ.1.AND.ISIGNY.NE.1) THEN
C
             NUMSYM=2
C
             N_SIMP(IALLST)=0
             N_SIMM(IALLST)=0
C
             IF (IABS(IDSIMB).NE.1.OR.
     *          (IABS(IDSIMB).EQ.1.AND.(IREVER.NE.IREMQB(1).OR.
     *                                  ISTATE.NE.INUMQB(1)))) THEN
C
                 IF (IREVER.EQ.0) THEN
C
                     NUSIMP=NUSIMP+1
                     N_SIMP(IALLST)=NUSIMP
                 ELSE
                     NUSIMM=NUSIMM+1
                     N_SIMM(IALLST)=NUSIMM
C
                 END IF
C
             END IF
C
C=======================================================================
C            SIMPLEX CASE:
C                       THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                       THE "QPORDE" LABELS WITH THE  (SIMPLEX)
C                       BLOCKS ORDERED AS: (+) (-)
C=======================================================================
C
             IF (N_SIMP(IALLST).LE.999.AND.N_SIMM(IALLST).LE.999)
     *           WRITE(QPORDE(ISTATE,IREVER),
     *                                '(''  ('',I3,'','',I3,'')  '')')
     *
     *           N_SIMP(IALLST),N_SIMM(IALLST)
C
             IF (IALLST.EQ.NALLST) THEN
C
                 IF (NUSIMP.LE.9999.AND.NUSIMM.LE.9999)
     *               WRITE(QPLAST,'('' ('',I4,'','',I4,'')     '',4X)')
     *               NUSIMP,NUSIMM
C
                 IF (NUSIMP.LE.999.AND.NUSIMM.LE.999)
     *               WRITE(QPLAST,'('' ('',I3,'','',I3,'')     '',6X)')
     *               NUSIMP,NUSIMM
C
                 IF (NUSIMP.LE.99.AND.NUSIMM.LE.99)
     *               WRITE(QPLAST,'('' ('',I2,'','',I2,'')     '',8X)')
     *               NUSIMP,NUSIMM
C
             END IF
C
         END IF
C
C=======================================================================
C        HERE THE PARITY BLOCKS ARE CONSIDERED
C=======================================================================
C
         IF (ISIMPY.NE.1.AND.ISIQTY.EQ.1) THEN
C
             NUMSYM=3
C
             N_PARP(IALLST)=0
             N_PARM(IALLST)=0
C
             IF (IPARIT.EQ.0) THEN
C
                 NUPARP=NUPARP+1
                 N_PARP(IALLST)=NUPARP
             ELSE
                 NUPARM=NUPARM+1
                 N_PARM(IALLST)=NUPARM
C
             END IF
C
C=======================================================================
C            PARITY CASE:
C                       THE MATRICES WITH CONFIGURATIONS ARE PUT INTO
C                       THE "QPORDE" LABELS WITH THE  (PARITY)
C                       BLOCKS ORDERED AS: (+) (-)
C=======================================================================
C
             IF (N_PARP(IALLST).LE.999.AND.N_PARM(IALLST).LE.999)
     *           WRITE(QPORDE(ISTATE,IREVER),
     *                                '(''  ('',I3,'','',I3,'')  '')')
     *
     *           N_PARP(IALLST),N_PARM(IALLST)
C
             IF (IALLST.EQ.NALLST) THEN
C
                 IF (NUPARP.LE.9999.AND.NUPARM.LE.9999)
     *               WRITE(QPLAST,'('' ('',I4,'','',I4,'')     '',4X)')
     *               NUPARP,NUPARM
C
                 IF (NUPARP.LE.999.AND.NUPARM.LE.999)
     *               WRITE(QPLAST,'('' ('',I3,'','',I3,'')     '',6X)')
     *               NUPARP,NUPARM
C
                 IF (NUPARP.LE.99.AND.NUPARM.LE.99)
     *               WRITE(QPLAST,'('' ('',I2,'','',I2,'')     '',8X)')
     *               NUPARP,NUPARM
C
             END IF
C
         END IF
C
C=======================================================================
C        HERE THE NO-SYMMETRY CASE IS CONSIDERED
C=======================================================================
C
         IF (ISIMPY.NE.1.AND.ISIQTY.NE.1) THEN
C
             NUMSYM=4
C
             WRITE(QPORDE(ISTATE,IREVER),'(F11.5,2X)')
     *
     *             QPSIMP(ISTATE,IREVER)
C
             IF (IALLST.EQ.NALLST) THEN
C
                 IF (NUMBQP(0,ICHARG).LE.9999.AND.
     *               NUMBQP(1,ICHARG).LE.9999)
     *               WRITE(QPLAST,'('' ('',I4,'','',I4,'')     '',4X)')
     *               NUMBQP(0,ICHARG),NUMBQP(1,ICHARG)
C
                 IF (NUMBQP(0,ICHARG).LE.999.AND.
     *               NUMBQP(1,ICHARG).LE.999)
     *               WRITE(QPLAST,'('' ('',I3,'','',I3,'')     '',6X)')
     *               NUMBQP(0,ICHARG),NUMBQP(1,ICHARG)
C
                 IF (NUMBQP(0,ICHARG).LE.99.AND.
     *               NUMBQP(1,ICHARG).LE.99)
     *               WRITE(QPLAST,'('' ('',I2,'','',I2,'')     '',8X)')
     *               NUMBQP(0,ICHARG),NUMBQP(1,ICHARG)
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C         PRINTING THE TABLE
C=======================================================================
C
      IF (EMAXQU.GT.0.0D0) THEN
C
          IF (IQUNIL.EQ.0)
     *    WRITE(NFIPRI,'(79(1H*),/,              1H*,77X,1H*,/,
     *                 1H*,2X,''SINGLE-QUASIPARTICLE PROPERTIES: '',
     *                                       ''                  '',
     *                                         14X,A8,2X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*,/,
     *                 1H*,2X,''NO)   ENERGY '',A13,3X,
     *                                            ''  PARITY '',
     *                              ''  V2QUAP '',''  EEQUIV '',
     *                              ''  DEQUIV '',''  V_CORR '',
     *                                                1X,1H*,/,
     *                                           1H*,77X,1H*)')
     *
     *    NAMEPN,NAMSYM(NUMSYM)
C
          IF (IQUNIL.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,              1H*,77X,1H*,/,
     *                 1H*,2X,''SINGLE-QUASIPARTICLE PROPERTIES: '',
     *                                       ''                  '',
     *                                         14X,A8,2X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*,/,
     *                 1H*,2X,''NO)   ENERGY'','' | N,'',A10,''> '',
     *                                            ''  PARITY '',
     *                              ''  V2QUAP '',''  EEQUIV '',
     *                              ''  DEQUIV '',''  V_CORR '',
     *                                                1X,1H*,/,
     *                                           1H*,77X,1H*)')
     *
     *    NAMEPN,NAMLAB(NILXYZ)
C
      END IF
C
C=======================================================================
C   NOTE: IPRINT USED TO AVOID DOUBLE PRINTING WHEN MULTIBLOCKING IS ON.
C=======================================================================
C
      DO IALLST=1,NALLST
C
         ISTATE=NSTATE(NORDER(IALLST))
         IREVER=NREVER(NORDER(IALLST))
         IPARIT=NPARIT(NORDER(IALLST))
         LSTATE=ISTATE+IREVER*NUMBQP(0,ICHARG)
C
         IF (ENQUAP(ISTATE,IREVER).LT.EMAXQU) THEN
C
             DO NUBLOC=1,NDBLOC
                IPRINT=0
C
                IF ((IABS(IDSIGB).EQ.1.OR.IABS(IDSIMB).EQ.1.OR.
     *               IABS(IDSIQB(1)).EQ.1.OR.
     *               IABS(IDSIZB(NUBLOC)).EQ.1).AND.
     *               IREVER.EQ.IREMQB(NUBLOC).AND.
     *               ISTATE.EQ.INUMQB(NUBLOC)) THEN
C
                    IF (ICHARG.EQ.0) BLOTYP='NQBL'
                    IF (ICHARG.EQ.1) BLOTYP='PQBL'
                    IPRINT=1
                ELSE
                    IF ((IABS(IDSIGB).EQ.1.OR.IABS(IDSIMB).EQ.1.OR.
     *                   IABS(IDSIQB(1)).EQ.1.OR.
     *                   IABS(IDSIZB(NUBLOC)).EQ.1).AND.
     *                   IREVER.NE.IREMQB(NUBLOC).AND.
     *                   ISTATE.EQ.JNUMQB(NUBLOC).AND.
     *                  (IABS(IDSIQB(1)).NE.1.AND.
     *                   IABS(IDSIZB(NUBLOC)).NE.1)) THEN
C
                    IF (ICHARG.EQ.0) BLOTYP='NADD'
                    IF (ICHARG.EQ.1) BLOTYP='PADD'
                    IPRINT=1
                    ELSE
                        IF (IPRINT.EQ.0) BLOTYP='    '
                        IF (NUBLOC.EQ.NDBLOC) IPRINT=1
C
                    END IF
C
                END IF
C
                IF (IPRINT.EQ.1.AND.IQUNIL.EQ.0)
     *              WRITE(NFIPRI,'(1H*,I4,'')'',1X,F8.3,1X,A13,A4,1X,
     *                                   F6.3,F9.5,2F9.3,F9.5,2X,1H*)')
     *
     *              IALLST,ENQUAP(ISTATE,IREVER),
     *                     QPORDE(ISTATE,IREVER),
     *                     BLOTYP,
     *                     QPPARI(ISTATE,IREVER),
     *                     V2QUAP(ISTATE,IREVER),
     *                     EEQUIV(ISTATE,IREVER),
     *                     DEQUIV(ISTATE,IREVER),
     *                     V_CORR(ISTATE,IREVER)
C
                IF (IPRINT.EQ.1.AND.IQUNIL.EQ.1)
     *              WRITE(NFIPRI,'(1H*,I4,'')'',1X,F8.3,1X,A9,4X,A4,1X,
     *                                    F6.3,F9.5,2F9.3,F9.5,2X,1H*)')
     *
     *              IALLST,ENQUAP(ISTATE,IREVER),
     *                     QPNIL2(LSTATE,ICHARG),
     *                     BLOTYP,
     *                     QPPARI(ISTATE,IREVER),
     *                     V2QUAP(ISTATE,IREVER),
     *                     EEQUIV(ISTATE,IREVER),
     *                     DEQUIV(ISTATE,IREVER),
     *                     V_CORR(ISTATE,IREVER)
C
             END DO
C
         END IF
C
         IF (IALLST.EQ.NALLST.AND.EMAXQU.GT.0.0D0) THEN
C
             IF (IALLST.LE.9999) THEN
C
                 WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,I4,'')'',
     *                     1X,''  TOTAL='',1X,A21,1X,40X,1H*)')
     *           IALLST,QPLAST
C
             ELSE
C
                 WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,I6,'')'',
     *                     1X,''  TOTAL='',1X,A21,1X,38X,1H*)')
     *           IALLST,QPLAST
C
             END IF
C
         END IF
C
C=======================================================================
C           STORING THE QUASIPARTICLE DATA FOR NEUTRONS AND PROTONS
C=======================================================================
C           ATTENTION: IN PREPARATION FOR THE PROTON-NEUTRON MIXING, THE
C                      LEFT-HAND-SIDE ARRAYS BELOW ARE  DIMENSIONNED  UP
C                      TO 4*NDSTAT INSTEAD OF 2*NDSTAT. THIS CHANGE  HAS
C                      BEEN INTRODUCED ON 21/02/20 IN VERSION (2.93G).
C=======================================================================
C
         QPENER(ISTATE+IREVER*NUMBQP(0,ICHARG),ICHARG)=
     *                                             ENQUAP(ISTATE,IREVER)
         QPOCCU(ISTATE+IREVER*NUMBQP(0,ICHARG),ICHARG)=
     *                                             V2QUAP(ISTATE,IREVER)
         QPORDD(ISTATE+IREVER*NUMBQP(0,ICHARG),ICHARG)=
     *                                             QPORDE(ISTATE,IREVER)
         QPPARR(ISTATE+IREVER*NUMBQP(0,ICHARG),ICHARG)=
     *                                             QPPARI(ISTATE,IREVER)
         QPEEQU(ISTATE+IREVER*NUMBQP(0,ICHARG),ICHARG)=
     *                                             EEQUIV(ISTATE,IREVER)
         QPDEQU(ISTATE+IREVER*NUMBQP(0,ICHARG),ICHARG)=
     *                                             DEQUIV(ISTATE,IREVER)
         QPCORR(ISTATE+IREVER*NUMBQP(0,ICHARG),ICHARG)=
     *                                             V_CORR(ISTATE,IREVER)
C
      END DO
C
      IF (EMAXQU.GT.0.0D0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVPARI(MREVER,ICHARG,IPNMIX)
C=======================================================================
      USE ALLWAV
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('AVPARI',1)
C
C=======================================================================
C     THIS ROUTINE CALCULATES AVERAGE PARITY OF SINGLE PARTICLE STATES
C=======================================================================
C
      IF (IPNMIX.NE.1) THEN
C
          LSTATE=NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG)
C
          DO ISTATE=1,LSTATE
C
             SPPARI(ISTATE,ICHARG)=0.0D0
C
          END DO
C
          DO IBASE=1,LDBASE
C
             IPARI=1-2*MOD(NXVECT(IBASE,1)+NYVECT(IBASE,1)
     *                                 +NZVECT(IBASE,1),2)
C
             DO ISTATE=1,LSTATE
C
                SPPARI(ISTATE,ICHARG)=SPPARI(ISTATE,ICHARG)+IPARI
     *                    *REAL(WAVOCC(IBASE,ISTATE,0)
     *                   *CONJG(WAVOCC(IBASE,ISTATE,0))
     *                         +WAVOCC(IBASE,ISTATE,1)
     *                   *CONJG(WAVOCC(IBASE,ISTATE,1)))
C
             END DO
C
          END DO
C
      ELSE
C
          LSTATE=NUMBSP(0,0)+NUMBSP(0,1)
     *                                 +MREVER*(NUMBSP(1,0)+NUMBSP(1,1))
          DO ISTATE=1,LSTATE
C
             PNPARI(ISTATE)=0.0D0
C
          END DO
C
          DO IBASE=1,LDBASE
C
             IPARI=1-2*MOD(NXVECT(IBASE,1)+NYVECT(IBASE,1)
     *                                 +NZVECT(IBASE,1),2)
C
             DO ISTATE=1,LSTATE
C
                PNPARI(ISTATE)=PNPARI(ISTATE)+IPARI
     *                          *REAL(PNMOCC(       IBASE,ISTATE,0)
     *                         *CONJG(PNMOCC(       IBASE,ISTATE,0))
     *                               +PNMOCC(       IBASE,ISTATE,1)
     *                         *CONJG(PNMOCC(       IBASE,ISTATE,1))
     *                               +PNMOCC(LDBASE+IBASE,ISTATE,0)
     *                         *CONJG(PNMOCC(LDBASE+IBASE,ISTATE,0))
     *                               +PNMOCC(LDBASE+IBASE,ISTATE,1)
     *                         *CONJG(PNMOCC(LDBASE+IBASE,ISTATE,1)))
C
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('AVPARI',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVSIMP(MREVER,ICHARG,IPNMIX)
C=======================================================================
      USE ALLWAV
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('AVSIMP',1)
C
C=======================================================================
C     THIS ROUTINE CALCULATES AVERAGE SIMPLEX OF SINGLE-PARTICLE STATES
C=======================================================================
C
      IF (IPNMIX.NE.1) THEN
C
          LSTATE=NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG)
C
          DO ISTATE=1,LSTATE
C
             SPSIMP(ISTATE,ICHARG)=0.0D0
C
             DO IBASE=1,LDBASE
C
                SPSIMP(ISTATE,ICHARG)=SPSIMP(ISTATE,ICHARG)
     *                          +REAL(WAVOCC(IBASE,ISTATE,0)
     *                         *CONJG(WAVOCC(IBASE,ISTATE,0))
     *                               -WAVOCC(IBASE,ISTATE,1)
     *                         *CONJG(WAVOCC(IBASE,ISTATE,1)))
C
             END DO
C
          END DO
C
      ELSE
C
          LSTATE=NUMBSP(0,0)+NUMBSP(0,1)
     *                                 +MREVER*(NUMBSP(1,0)+NUMBSP(1,1))
C
          DO ISTATE=1,LSTATE
C
             PNSIMP(ISTATE)=0.0D0
C
             DO IBASE=1,LDBASE
C
                PNSIMP(ISTATE)=PNSIMP(ISTATE)
     *                          +REAL(PNMOCC(       IBASE,ISTATE,0)
     *                         *CONJG(PNMOCC(       IBASE,ISTATE,0))
     *                               -PNMOCC(       IBASE,ISTATE,1)
     *                         *CONJG(PNMOCC(       IBASE,ISTATE,1))
     *                               +PNMOCC(LDBASE+IBASE,ISTATE,0)
     *                         *CONJG(PNMOCC(LDBASE+IBASE,ISTATE,0))
     *                               -PNMOCC(LDBASE+IBASE,ISTATE,1)
     *                         *CONJG(PNMOCC(LDBASE+IBASE,ISTATE,1)))
C
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('AVSIMP',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVISOS(MREVER)
C=======================================================================
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('AVISOS',1)
C
C=======================================================================
C     THIS ROUTINE CALCULATES AVERAGE ISOSPIN OF SINGLE-PARTICLE STATES
C=======================================================================
C
      LSTATE=NUMBSP(0,0)+NUMBSP(0,1)+MREVER*(NUMBSP(1,0)+NUMBSP(1,1))
C
      DO ISTATE=1,LSTATE
C
         PNISOS(ISTATE)=0.0D0
C
         DO IBASE=1,LDBASE
C
            PNISOS(ISTATE)=PNISOS(ISTATE)
     *                      +REAL(PNMOCC(       IBASE,ISTATE,0)
     *                     *CONJG(PNMOCC(       IBASE,ISTATE,0))
     *                           +PNMOCC(       IBASE,ISTATE,1)
     *                     *CONJG(PNMOCC(       IBASE,ISTATE,1))
     *                           -PNMOCC(LDBASE+IBASE,ISTATE,0)
     *                     *CONJG(PNMOCC(LDBASE+IBASE,ISTATE,0))
     *                           -PNMOCC(LDBASE+IBASE,ISTATE,1)
     *                     *CONJG(PNMOCC(LDBASE+IBASE,ISTATE,1)))
C
         END DO
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('AVISOS',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVISOT(QMUT_I)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          QMUT_I
C
      DIMENSION
     *          QMUT_I(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /ISOTOT/ TOTISO(0:NDKART),TOTIS2(0:NDKART)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
C
C=======================================================================
C     THIS ROUTINE CALCULATES AVERAGE ISOSPIN <T_X>, <T_Y> AND <T_Z>
C=======================================================================
C
      TOTISO(1)=2*REAL(QMUT_I(0,0))*0.5D0
      TOTISO(2)=2*AIMAG(QMUT_I(0,0))*0.5D0
      TOTISO(3)=(QMUL_N(0,0)-QMUL_P(0,0))*0.5D0
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVISO2(MREVER,IN_FIX,IZ_FIX,ISIMPY)
C=======================================================================
      USE ALLWAV
      USE PNMWAV
      USE MAT_PP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX METAUP, METADW, METAUZ, METAUX,METAUY
      COMPLEX C_ZERO, UNIT_I
      COMPLEX AVERT2, AVRTZ2, AVRTY2, AVRTX2
      COMPLEX AVTAU2, AVTAUX, AVTAUY, AVTAUZ
      INTEGER NOCCST(0:1)
      COMPLEX, ALLOCATABLE ::  OCPNWF(:,:,:)
      DIMENSION METAUP(1:4*NDSTAT,1:4*NDSTAT),
     *          METADW(1:4*NDSTAT,1:4*NDSTAT),
     *          METAUX(1:4*NDSTAT,1:4*NDSTAT),
     *          METAUY(1:4*NDSTAT,1:4*NDSTAT),
     *          METAUZ(1:4*NDSTAT,1:4*NDSTAT)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
C
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /MIOCCU/ VMOCCU(1:4*NDSTAT)
      COMMON
     *       /ISOTOT/ TOTISO(0:NDKART),TOTIS2(0:NDKART)
      COMMON
     *       /ISOFER/ FERISO(0:NDKART)
C
C=======================================================================
C
      CALL CPUTIM('AVISO2',1)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C          THIS ROUTINE CALCULATES AVERAGE ISOSPIN <T>
C          AND AVERAGE ISOSPIN SQUARED <T^2>
C=======================================================================
C
      IF (.NOT.ALLOCATED(OCPNWF)) THEN
          ALLOCATE (OCPNWF(1:2*NDBASE,1:4*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('OCONWF','AVISO2')
      END IF
C=======================================================================
C     CHECK IF THE WAVE FUNCTIONS ARE STORED
C=======================================================================
C
      NOCCST=0
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF (VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))>0.0)
     *         THEN
                NOCCST(IREVER)=NOCCST(IREVER)+1
C
               IF (NOCCST(IREVER) .GT. 2*NDSTAT)
     *            STOP 'NOCCST > 2*NDSTAT IN AVISO2'
C
            END IF
C
         END DO
C
      END DO
C
      IF ( NOCCST(0)+NOCCST(1) .EQ. 0 ) THEN
           DEALLOCATE (OCPNWF)
           CALL CPUTIM('AVISO2',0)
           RETURN
      END IF
C
      LSTATE=NUMBSP(0,0)+NUMBSP(0,1)+NUMBSP(1,0)+NUMBSP(1,1)
C
      OCPNWF=C_ZERO
C
      IF (ISIMPY.EQ.1) THEN
C
          DO IREVER=0,MREVER
C
             DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
                DO IBASE=1,2*LDBASE
                   OCPNWF(IBASE,
     *            (ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),IREVER)
     *            =PNMOCC(IBASE,
     *            (ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))),IREVER)
     *            *PNOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
                END DO
C
             END DO
C
          END DO
C
          IF ( MREVER .EQ. 0) THEN
C
             DO ISTATE=1,NUMBSP(0,0)+NUMBSP(0,1)
C
                DO IBASE=1,2*LDBASE
                   OCPNWF(IBASE,ISTATE+NUMBSP(0,0)+NUMBSP(0,1), 1)
     *            =OCPNWF(IBASE,ISTATE                        , 0)
                END DO
C
             END DO
C
          END IF
C
      ELSE
C
          DO IREVER=0,MREVER
C
             DO ISTATE=1,LSTATE
C
                DO IBASE=1,2*LDBASE
                  OCPNWF(IBASE,ISTATE,IREVER)
     *           =PNMOCC(IBASE,ISTATE,IREVER)*PNOCCU(ISTATE)
                END DO
C
             END DO
C
          END DO
C
       END IF
C
C      WRITE(NFIPRI, '(''*'',1X,''NOCCST(0)='',I8,2X,''NOCCST(1)='',I8,2X
C     *  ,''MREVER='',I8
C     * ,1X,''*'')')
C     *    NOCCST(0),NOCCST(1),MREVER
C
C      DO ISTATE=1,LSTATE
C
C         WRITE(NFIPRI,'(''PNOCCU('', I4 ,'')='', F6.4,1X,
C     *                 ''VMOCCU('', I4 ,'')='', F6.4,1X)')
C     *         ISTATE, PNOCCU(ISTATE)
C     *        ,ISTATE, VMOCCU(ISTATE)
C      END DO
C
      METAUP=C_ZERO
      METADW=C_ZERO
      METAUX=C_ZERO
      METAUY=C_ZERO
      METAUZ=C_ZERO
C
      DO JSTATE=1,LSTATE
         DO ISTATE=1,LSTATE
            DO IBASE=1,LDBASE
C       <ISTATE|tau_+|JSTATE>
               METAUP(ISTATE,JSTATE)=METAUP(ISTATE,JSTATE)
     *        +OCPNWF(LDBASE+IBASE,JSTATE,0)
     *  *CONJG(OCPNWF(       IBASE,ISTATE,0))
     *        +OCPNWF(LDBASE+IBASE,JSTATE,1)
     *  *CONJG(OCPNWF(       IBASE,ISTATE,1))
C
C       <ISTATE|tau_-|JSTATE>
               METADW(ISTATE,JSTATE)=METADW(ISTATE,JSTATE)
     *        +OCPNWF(       IBASE,JSTATE,0)
     *  *CONJG(OCPNWF(LDBASE+IBASE,ISTATE,0))
     *        +OCPNWF(       IBASE,JSTATE,1)
     *  *CONJG(OCPNWF(LDBASE+IBASE,ISTATE,1))
C
C       <ISTATE|tau_z|JSTATE>
               METAUZ(ISTATE,JSTATE)=METAUZ(ISTATE,JSTATE)
     *       + OCPNWF(       IBASE,JSTATE,0)
     *  *CONJG(OCPNWF(       IBASE,ISTATE,0))
     *        -OCPNWF(LDBASE+IBASE,JSTATE,0)
     *  *CONJG(OCPNWF(LDBASE+IBASE,ISTATE,0))
     *        +OCPNWF(       IBASE,JSTATE,1)
     *  *CONJG(OCPNWF(       IBASE,ISTATE,1))
     *        -OCPNWF(LDBASE+IBASE,JSTATE,1)
     *  *CONJG(OCPNWF(LDBASE+IBASE,ISTATE,1))
C
C       <ISTATE|tau_x|JSTATE>
               METAUX(ISTATE,JSTATE)=METAUX(ISTATE,JSTATE)
     *       + OCPNWF(LDBASE+IBASE,JSTATE,0)
     *  *CONJG(OCPNWF(       IBASE,ISTATE,0))
     *        +OCPNWF(       IBASE,JSTATE,0)
     *  *CONJG(OCPNWF(LDBASE+IBASE,ISTATE,0))
     *        +OCPNWF(LDBASE+IBASE,JSTATE,1)
     *  *CONJG(OCPNWF(       IBASE,ISTATE,1))
     *        +OCPNWF(       IBASE,JSTATE,1)
     *  *CONJG(OCPNWF(LDBASE+IBASE,ISTATE,1))
C
C       <ISTATE|tau_y|JSTATE>
               METAUY(ISTATE,JSTATE)=METAUY(ISTATE,JSTATE)
     *       +(OCPNWF(       IBASE,JSTATE,0)
     *  *CONJG(OCPNWF(LDBASE+IBASE,ISTATE,0))
     *        -OCPNWF(LDBASE+IBASE,JSTATE,0)
     *  *CONJG(OCPNWF(       IBASE,ISTATE,0))
     *        +OCPNWF(       IBASE,JSTATE,1)
     *  *CONJG(OCPNWF(LDBASE+IBASE,ISTATE,1))
     *        -OCPNWF(LDBASE+IBASE,JSTATE,1)
     *  *CONJG(OCPNWF(       IBASE,ISTATE,1)))*UNIT_I
C
            END DO
         END DO
      END DO
C
      AVERT2=C_ZERO
      AVRTX2=C_ZERO
      AVRTY2=C_ZERO
      AVRTZ2=C_ZERO
C
      METAUX=0.5D0*METAUX
      METAUY=0.5D0*METAUY
      METAUZ=0.5D0*METAUZ
C
      DO JSTATE=1,LSTATE
         DO ISTATE=1,LSTATE
            IF (ISTATE .NE. JSTATE) THEN
C
            AVRTX2=AVRTX2
     *             +METAUX(ISTATE,ISTATE)
     *             *METAUX(JSTATE,JSTATE)
     *             -METAUX(ISTATE,JSTATE)
     *             *METAUX(JSTATE,ISTATE)
            AVRTY2=AVRTY2
     *             +METAUY(ISTATE,ISTATE)
     *             *METAUY(JSTATE,JSTATE)
     *             -METAUY(ISTATE,JSTATE)
     *             *METAUY(JSTATE,ISTATE)
C
            AVRTZ2=AVRTZ2
     *             +METAUZ(ISTATE,ISTATE)
     *             *METAUZ(JSTATE,JSTATE)
     *             -METAUZ(ISTATE,JSTATE)
     *             *METAUZ(JSTATE,ISTATE)
C
            AVERT2=AVERT2
     *            +(METAUP(ISTATE,ISTATE)
     *             *METADW(JSTATE,JSTATE)
     *             -METAUP(ISTATE,JSTATE)
     *             *METADW(JSTATE,ISTATE)
     *             +METAUZ(ISTATE,ISTATE)
     *             *METAUZ(JSTATE,JSTATE)
     *             -METAUZ(ISTATE,JSTATE)
     *             *METAUZ(JSTATE,ISTATE))
C
           END IF
         END DO
      END DO
C
      AVTAUX=C_ZERO
      AVTAUY=C_ZERO
      AVTAUZ=C_ZERO
C
      DO JSTATE=1,LSTATE
         AVTAUX=AVTAUX+METAUX(JSTATE,JSTATE)
         AVTAUY=AVTAUY+METAUY(JSTATE,JSTATE)
         AVTAUZ=AVTAUZ+METAUZ(JSTATE,JSTATE)
      END DO
C
      AVTAU2=0.75D0*(IN_FIX+IZ_FIX)+(AVRTX2+AVRTY2+AVRTZ2)
      AVERT2=AVERT2+0.75D0*(IN_FIX+IZ_FIX)
      AVRTX2=AVRTX2+0.25D0*(IN_FIX+IZ_FIX)
      AVRTY2=AVRTY2+0.25D0*(IN_FIX+IZ_FIX)
      AVRTZ2=AVRTZ2+0.25D0*(IN_FIX+IZ_FIX)
C
      TOTISO(1)=REAL(AVTAUX)
      TOTISO(2)=REAL(AVTAUY)
      TOTISO(3)=REAL(AVTAUZ)
      TOTISO(0)=TOTISO(1)**2+TOTISO(2)**2+TOTISO(3)**2
C
      TOTIS2(1)=REAL(AVRTX2)
      TOTIS2(2)=REAL(AVRTY2)
      TOTIS2(3)=REAL(AVRTZ2)
      TOTIS2(0)=REAL(AVERT2)
C
C     WRITE(NFIPRI,'(79(''*''),/,
C    *          ''*'',26X,''AVERAGE TOTAL ISOSPIN'',30X,''*'')')
C     WRITE(NFIPRI, '(''*'',1X,''<Tx>='',F12.8,2X,''<Ty>='',F12.8,
C    *               2X,''<Tz>='',F12.8,2X,''<T^2>='',F12.8,1X,''*'')')
C    *                  REAL(AVTAUX)
C    *                 ,REAL(AVTAUY)
C    *                 ,REAL(AVTAUZ)
C    *                 ,REAL(AVERT2)
C     WRITE(NFIPRI, '(''*'',1X,''<Tx^2>='',F12.8,4X,''<Ty^2>='',F12.8,
C    *               4X,''<Tz^2>='',F12.8,11X,''*'')')
C    *                  REAL(AVRTX2)
C    *                 ,REAL(AVRTY2)
C    *                 ,REAL(AVRTZ2)
C     WRITE(NFIPRI,'(79(''*''),/)')
C
      DEALLOCATE (OCPNWF)
C
      CALL CPUTIM('AVISO2',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVISP2(MREVER,IN_FIX,IZ_FIX,ISIMPY)
C=======================================================================
C
      USE MAT_PP
      USE MAT_PM
      USE MAD_PP
      USE MAD_PM
C
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX C_ZERO, UNIT_I
      COMPLEX AVRTX2, AVRTY2, AVRTZ2
      COMPLEX AVTAUX, AVTAUY, AVTAUZ
C
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /ISOTOT/ TOTISO(0:NDKART),TOTIS2(0:NDKART)
C
C=======================================================================
C
      CALL CPUTIM('AVISP2',1)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      MASSNB=IN_FIX+IZ_FIX
C
C=======================================================================
C          THIS ROUTINE CALCULATES AVERAGE ISOSPIN <T>
C          AND AVERAGE ISOSPIN SQUARED <T^2> USING THE DENSITY MATRICES
C=======================================================================
C
C=======================================================================
C
C  <T^2_x> =( A +  <T_x>^2 - \sum <a|tau_x|b><b|tau_x|a>  )/4
C
C=======================================================================
C
C=======================================================================
C     CALCULATE THE AVERAGE Z-COMPONENT OF ISOSPIN <T_z>
C=======================================================================
C
      AVTAUZ = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
         AVTAUZ = AVTAUZ + DEN_PP(IBRA,IBRA,IREVER,0)
     *                   - DEN_PP(IBRA,IBRA,IREVER,1)
C
         END DO
C
      END DO
C
C=======================================================================
C     CALCULATE THE AVERAGE X-COMPONENT OF ISOSPIN <T_x>
C=======================================================================
C
      AVTAUX = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
         AVTAUX = AVTAUX + 2.0D0*REAL(BIG_PP(IBRA,IBRA,IREVER))
C
         END DO
C
      END DO
C
C=======================================================================
C     CALCULATE THE AVERAGE Y-COMPONENT OF ISOSPIN <T_y>
C=======================================================================
C
      AVTAUY = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
         AVTAUY = AVTAUY + 2.0D0*AIMAG(BIG_PP(IBRA,IBRA,IREVER))
C
         END DO
C
      END DO
C
C=======================================================================
C     CALCULATE THE AVERAGE X-COMPONENT OF ISOSPIN SQUARED <T_x^2>
C=======================================================================
C
      AVRTX2 = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
            DO IKET=1, LDBASE
C
               AVRTX2
     *       = AVRTX2 +2.0D0*(     DEN_PP(IBRA,IKET,IREVER,1)
     *                            *DEN_PP(IKET,IBRA,IREVER,0)
     *                     + REAL((BIG_PP(IBRA,IKET,IREVER  )
     *                            *BIG_PP(IKET,IBRA,IREVER  ))))
C
            END DO
C
         END DO
C
      END DO
C
      IF (ISIMPY .NE. 1) THEN
         DO IREVER=0, MREVER
C
            DO IBRA=1, LDBASE
C
               DO IKET=1, LDBASE
C
               AVRTX2
     *       = AVRTX2 +2.0D0*(     DEN_PM(IBRA,IKET,IREVER  ,1)
     *                            *DEN_PM(IKET,IBRA,1-IREVER,0)
     *                      +REAL((BIG_PM(IBRA,IKET,IREVER    )
     *                            *BIG_PM(IKET,IBRA,1-IREVER  ))))
C
               END DO
C
            END DO
C
         END DO
C
      END IF
C
      AVRTX2=0.25D0*(MASSNB+AVTAUX**2-AVRTX2)
C
C=======================================================================
C     CALCULATE THE AVERAGE Y-COMPONENT OF ISOSPIN SQUARED <T_y^2>
C=======================================================================
C
      AVRTY2 = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
            DO IKET=1, LDBASE
C
               AVRTY2
     *       = AVRTY2 +2.0D0*(     DEN_PP(IBRA,IKET,IREVER,1)
     *                            *DEN_PP(IKET,IBRA,IREVER,0)
     *                     - REAL((BIG_PP(IBRA,IKET,IREVER  )
     *                            *BIG_PP(IKET,IBRA,IREVER  ))))
C
            END DO
C
         END DO
C
      END DO
C
      IF (ISIMPY .NE. 1) THEN
         DO IREVER=0, MREVER
C
            DO IBRA=1, LDBASE
C
               DO IKET=1, LDBASE
C
               AVRTY2
     *       = AVRTY2 +2.0D0*(     DEN_PM(IBRA,IKET,IREVER  ,1)
     *                            *DEN_PM(IKET,IBRA,1-IREVER,0)
     *                      -REAL((BIG_PM(IBRA,IKET,IREVER    )
     *                            *BIG_PM(IKET,IBRA,1-IREVER  ))))
C
               END DO
C
            END DO
C
         END DO
C
      END IF
C
      AVRTY2=0.25D0*(MASSNB+AVTAUY**2-AVRTY2)
C
C=======================================================================
C     CALCULATE THE AVERAGE Z-COMPONENT OF ISOSPIN SQUARED <T_z^2>
C=======================================================================
C
      AVRTZ2 = C_ZERO
C
      DO ICHARG=0, NDISOS
C
         DO IREVER=0, MREVER
C
            DO IBRA=1, LDBASE
C
               DO IKET=1, LDBASE
C
               AVRTZ2
     *       = AVRTZ2 +  DEN_PP(IBRA,IKET,IREVER,ICHARG)
     *                  *DEN_PP(IKET,IBRA,IREVER,ICHARG)
               END DO
C
            END DO
C
         END DO
C
      END DO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
            DO IKET=1, LDBASE
C
               AVRTZ2
     *       =+AVRTZ2 -2.0D0*(BIG_PP(IBRA,IKET,IREVER  )
     *                *CONJG( BIG_PP(IBRA,IKET,IREVER  )))
C
            END DO
C
         END DO
C
      END DO
C
      IF (ISIMPY .NE. 1) THEN
C
         DO ICHARG=0, NDISOS
C
            DO IBRA=1, LDBASE
C
               DO IKET=1, LDBASE
C
               AVRTZ2
     *       = AVRTZ2 + 2.0D0*DEN_PM(IBRA,IKET,0,ICHARG)
     *                       *DEN_PM(IKET,IBRA,1,ICHARG)
C
               END DO
C
            END DO
C
         END DO
C
         DO IREVER=0, MREVER
C
            DO IBRA=1, LDBASE
C
               DO IKET=1, LDBASE
C
                  AVRTZ2
     *           =AVRTZ2 -2.0D0*(BIG_PM(IBRA,IKET,IREVER)
     *                    *CONJG(BIG_PM(IBRA,IKET,IREVER)))
C
               END DO
C
            END DO
C
         END DO
C
      END IF
C
      AVRTZ2=0.25D0*(MASSNB+AVTAUZ**2-AVRTZ2)
C
      TOTISO(1)=0.5D0*REAL(AVTAUX)
      TOTISO(2)=0.5D0*REAL(AVTAUY)
      TOTISO(3)=0.5D0*REAL(AVTAUZ)
      TOTISO(0)=TOTISO(1)**2+TOTISO(2)**2
     *                      +TOTISO(3)**2
C
      TOTIS2(1)=REAL(AVRTX2)
      TOTIS2(2)=REAL(AVRTY2)
      TOTIS2(3)=REAL(AVRTZ2)
      TOTIS2(0)=TOTIS2(1)+TOTIS2(2)+TOTIS2(3)
C
      CALL CPUTIM('AVISP2',0)
C
      RETURN
C
      END
C
C=======================================================================
C
      SUBROUTINE KEISP2(MREVER,ISIMPY,
     *                  BNN_PP,BNN_PM,BNP_PP,BNP_PM,
     *                  BPP_PP,BPP_PM,BPN_PP,BPN_PM)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          BNN_PP,BNN_PM,BNP_PP,BNP_PM,
     *          BPP_PP,BPP_PM,BPN_PP,BPN_PM
      DIMENSION
     *          BNN_PP(1:NDBASE,1:NDBASE,0:NDREVE),
     *          BNP_PP(1:NDBASE,1:NDBASE,0:NDREVE),
     *          BPP_PP(1:NDBASE,1:NDBASE,0:NDREVE),
     *          BPN_PP(1:NDBASE,1:NDBASE,0:NDREVE),
     *          BNN_PM(1:NDBASE,1:NDBASE,0:NDREVE),
     *          BNP_PM(1:NDBASE,1:NDBASE,0:NDREVE),
     *          BPP_PM(1:NDBASE,1:NDBASE,0:NDREVE),
     *          BPN_PM(1:NDBASE,1:NDBASE,0:NDREVE)
C
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          TAUKX2,TAUKY2,TAUKZ2
      COMPLEX
     *          TAUKEX,TAUKEY,TAUKEZ,TAUKES
      COMPLEX
     *          TKEISO,TKEIS2
C
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /ISOTOK/ TKEISO(0:NDKART),TKEIS2(0:NDKART)
C
C=======================================================================
C
      CALL CPUTIM('KEISP2',1)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C          THIS ROUTINE CALCULATES KERNELS OF ISOSPIN <T>
C          AND KERNELS OF ISOSPIN SQUARED <T^2>
C=======================================================================
C
C=======================================================================
C     CALCULATE THE KERNEL OF THE SCALAR ISOSPIN <T_0>
C=======================================================================
C
      TAUKES = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
         TAUKES = TAUKES + BNN_PP(IBRA,IBRA,IREVER)
     *                   + BPP_PP(IBRA,IBRA,IREVER)
C
         END DO
C
      END DO
C
C=======================================================================
C     CALCULATE THE KERNEL OF THE Z-COMPONENT OF ISOSPIN <T_z>
C=======================================================================
C
      TAUKEZ = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
         TAUKEZ = TAUKEZ + BNN_PP(IBRA,IBRA,IREVER)
     *                   - BPP_PP(IBRA,IBRA,IREVER)
C
         END DO
C
      END DO
C
      TAUKEZ = TAUKEZ/2
C
C=======================================================================
C     CALCULATE THE KERNEL OF THE X-COMPONENT OF ISOSPIN <T_x>
C=======================================================================
C
      TAUKEX = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
         TAUKEX = TAUKEX + BNP_PP(IBRA,IBRA,IREVER)
     *                   + BPN_PP(IBRA,IBRA,IREVER)
C
         END DO
C
      END DO
C
      TAUKEX = TAUKEX/2
C
C=======================================================================
C     CALCULATE THE KERNEL OF THE Y-COMPONENT OF ISOSPIN <T_y>
C=======================================================================
C
      TAUKEY = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
         TAUKEY = TAUKEY + BNP_PP(IBRA,IBRA,IREVER)
     *                   - BPN_PP(IBRA,IBRA,IREVER)
C
         END DO
C
      END DO
C
      TAUKEY = TAUKEY/2*UNIT_I
C
C=======================================================================
C     CALCULATE THE KERNEL OF THE X-COMPONENT OF ISOSPIN SQUARED <T_X^2>
C=======================================================================
C
      TAUKX2 = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
            DO IKET=1, LDBASE
C
               TAUKX2
     *       = TAUKX2 + 2*BNN_PP(IBRA,IKET,IREVER)
     *                   *BPP_PP(IKET,IBRA,IREVER)
     *                +   BNP_PP(IBRA,IKET,IREVER)
     *                   *BNP_PP(IKET,IBRA,IREVER)
     *                +   BPN_PP(IBRA,IKET,IREVER)
     *                   *BPN_PP(IKET,IBRA,IREVER)
C
            END DO
C
         END DO
C
      END DO
C
      IF (ISIMPY .NE. 1) THEN
         DO IREVER=0, MREVER
C
            DO IBRA=1, LDBASE
C
               DO IKET=1, LDBASE
C
               TAUKX2
     *       = TAUKX2 + 2*BNN_PM(IBRA,IKET,  IREVER)
     *                   *BPP_PM(IKET,IBRA,1-IREVER)
     *                +   BNP_PM(IBRA,IKET,  IREVER)
     *                   *BNP_PM(IKET,IBRA,1-IREVER)
     *                +   BPN_PM(IBRA,IKET,  IREVER)
     *                   *BPN_PM(IKET,IBRA,1-IREVER)
C
               END DO
C
            END DO
C
         END DO
C
      END IF
C
      TAUKX2=(TAUKES+4*TAUKEX**2-TAUKX2)/4
C
C=======================================================================
C     CALCULATE THE KERNEL OF THE Y-COMPONENT OF ISOSPIN SQUARED <T_Y^2>
C=======================================================================
C
      TAUKY2 = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
            DO IKET=1, LDBASE
C
               TAUKY2
     *       = TAUKY2 + 2*BNN_PP(IBRA,IKET,IREVER)
     *                   *BPP_PP(IKET,IBRA,IREVER)
     *                -   BNP_PP(IBRA,IKET,IREVER)
     *                   *BNP_PP(IKET,IBRA,IREVER)
     *                -   BPN_PP(IBRA,IKET,IREVER)
     *                   *BPN_PP(IKET,IBRA,IREVER)
C
            END DO
C
         END DO
C
      END DO
C
      IF (ISIMPY .NE. 1) THEN
         DO IREVER=0, MREVER
C
            DO IBRA=1, LDBASE
C
               DO IKET=1, LDBASE
C
               TAUKY2
     *       = TAUKY2 + 2*BNN_PM(IBRA,IKET,  IREVER)
     *                   *BPP_PM(IKET,IBRA,1-IREVER)
     *                -   BNP_PM(IBRA,IKET,  IREVER)
     *                   *BNP_PM(IKET,IBRA,1-IREVER)
     *                -   BPN_PM(IBRA,IKET,  IREVER)
     *                   *BPN_PM(IKET,IBRA,1-IREVER)
C
               END DO
C
            END DO
C
         END DO
C
      END IF
C
      TAUKY2=(TAUKES+4*TAUKEY**2-TAUKY2)/4
C
C=======================================================================
C     CALCULATE THE KERNEL OF THE Z-COMPONENT OF ISOSPIN SQUARED <T_Z^2>
C=======================================================================
C
      TAUKZ2 = C_ZERO
C
      DO IREVER=0, MREVER
C
         DO IBRA=1, LDBASE
C
            DO IKET=1, LDBASE
C
               TAUKZ2
     *       = TAUKZ2 +   BNN_PP(IBRA,IKET,IREVER)
     *                   *BNN_PP(IKET,IBRA,IREVER)
     *                +   BPP_PP(IBRA,IKET,IREVER)
     *                   *BPP_PP(IKET,IBRA,IREVER)
     *                - 2*BNP_PP(IBRA,IKET,IREVER)
     *                   *BPN_PP(IKET,IBRA,IREVER)
C
            END DO
C
         END DO
C
      END DO
C
      IF (ISIMPY .NE. 1) THEN
         DO IREVER=0, MREVER
C
            DO IBRA=1, LDBASE
C
               DO IKET=1, LDBASE
C
               TAUKZ2
     *       = TAUKZ2 +   BNN_PM(IBRA,IKET,  IREVER)
     *                   *BNN_PM(IKET,IBRA,1-IREVER)
     *                +   BPP_PM(IBRA,IKET,  IREVER)
     *                   *BPP_PM(IKET,IBRA,1-IREVER)
     *                - 2*BNP_PM(IBRA,IKET,  IREVER)
     *                   *BPN_PM(IKET,IBRA,1-IREVER)
C
               END DO
C
            END DO
C
         END DO
C
      END IF
C
      TAUKZ2=(TAUKES+4*TAUKEZ**2-TAUKZ2)/4
C
C=======================================================================
C     CALCULATE THE TOTAL KERNELS
C=======================================================================
C
      TKEISO(0)=TAUKES
      TKEISO(1)=TAUKEX
      TKEISO(2)=TAUKEY
      TKEISO(3)=TAUKEZ
C
      TKEIS2(1)=TAUKX2
      TKEIS2(2)=TAUKY2
      TKEIS2(3)=TAUKZ2
      TKEIS2(0)=TKEIS2(1)+TKEIS2(2)+TKEIS2(3)
C
C=======================================================================
C
      CALL CPUTIM('KEISP2',0)
C
      RETURN
C
      END
C
C=======================================================================
C
      SUBROUTINE INTEGH(IMOVAX,ITILAX,ITISAX,NO_ORB,
     *           IPNMIX,ITPNMX,IROTAT,ICHARG,ISIMPY,
     *                  MPAHFB,IPOTHO,ISCHIF,IOCONT,
     *                                NMUCON,NSICON,
     *                  I_YUKA,I_GOGA,I_REGA,I_SEPA,
     *                         ITWOLI,JETACM,ALINLT,
     *                                KETA_R,AROTLT,
     *                                ICOUDI,ICOUEX,
     *                                LIPKIN,LIPKIP,
     *                                EFER2N,EFER2P,
     *                                       IF_RPA,
     *                                ILIPON,ILIPOP,
     *                                       NEWGOG,
     *                                LTWCEN,ITWCEN,
     *                                       INDCOE)
C=======================================================================
      USE HCOULO
      USE COUSTO
      USE YUKSTO
      USE GOGSTO
      USE REGSTO
      USE SEPSTO
      USE FSTSTO
      USE ALISTO
      USE AROSTO
      USE MAT_PP
      USE MAT_PM
      USE MLI_PP
      USE MLI_PM
      USE VE_FLD
      USE hfodd_fission_fragments
      USE MAD2PP
      USE MAD3PP
      USE MAD4PP
      USE MAD5PP
      USE hfodd_twocen
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDFSTA=3)
C=======================================================================
C
      COMPLEX
     *          PHACOM
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          FERFAC
      COMPLEX
     *          VONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX,1:NDKART),
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX)
      COMPLEX
     *          HCOMPP,HCOMPM
C
      DIMENSION
     *          ALINLT(0:NDKART),AROTLT(0:NDKART)
C=======================================================================
      ALLOCATABLE HAUXPP(:,:)
      ALLOCATABLE HAUXPM(:,:)
      ALLOCATABLE HCOMPP(:,:)
      ALLOCATABLE HCOMPM(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /HERSTO/ HERMTS(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /ICNSTR/ STIFFI(1:NDKART),
     *                ASKEDI(1:NDKART),
     *                IFLAGI(1:NDKART)
      COMMON
     *       /ICNTTR/ STIFTI(1:NDKART),
     *                ASKETI(1:NDKART),
     *                IFTAGI(1:NDKART)
      COMMON
     *       /TCNSTR/ STIFFT(1:NDKART),
     *                ASKEDT(1:NDKART),
     *                IFLAGT(1:NDKART)
      COMMON
     *       /MOVFER/ FERMOV(0:NDKART)
      COMMON
     *       /ACNSTR/ STIFFA,ASKEDA,IFLAGA
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /RENORM/ HBMREN(NDKART)
      COMMON
     *       /RENROT/ ROTREN(NDKART)
      COMMON
     *       /ITERTS/ ITESTA,ITESTO,NOITER,NUMITE
      COMMON
     *       /ISDLIP/ IS_DLI(0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
     *       /NCKFLA/ IFNECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
C- XB - XB - - XB - - XB - - XB - - XB - - XB - - XB - - XB - - XB
      REAL
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
      COMMON
     *       /LIPLAM/
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
C
      INTEGER,PARAMETER :: NODGAU = 1000
      COMPLEX
     *          RLIPNU,NLIPNU
      COMMON
     *       /LIPNUM/
     *          RLIPNU(0:6,0:NODGAU,0:NDISOS),
     *          NLIPNU(0:6,0:NODGAU,0:NDISOS)
      COMMON
     *       /AXILIZ/ NOSCIL,IF_THO,IAXIAP
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *      /HERMIN/  INTWHE(1:NDTWCE,1:NDTWCE,1:NDTWCE,1:NDTWCE)
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
C- XB - XB - - XB - - XB - - XB - - XB - - XB - - XB - - XB - - XB
C
C=======================================================================
C
      CALL CPUTIM('INTEGH',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPP','INTEGH')
      ALLOCATE (HAUXPM(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPM','INTEGH')
C=======================================================================
      ALLOCATE (HCOMPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HCOMPP','INTEGH')
      ALLOCATE (HCOMPM(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HCOMPM','INTEGH')
C=======================================================================
      IF (.NOT.ALLOCATED(BIG_PP)) THEN
          ALLOCATE (BIG_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PP','INTEGH')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(BIG_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (BIG_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PM','INTEGH')
      END IF
C=======================================================================
C
C=======================================================================
C          THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF THE  MEAN-FIELD
C                       S K Y R M E   H A M I L T O N I A N
C=======================================================================
C         PREPARE THE INPUT DATA
C=======================================================================
C
      IF (ITPNMX.EQ.0) THEN
C
          LIPKIX=LIPKIN
          EFER2X=EFER2N
C
      END IF
C
      IF (ITPNMX.EQ.1) THEN
C
          LIPKIX=LIPKIP
          EFER2X=EFER2P
C
      END IF
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C          FROM VERSION (2.50Y), WE DO NOT ANYMORE SPLIT THE S.P. MATRIX
C          ELEMENTS (ME'S) INTO TIME-EVEN AND TIME-ODD PARTS  AND  LATER
C          RECOMBINE THEM INTO THE  TIME-UP  AND  TIME-DOWN  BLOCKS, BUT
C          INSTEAD WE PUT THEM DIRECTLY INTO THE TIME-UP  AND  TIME-DOWN
C          BLOCKS.
C          THE ME'S ARE FIRST CALCULATED IN THE TIME-UP-UP BLOCK AND PUT
C          INTO ARRAY BIG_PP(,,0), AND IN THE TIME-UP-DOWN BLOCK AND PUT
C          INTO ARRAY BIG_PM(,,0).
C          THEN, THEY ARE PUT INTO THE TIME-INVERTED BLOCKS  AND  STORED
C          IN ARRAYS BIG_PP(,,1) AND  BIG_PM(,,1),  WITH  THE  FOLLOWING
C          FACTORS:
C
C          FOR THE BIG_PP(,,1) ARRAY:
C             FOR TIME-EVEN REAL AND TIME-ODD IMAGINARY ME'S - FACTOR +1
C             FOR TIME-EVEN IMAGINARY AND TIME-ODD REAL ME'S - FACTOR -1
C
C          FOR THE BIG_PM(,,1) ARRAY:
C             FOR TIME-EVEN REAL AND TIME-ODD IMAGINARY ME'S - FACTOR -1
C             FOR TIME-EVEN IMAGINARY AND TIME-ODD REAL ME'S - FACTOR +1
C
C          FOR THE S.P. ME'S CORRESPONDING TO THE NON-DIAGONAL MANY-BODY
C          ME'S, THE FIELD FORM-FACTORS ARE NOT ANYMORE  REAL.  HOWEVER,
C          THEIR IMAGINARY PARTS SIMULTANEOUSLY CHANGE THE STATUS OF
C          THEIR S.P. ME'S IN THE FOLLOWING WAY:
C
C             REAL <--> IMAGINARY TOGETHER  WITH TIME-EVEN <--> TIME-ODD
C
C          THEREFORE, THE ABOVE FACTORS STAY THE SAME, AND THE SAME CODE
C          CAN BE USED FOR THE DIAGONAL AND NON-DIAGONAL MANY-BODY ME'S.
C=======================================================================
C
      IF (INDCOE.EQ.1.OR.INDCOE.EQ.13.OR.INDCOE.EQ.9) THEN
C
          BIG_PP(:,:,:)=C_ZERO
          IF (ISIMPY.NE.1) THEN
              BIG_PM(:,:,:)=C_ZERO
          END IF
C
      END IF
C
C=======================================================================
C          THE BLOCK BELOW IS EXECUTED ONLY FOR THE TERMS THAT ARE
C          DIAGONAL IN ISOSPIN (NOT INDENTED)
C=======================================================================
C
      IF (ITPNMX.LE.1) THEN
C
C=======================================================================
C          INSERTING THE CRANKING MATRIX ELEMENTS
C=======================================================================
C
      OMEGAT=OMOVAX**2+OMOVAY**2+OMOVAZ**2
C
      OMEGAJ=OMOVAX*ANGU_T(1)+
     *       OMOVAY*ANGU_T(2)+
     *       OMOVAZ*ANGU_T(3)
C
      IF (IMOVAX.NE.0.AND.(IOCONT.EQ.1.OR.NUMITE.NE.ITESTA)) THEN
C
          OMETOT=SQRT(OMOVAX   **2+OMOVAY   **2+OMOVAZ   **2)
          ANGTOT=SQRT(ANGU_T(1)**2+ANGU_T(2)**2+ANGU_T(3)**2)
C
          OMOVAX=IMOVAX*ANGU_T(1)*OMETOT/ANGTOT
          OMOVAY=IMOVAX*ANGU_T(2)*OMETOT/ANGTOT
          OMOVAZ=IMOVAX*ANGU_T(3)*OMETOT/ANGTOT
C
      END IF
C
      IF (ITILAX   .EQ.0.AND.ITISAX   .EQ.0.AND.
     *    IFLAGI(1).EQ.0.AND.IFLAGI(3).EQ.0.AND.
     *    IFTAGI(1).EQ.0.AND.IFTAGI(3).EQ.0) GO TO 2
C
      IF (ISIMPY.EQ.1) GO TO 2
C
C=======================================================================
C          X-DIRECTION
C=======================================================================
C
      OMEGAC=0.0D0
      IF (ITILAX   .NE.0) OMEGAC=OMEGAC+             OMOVAX
      IF (ITISAX   .NE.0) OMEGAC=OMEGAC+(1-2*ICHARG)*OMISOX
      IF (IFLAGI(1).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFI(1)*(ANGU_T(1)-ASKEDI(1))
      IF (IFTAGI(1).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFTI(1)*(ANGU_N(1)-ANGU_P(1)
     *                                                 -ASKETI(1))*
     *                                                (1-2*ICHARG)
      IF (IFLAGA   .NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFA   *(ANGU_T(1)*OMEGAT
     *                                       -OMOVAX   *OMEGAJ)/OMEGAT
C
      IF (ITWCEN.EQ.1) THEN
C
          IF (NO_ORB.NE.1) THEN
C
              CALL INT_LX(IPHAPM(0,0,0),HAUXPM,OMEGAC)
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                            -UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                            +UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
C
C             CALL PUTIMA(-1,HAUXPM,BIG_PM(1,1,1))
C
          END IF
C
          CALL INT_SX(HAUXPM,OMEGAC)
C
          BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               -HAUXPM(1:NDBASE,1:NDBASE)
          BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                               -HAUXPM(1:NDBASE,1:NDBASE)
C
C     CALL PUTREA(-1,HAUXPM,BIG_PM(1,1,1))
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IF (INDCOE.EQ.1.OR.INDCOE.EQ.13.OR.INDCOE.EQ.9) THEN
C
              IF (NO_ORB.NE.1) THEN
C
                  CALL TWC_LX(HAUXPM,OMEGAC,LTWCEN)
C
                  DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                     DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                        NY=NYVECT(IBRA,IND2HL(LTWCEN))
                        MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                        BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAPP(NY,MY,0)
                        BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAMM(NY,MY,0)
                        BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAPM(NY,MY,0)
                        BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAMP(NY,MY,0)
C
                     END DO
                  END DO
C
              END IF
C
              CALL TWC_SX(HAUXPM,OMEGAC,LTWCEN)
C
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                    NY=NYVECT(IBRA,IND2HL(LTWCEN))
                    MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                    BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                   -HAUXPM(IBRA,IKET)*IPHAPP(NY,MY,0)
                    BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                   -HAUXPM(IBRA,IKET)*IPHAMM(NY,MY,0)
                    BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                   -HAUXPM(IBRA,IKET)*IPHAPM(NY,MY,0)
                    BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                   -HAUXPM(IBRA,IKET)*IPHAMP(NY,MY,0)
C
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          Z-DIRECTION
C=======================================================================
C
      OMEGAC=0.0D0
      IF (ITILAX   .NE.0) OMEGAC=OMEGAC+             OMOVAZ
      IF (ITISAX   .NE.0) OMEGAC=OMEGAC+(1-2*ICHARG)*OMISOZ
      IF (IFLAGI(3).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFI(3)*(ANGU_T(3)-ASKEDI(3))
      IF (IFTAGI(3).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFTI(3)*(ANGU_N(3)-ANGU_P(3)
     *                                                 -ASKETI(3))*
     *                                                (1-2*ICHARG)
      IF (IFLAGA   .NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFA   *(ANGU_T(3)*OMEGAT
     *                                       -OMOVAZ   *OMEGAJ)/OMEGAT
C
      IF (ITWCEN.EQ.1) THEN
C
          IF (NO_ORB.NE.1) THEN
C
              CALL INT_LZ(IPHAPM(0,0,0),HAUXPM,OMEGAC)
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                            -UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                            +UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
C
C         CALL PUTIMA(-1,HAUXPM,BIG_PM(1,1,1))
C
          END IF
C
          CALL INT_SZ(HAUXPM,OMEGAC)
C
          BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                        -UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
          BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                        +UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
C
C     CALL PUTIMA(-1,HAUXPM,BIG_PM(1,1,1))
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IF (INDCOE.EQ.1.OR.INDCOE.EQ.13.OR.INDCOE.EQ.9) THEN
C
              IF (NO_ORB.NE.1) THEN
C
                  CALL TWC_LZ(HAUXPM,OMEGAC,LTWCEN)
C
                  DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                     DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                        NY=NYVECT(IBRA,IND2HL(LTWCEN))
                        MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                        BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAPP(NY,MY,0)
                        BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAMM(NY,MY,0)
                        BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAPM(NY,MY,0)
                        BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAMP(NY,MY,0)
C
                     END DO
                  END DO
C
              END IF
C
              CALL TWC_SZ(HAUXPM,OMEGAC,LTWCEN)
C
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                    NY=NYVECT(IBRA,IND2HL(LTWCEN))
                    MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                    BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *            -UNIT_I*HAUXPM(IBRA,IKET)*IPHAPP(NY,MY,0)
                    BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *            -UNIT_I*HAUXPM(IBRA,IKET)*IPHAMM(NY,MY,0)
                    BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *            -UNIT_I*HAUXPM(IBRA,IKET)*IPHAPM(NY,MY,0)
                    BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *            -UNIT_I*HAUXPM(IBRA,IKET)*IPHAMP(NY,MY,0)
C
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C          Y-DIRECTION
C=======================================================================
C
      OMEGAC=OMOVAY+(1-2*ICHARG)*OMISOY
      IF (IFLAGI(2).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFI(2)*(ANGU_T(2)-ASKEDI(2))
      IF (IFTAGI(2).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFTI(2)*(ANGU_N(2)-ANGU_P(2)
     *                                                 -ASKETI(2))*
     *                                                (1-2*ICHARG)
      IF (IFLAGA   .NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFA   *(ANGU_T(2)*OMEGAT
     *                                       -OMOVAY   *OMEGAJ)/OMEGAT
C
      IF (ITWCEN.EQ.1) THEN
C
          IF (NO_ORB.NE.1) THEN
C
              CALL INT_LY(IPHAPP(0,0,0),HAUXPP,OMEGAC)
C
              BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                            -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
              BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                            -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
C
C         CALL PUTIMA(-1,HAUXPP,BIG_PP(1,1,1))
C
          END IF
C
          CALL INT_SY(HAUXPP,OMEGAC)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                               -HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
C
C     CALL PUTREA(-1,HAUXPP,BIG_PP(1,1,1))
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IF (INDCOE.EQ.1.OR.INDCOE.EQ.13.OR.INDCOE.EQ.9) THEN
C
              IF (NO_ORB.NE.1) THEN
C
                  CALL TWC_LY(HAUXPM,OMEGAC,LTWCEN)
C
                  DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                     DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                        NY=NYVECT(IBRA,IND2HL(LTWCEN))
                        MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                        BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAPP(NY,MY,0)
                        BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAMM(NY,MY,0)
                        BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAPM(NY,MY,0)
                        BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                -UNIT_I*HAUXPM(IBRA,IKET)*IPHAMP(NY,MY,0)
C
                     END DO
                  END DO
C
              END IF
C
              CALL TWC_SY(HAUXPM,OMEGAC,LTWCEN)
C
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                    NY=NYVECT(IBRA,IND2HL(LTWCEN))
                    MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                    BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                   -HAUXPM(IBRA,IKET)*IPHAPP(NY,MY,0)
                    BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                   -HAUXPM(IBRA,IKET)*IPHAMM(NY,MY,0)
                    BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                   -HAUXPM(IBRA,IKET)*IPHAPM(NY,MY,0)
                    BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                   -HAUXPM(IBRA,IKET)*IPHAMP(NY,MY,0)
C
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          CALCULATING THE BARE-MASS KINETIC ENERGY MATRIX ELEMENTS
C=======================================================================
C          TWO-CENTRE BASIS OPTION: AS THIS TERM DOES NOT DEPEND OF THE
C          FIELDS IT MUST BE CONSIDERED ONLY ONCE PER TWO-CENTRE BLOCK.
C          MOREOVER, IF A SEPARATION IN THE BASIS IS PRESENT ALONG THE
C          Y-AXIS, THE KINETIC ENERGY OPERATOR BREAKS THE SIMPLEX SYMME-
C          TRY. AS A RESULT, PM BLOCKS MUST BE CONSIDERED AS WELL.
C=======================================================================
      IF (INDCOE.EQ.1.OR.INDCOE.EQ.13.OR.INDCOE.EQ.9) THEN
C
          IF (ITWCEN.EQ.1) THEN
C
              CALL INTKIN(HAUXPP,HBMRPA,LTWCEN)
C
              BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                                   +HAUXPP(1:NDBASE,1:NDBASE)
              BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                                   +HAUXPP(1:NDBASE,1:NDBASE)
          ELSEIF (ITWCEN.EQ.2) THEN

              CALL TWC_INTKIN(HAUXPP,HBMRPA,LTWCEN)
C
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                    NY=NYVECT(IBRA,IND2HL(LTWCEN))
                    MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                    BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                   +HAUXPP(IBRA,IKET)*IPHAPP(NY,MY,0)
                    BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                   +HAUXPP(IBRA,IKET)*IPHAMM(NY,MY,0)
                    BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                   +HAUXPP(IBRA,IKET)*IPHAPM(NY,MY,0)
                    BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                   +HAUXPP(IBRA,IKET)*IPHAMP(NY,MY,0)
                 END DO
              END DO
C
          END IF
C
      END IF
C
C     CALL PUTREA(+1,HAUXPP,BIG_PP(1,1,0))
C
C=======================================================================
C          INTRODUCING THE CONSTRAINTS ON MULTIPOLE MOMENTS
C=======================================================================

      IF (ITWCEN.EQ.1) THEN
C
          CALL INTCON(ISIMPY,ICHARG,ISCHIF,NMUCON,NSICON,HAUXPP,HAUXPM,
     *                                                          IF_RPA)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                                 +HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                                 +HAUXPP(1:NDBASE,1:NDBASE)
C
          IF (ISIMPY.NE.1) THEN
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                                     +HAUXPM(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                                     -HAUXPM(1:NDBASE,1:NDBASE)
           END IF
C
C          CALL PUTREA(+1,HAUXPP,BIG_PP(1,1,0))
C
C          IF (ISIMPY.NE.1) CALL PUTREA(+1,HAUXPM,BIG_PM(1,1,0))
C
C
      ELSEIF (ITWCEN.EQ.2) THEN
C=======================================================================
C          TWO-CENTRE BASIS OPTION: SEE PREVIOUS COMMENT BEFORE KINETIC
C          ENERGY MATRIX ELEMENTS
C=======================================================================
          IF (INDCOE.EQ.1.OR.INDCOE.EQ.13.OR.INDCOE.EQ.9) THEN
C
              CALL TWC_INTCON(ICHARG,NMUCON,HAUXPP,LTWCEN,IF_RPA)
C
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                    NY=NYVECT(IBRA,IND2HL(LTWCEN))
                    MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                    BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                   +HAUXPP(IBRA,IKET)*IPHAPP(NY,MY,0)
                    BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                   +HAUXPP(IBRA,IKET)*IPHAMM(NY,MY,0)
                    BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                   +HAUXPP(IBRA,IKET)*IPHAPM(NY,MY,0)
                    BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                   +HAUXPP(IBRA,IKET)*IPHAMP(NY,MY,0)
C
                 END DO
              END DO
C
              CALL TWC_FRACON(NMUCON,HAUXPP,LTWCEN)
C
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
                    NY=NYVECT(IBRA,IND2HL(LTWCEN))
                    MY=NYVECT(IKET,IND2HR(LTWCEN))
C
                    BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                   +HAUXPP(IBRA,IKET)*IPHAPP(NY,MY,0)
                    BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                   +HAUXPP(IBRA,IKET)*IPHAMM(NY,MY,0)
                    BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                   +HAUXPP(IBRA,IKET)*IPHAPM(NY,MY,0)
                    BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                   +HAUXPP(IBRA,IKET)*IPHAMP(NY,MY,0)
C
                 END DO
              END DO
C
          END IF
C
      END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C=======================================================================
C          INTRODUCING THE CONSTRAINTS ON THE NECK
C=======================================================================
C
      NZMAXX=NZMAXV(1)
C
      IF (IFNECK.EQ.2.AND.IF_RPA.EQ.1) THEN
C
          CALL INT_QN(NZMAXX,HAUXPP)
C
          BIG_PP(:,:,0)=BIG_PP(:,:,0)-G_NECK*HAUXPP(:,:)
          BIG_PP(:,:,1)=BIG_PP(:,:,1)-G_NECK*HAUXPP(:,:)
C
      END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C=======================================================================
C          INSERTING THE MATRIX ELEMENTS OF THE HO POTENTIAL
C=======================================================================
C
      IF (IPOTHO.EQ.1) THEN
C
          ESCALE=0.0D0
C
          CALL INT_HO(HAUXPP,HBMASS,ESCALE,
     *       HBAROX(1),HBAROY(1),HBAROZ(1),1)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
C
C         CALL PUTREA(+1,HAUXPP,BIG_PP(1,1,0))
C
      END IF
C
C=======================================================================
C          INSERTING THE COULOMB MATRIX ELEMENTS, WHICH ARE SUPPOSED
C          TO BE ALREADY CALCULATED BEFORE
C=======================================================================
C
      IF (ICHARG.EQ.1.AND.ICOUDI.EQ.1) THEN
C
C         DO IKET=1,LDBASE
C            DO IBRA=1,LDBASE
C               HAUXPP(IBRA,IKET)=REAL(HPPCOU(IBRA,IKET))
C            END DO
C         END DO
C
C         IF (ISIMPY.NE.1) THEN
C             DO IKET=1,LDBASE
C                DO IBRA=1,LDBASE
C                   HAUXPM(IBRA,IKET)=REAL(HPMCOU(IBRA,IKET))
C                END DO
C             END DO
C         END IF
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                               +HPPCOU(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                               +HPPCOU(1:NDBASE,1:NDBASE)
C
          IF (ISIMPY.NE.1) THEN
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                                   +HPMCOU(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                                   -HPMCOU(1:NDBASE,1:NDBASE)
          END IF
C
C             IF (ISIMPY.NE.1) CALL PUTREA(+1,HAUXPM,BIG_PM(1,1,0))
C                              CALL PUTREA(+1,HAUXPP,BIG_PP(1,1,0))
C
      END IF
C
C=======================================================================
C          INSERTING THE LINEAR-MOMENTUM-SQUARED DIRECT MATRIX  ELEMENTS
C=======================================================================
C
      IF (JETACM.EQ.2) THEN
C
          CALL INTPX2(IPHAPP(0,0,0),HAUXPP,HBMREN(1))
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
C
C         CALL PUTREA(+1,HAUXPP,BIG_PP(1,1,0))
C
          CALL INTPY2(IPHAPP(0,0,0),HAUXPP,HBMREN(2))
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
C
C         CALL PUTREA(+1,HAUXPP,BIG_PP(1,1,0))
C
          CALL INTPZ2(IPHAPP(0,0,0),HAUXPP,
     *                                                   HBMREN(3))
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                               +HAUXPP(1:NDBASE,1:NDBASE)
C
C         CALL PUTREA(+1,HAUXPP,BIG_PP(1,1,0))
C
      END IF
C
C=======================================================================
C          INSERTING THE ANGULAR-MOMENTUM-SQUARED DIRECT MATRIX ELEMENTS
C=======================================================================
C
      IF (KETA_R.EQ.2) THEN
C
          FACTOR=ROTREN(1)
C
          CALL INTLX2(HAUXPP,FACTOR)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                       +HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                       +HAUXPP(1:NDBASE,1:NDBASE)
C
          CALL INT_LX(IPHAPP(0,0,1),HAUXPP,FACTOR)
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                +UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
C
          FACTOR=ROTREN(2)
C
          CALL INTLY2(HAUXPP,FACTOR)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                       +HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                       +HAUXPP(1:NDBASE,1:NDBASE)
C
          CALL INT_LY(IPHAPP(0,0,2),HAUXPP,FACTOR)
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                +UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
C
          FACTOR=ROTREN(3)
C
          CALL INTLZ2(HAUXPP,FACTOR)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                       +HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                       +HAUXPP(1:NDBASE,1:NDBASE)
C
          CALL INT_LZ(IPHAPP(0,0,3),HAUXPP,FACTOR)
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                       -HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                       -HAUXPP(1:NDBASE,1:NDBASE)
C
          DO IBRA=1,LDBASE
C
              BIG_PP(IBRA,IBRA,0)=BIG_PP(IBRA,IBRA,0)
     *        +(ROTREN(1)+ROTREN(2)+ROTREN(3))*0.25d0
              BIG_PP(IBRA,IBRA,1)=BIG_PP(IBRA,IBRA,1)
     *        +(ROTREN(1)+ROTREN(2)+ROTREN(3))*0.25d0
C
          END DO
      END IF
C
C=======================================================================
C
      END IF ! END OF ITPNMX.LE.1 (NOT INDENTED)
C
C=======================================================================
C          CALCULATING EFFECTIVE-MASS TERM MATRIX ELEMENTS
C=======================================================================
C
      NDEGRE=2
C
      CALL BEGINC(VE_MAS(1,1,1,ITPNMX,INDCOE),SONBAS,NDEGRE,
     *                          HERMTS,FOURWG,INDCOE,ITWCEN)
C
      KARTEZ=0
C

      CALL INTMAS(SONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,
     *                                 ITWCEN,INDCOE)
C
      BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           +HCOMPP(1:NDBASE,1:NDBASE)
      BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                           +HCOMPP(1:NDBASE,1:NDBASE)
C
      IF (ISIMPY.NE.1) THEN
C
          BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               +HCOMPM(1:NDBASE,1:NDBASE)
          BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                               -HCOMPM(1:NDBASE,1:NDBASE)
      END IF
C
C
C     CALL PUTCOM(+1,HCOMPP,BIG_PP(1,1,0))
C
C     IF (ISIMPY.NE.1) CALL PUTCOM(+1,HCOMPM,BIG_PM(1,1,0))
C
C=======================================================================
C          CALCULATING  CENTRAL-TERM  MATRIX ELEMENTS
C=======================================================================
C
      NDEGRE=0
C
      CALL BEGINC(VE_CEN(1,1,1,ITPNMX,INDCOE),SONBAS,NDEGRE,
     *                         HERMTS,FOURWG,INDCOE,ITWCEN)
C
      KARTEZ=0
C
      CALL INTCEN(SONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,
     *                                 ITWCEN,INDCOE)
C
      BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           +HCOMPP(1:NDBASE,1:NDBASE)
      BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                           +HCOMPP(1:NDBASE,1:NDBASE)
C
      IF (ISIMPY.NE.1) THEN
C
          BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               +HCOMPM(1:NDBASE,1:NDBASE)
          BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                               -HCOMPM(1:NDBASE,1:NDBASE)
      END IF
C
C     CALL PUTCOM(+1,HCOMPP,BIG_PP(1,1,0))
C
C     IF (ISIMPY.NE.1) CALL PUTCOM(+1,HCOMPM,BIG_PM(1,1,0))
C
C=======================================================================
C          CALCULATING  SPIN-ORBIT TERM MATRIX ELEMENTS
C=======================================================================
C
      NDEGRE=1
C
      DO K=1,NDKART
C
         DO L=1,NDKART
C
            CALL BEGINC(VE_SOR(1,1,1,L,K,ITPNMX,INDCOE),VONBAS(0,0,0,L),
     *                              NDEGRE,HERMTS,FOURWG,INDCOE,ITWCEN)
C
         END DO
C
         KARTEZ=K
C
         CALL INTSOR(VONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,
     *                                    ITWCEN,INDCOE)
C
         IF (K.EQ.1)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           -UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.2)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           -UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.3)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                                  +HCOMPP(1:NDBASE,1:NDBASE)
C
         IF (K.EQ.1)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                           +UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.2)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                           +UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.3)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                                  +HCOMPP(1:NDBASE,1:NDBASE)
C
C        IF (K.EQ.1) CALL PUTCOI(-1,HCOMPP,BIG_PP(1,1,0))
C        IF (K.EQ.2) CALL PUTCOI(-1,HCOMPP,BIG_PP(1,1,0))
C        IF (K.EQ.3) CALL PUTCOM(+1,HCOMPP,BIG_PP(1,1,0))
C
         IF (ISIMPY.NE.1) THEN
C
             IF (K.EQ.1)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               -UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.2)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               -UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.3)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
C
             IF (K.EQ.1)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                               -UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.2)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                               -UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.3)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                                      -HCOMPM(1:NDBASE,1:NDBASE)
C
C            IF (K.EQ.1) CALL PUTCOI(-1,HCOMPM,BIG_PM(1,1,0))
C            IF (K.EQ.2) CALL PUTCOI(-1,HCOMPM,BIG_PM(1,1,0))
C            IF (K.EQ.3) CALL PUTCOM(+1,HCOMPM,BIG_PM(1,1,0))
C
         END IF
C
      END DO
C
C=======================================================================
C          THE MATRIX ELEMENTS OF  TIME - ODD  TERMS  ARE NOT CALCULATED
C          WHEN THE CASE WITH   N O   R O T A T I O N  HAS BEEN SELECTED
C=======================================================================
C
      IF (IROTAT.NE.1) GO TO 1
C
C=======================================================================
C          THE BLOCK BELOW IS EXECUTED ONLY FOR THE TERMS THAT ARE
C          DIAGONAL IN ISOSPIN (NOT INDENTED)
C=======================================================================
C
      IF (ITPNMX.LE.1) THEN
C
C=======================================================================
C          INSERTING THE LINEAR-MOMENTUM LINEAR MATRIX ELEMENTS
C=======================================================================
C          ATTENTION: INDEPENENTLY OF ICHARG, THE AVERAGE VALUE  OF  THE
C                     TOTAL LINEAR  MOMENTUM "ALINLT" MUST BE USED BELOW
C                     SEE NOTES 9-97C.
C=======================================================================
C
      IF (JETACM.EQ.2.AND.ABS(ITWOLI).EQ.1) THEN
C
          FACTOR=2*HBMREN(1)*ALINLT(1)
C
          CALL INT_PX(IPHAPP(0,0,0),HAUXPP,FACTOR)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                        -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                        -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
C
C         CALL PUTIMA(-1,HAUXPP,BIG_PP(1,1,1))
C
          FACTOR=2*HBMREN(3)*ALINLT(3)
C
          CALL INT_PZ(IPHAPP(0,0,0),HAUXPP,FACTOR)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                        -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                        -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
C
C         CALL PUTIMA(-1,HAUXPP,BIG_PP(1,1,1))
C
          IF (ISIMPY.NE.1) THEN
C
              FACTOR=2*HBMREN(2)*ALINLT(2)
C
              CALL INT_PY(IPHAPM(0,0,0),HAUXPM,FACTOR)
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                            -UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                            +UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
C
C             CALL PUTIMA(-1,HAUXPM,BIG_PM(1,1,1))
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE ANGULAR-MOMENTUM LINEAR MATRIX ELEMENTS
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.68U) AND  (2.96T),  THE  INTEGH
C                    CALLS TO ROUTINES "INT_L?" AND  "INT_S?"  WERE  FOR
C                    KETA_R=2 PERFORMED WITH ARGUMENTS "FACTOR" REPLACED
C                    INCORRECTLY WITH ARGUMENTS "OMEGAC". THIS  BUG  WAS
C                    CORRECTED ON 13/07/2020 IN VERSION (2.96U). THE BUG
C                    WAS RENDERING ANY  CALCULATION  PERFORMED  FOR  THE
C                    SELF-CONSISTENTLY INCLUDED ROTATIONAL  CORRECTIONS,
C                    THAT IS, FOR ABS(ITWOLI)=1, INCORRECT.
C=======================================================================
C          ATTENTION: INDEPENENTLY OF ICHARG, THE AVERAGE VALUE  OF  THE
C                     TOTAL ANGULAR MOMENTUM "AROTLT" MUST BE USED BELOW
C                     SEE NOTES 9-97C.
C=======================================================================
C
      IF (KETA_R.EQ.2.AND.ABS(ITWOLI).EQ.1) THEN
C
          FACTOR=-2*ROTREN(2)*AROTLT(2)
C
          CALL INT_LY(IPHAPP(0,0,0),HAUXPP,FACTOR)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                        -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                        -UNIT_I*HAUXPP(1:NDBASE,1:NDBASE)
C
          CALL INT_SY(HAUXPP,FACTOR)
C
          BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           -HAUXPP(1:NDBASE,1:NDBASE)
          BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                           +HAUXPP(1:NDBASE,1:NDBASE)
C
          IF (ISIMPY.NE.1) THEN
C
              FACTOR=-2*ROTREN(1)*AROTLT(1)
C
              CALL INT_LX(IPHAPM(0,0,0),HAUXPM,FACTOR)
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                            -UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                            +UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
              CALL INT_SX(HAUXPM,FACTOR)
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                                   -HAUXPM(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                                   -HAUXPM(1:NDBASE,1:NDBASE)
C
              FACTOR=-2*ROTREN(3)*AROTLT(3)
C
              CALL INT_LZ(IPHAPM(0,0,0),HAUXPM,FACTOR)
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                            -UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                            +UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
C
              CALL INT_SZ(HAUXPM,FACTOR)
C
              BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                            -UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
              BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                            +UNIT_I*HAUXPM(1:NDBASE,1:NDBASE)
C
          END IF
C
      END IF
C
C=======================================================================
C          END OF THE BLOCK EXECUTED ONLY FOR THE TERMS THAT ARE
C          DIAGONAL IN ISOSPIN (NOT INDENTED)
C=======================================================================
C
      END IF ! END OF ITPNMX.LE.1 (NOT INDENTED)
C
C=======================================================================
C          CALCULATING  KINETIC SPIN TERM MATRIX ELEMENTS
C=======================================================================
C
      NDEGRE=2
C
      DO K=1,NDKART
C
         CALL BEGINC(VE_KIS(1,1,1,K,ITPNMX,INDCOE),SONBAS,NDEGRE,
     *                        HERMTS,FOURWG,INDCOE,ITWCEN)
C
         KARTEZ=K
C
         CALL INTMAS(SONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,
     *                                    ITWCEN,INDCOE)
C
         IF (K.EQ.1)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                                  +HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.2)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                                  +HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.3)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           +UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
C
         IF (K.EQ.1)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                                  -HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.2)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                                  -HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.3)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                           +UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
C
C        IF (K.EQ.1) CALL PUTCOM(+1,HCOMPP,BIG_PP(1,1,1))
C        IF (K.EQ.2) CALL PUTCOM(+1,HCOMPP,BIG_PP(1,1,1))
C        IF (K.EQ.3) CALL PUTCOI(+1,HCOMPP,BIG_PP(1,1,1))
C
         IF (ISIMPY.NE.1) THEN
C
             IF (K.EQ.1)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.2)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.3)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               +UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
C
             IF (K.EQ.1)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.2)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.3)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                               -UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
C
C            IF (K.EQ.1) CALL PUTCOM(+1,HCOMPM,BIG_PM(1,1,1))
C            IF (K.EQ.2) CALL PUTCOM(+1,HCOMPM,BIG_PM(1,1,1))
C            IF (K.EQ.3) CALL PUTCOI(+1,HCOMPM,BIG_PM(1,1,1))
C
         END IF
C
      END DO
C
C=======================================================================
C          CALCULATING  TENSOR TERM MATRIX ELEMENTS
C=======================================================================
C
      NDEGRE=2
C
      DO K=1,NDKART
C
         CALL BEGINC(VE_KIT(1,1,1,K,ITPNMX,INDCOE),VONBAS(0,0,0,K),
     *                         NDEGRE,HERMTS,FOURWG,INDCOE,ITWCEN)
C
      END DO
C
      CALL INTTEN(VONBAS,ISIMPY,HCOMPP,HCOMPM)
C
      BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           +HCOMPP(1:NDBASE,1:NDBASE)
      BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                     -CONJG(HCOMPP(1:NDBASE,1:NDBASE))
C
      IF (ISIMPY.NE.1) THEN
C
          BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               +HCOMPM(1:NDBASE,1:NDBASE)
          BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                         +CONJG(HCOMPM(1:NDBASE,1:NDBASE))
C
      END IF
C
C=======================================================================
C          CALCULATING THE SPIN-DIV (SPT) TENSOR TERM MATRIX ELEMENTS
C=======================================================================
C
      NDEGRE=1
C
      CALL BEGINC(VE_SPT(1,1,1,ITPNMX,INDCOE),SONBAS(0,0,0),NDEGRE,
     *                          HERMTS,FOURWG,INDCOE,ITWCEN)
C
      CALL INTSPT(SONBAS,ISIMPY,HCOMPP,HCOMPM)
C
      BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           +HCOMPP(1:NDBASE,1:NDBASE)
      BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                     -CONJG(HCOMPP(1:NDBASE,1:NDBASE))
C
      IF (ISIMPY.NE.1) THEN
C
          BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               +HCOMPM(1:NDBASE,1:NDBASE)
          BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                         +CONJG(HCOMPM(1:NDBASE,1:NDBASE))
C
      END IF
C
C=======================================================================
C          CALCULATING   S  P  I  N  TERM MATRIX ELEMENTS
C=======================================================================
C
      NDEGRE=0
C
      DO K=1,NDKART
C
         CALL BEGINC(VE_SPI(1,1,1,K,ITPNMX,INDCOE),SONBAS,NDEGRE,
     *                        HERMTS,FOURWG,INDCOE,ITWCEN)
C
         KARTEZ=K
C
         CALL INTCEN(SONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,
     *                                    ITWCEN,INDCOE)
C
         IF (K.EQ.1)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                                  +HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.2)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                                  +HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.3)
     *       BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                           +UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
C
         IF (K.EQ.1)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                                  -HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.2)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                                  -HCOMPP(1:NDBASE,1:NDBASE)
         IF (K.EQ.3)
     *       BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                           +UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
C
C        IF (K.EQ.1) CALL PUTCOM(+1,HCOMPP,BIG_PP(1,1,1))
C        IF (K.EQ.2) CALL PUTCOM(+1,HCOMPP,BIG_PP(1,1,1))
C        IF (K.EQ.3) CALL PUTCOI(+1,HCOMPP,BIG_PP(1,1,1))
C
         IF (ISIMPY.NE.1) THEN
C
             IF (K.EQ.1)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.2)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.3)
     *           BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                               +UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
C
             IF (K.EQ.1)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.2)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                                      +HCOMPM(1:NDBASE,1:NDBASE)
             IF (K.EQ.3)
     *           BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                               -UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
C
C            IF (K.EQ.1) CALL PUTCOM(+1,HCOMPM,BIG_PM(1,1,1))
C            IF (K.EQ.2) CALL PUTCOM(+1,HCOMPM,BIG_PM(1,1,1))
C            IF (K.EQ.3) CALL PUTCOI(+1,HCOMPM,BIG_PM(1,1,1))
C
         END IF
C
      END DO
C
C=======================================================================
C          CALCULATING  C U R R E N T  TERM MATRIX ELEMENTS
C=======================================================================
C
      NDEGRE=1
C
      DO L=1,NDKART
C
         CALL BEGINC(VE_CUR(1,1,1,L,ITPNMX,INDCOE),VONBAS(0,0,0,L),
     *                         NDEGRE,HERMTS,FOURWG,INDCOE,ITWCEN)
C
      END DO
C
      KARTEZ=0
C
      CALL INTSOR(VONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,
     *                                 ITWCEN,INDCOE)
C
      BIG_PP(1:NDBASE,1:NDBASE,0)=BIG_PP(1:NDBASE,1:NDBASE,0)
     *                    -UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
      BIG_PP(1:NDBASE,1:NDBASE,1)=BIG_PP(1:NDBASE,1:NDBASE,1)
     *                    -UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
C
      IF (ISIMPY.NE.1) THEN
C
          BIG_PM(1:NDBASE,1:NDBASE,0)=BIG_PM(1:NDBASE,1:NDBASE,0)
     *                        -UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
          BIG_PM(1:NDBASE,1:NDBASE,1)=BIG_PM(1:NDBASE,1:NDBASE,1)
     *                        +UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
      END IF
C
C     CALL PUTCOI(-1,HCOMPP,BIG_PP(1,1,1))
C
C     IF (ISIMPY.NE.1) CALL PUTCOI(-1,HCOMPM,BIG_PM(1,1,1))
C
C=======================================================================
C         RETURN FROM THE   N O - R O T A T I O N    CASE
C=======================================================================
C
    1 CONTINUE
C
C=======================================================================
C       INSERTING THE ISOSCALAR AND ISOVECTOR FERMI ENERGIES
C=======================================================================
C       ATTENTION! THE CODE USES  LINEAR  CONSTRAINTS  CORRESPONDING  TO
C                             S T A N D A R D   I S O S P I N
C                  THAT IS, CONSTRAINING TERM IN THE  Z-DIRECTION  READS
C                  -FERISO(3)*(IN_FIX-IZ_FIX)/2 = -FERISO(3)*TOTISO(3)
C                  THIS IS DONE TO KEEP THE CONSISTENCY WITH DEFINITIONS
C                  GIVEN IN 1308.1997  BUT  BREAKS  THE  SYMMETRY  WITH
C                  RESPECT TO THE ISOSCALAR CONSTRAINT, WHICH DEPENDS ON
C                  THE ISOSCALAR FERMI ENERGY AS:
C                               -FERISO(0)*(IN_FIX+IZ_FIX)
C                  THAT IS, IT DOES  NOT  CONTAIN  THE  FACTOR  OF  1/2.
C                  THEREFORE, THE FACTORS OF 1/2 MUST EXPLICITLY  APPEAR
C                  WHENEVER THE ISOVECTOR FERMI ENERGIES ARE USED IN THE
C                  MEAN FIELDS.
C=======================================================================
C
      IF (IPNMIX.EQ.1) THEN
C
          FERFAC=0.0D0
C
          IF (ITPNMX.EQ.0) FERFAC =       FERMOV(0) +FERMOV(3) /2
          IF (ITPNMX.EQ.1) FERFAC =       FERMOV(0) -FERMOV(3) /2
          IF (ITPNMX.EQ.2) FERFAC = CMPLX(FERMOV(1),-FERMOV(2))/2
          IF (ITPNMX.EQ.3) FERFAC = CMPLX(FERMOV(1), FERMOV(2))/2
C
          DO IBRA=1,LDBASE
C
             IKET=IBRA
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)-FERFAC
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)-FERFAC
C
          END DO
C
      END IF
C
C=======================================================================
C          THE BLOCK BELOW IS EXECUTED ONLY FOR THE TERMS THAT ARE
C          DIAGONAL IN ISOSPIN (NOT INDENTED)
C=======================================================================
C
      IF (ITPNMX.LE.1) THEN
C
C=======================================================================
C         INSERTING THE LIPKIN-NOGAMI CORRECTION TERM
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.97J) AND (3.07B), THE CONDITION
C                    BELOW TO  GRAB  THE  LIKIN-NOGAMI  ARRAYS  DID  NOT
C                    INCLUDE THE TEST OF "MPAHFB". AS  A  RESULT,  AFTER
C                    IMPLEMENTING THE DYNAMIC DOWNGRADE OF  HFB  TO  HF,
C                    IN AN HF RUN THE CODE WAS  STOPPING. THIS  BUG  WAS
C                    PRESENT IN SEVEN INSTANCES HERE AND BELOW, AND  WAS
C                    CORRECTED ON 25/09/2021 IN VERSIONS (3.07C).
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.LIPKIX.EQ.1) THEN
C
          IF (IS_DLI(ICHARG).NE.1) STOP ' NO DLI_PP IN INTEGH (1)'
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)+4*EFER2X*
     *                              DLI_PP(IBRA,IKET,0,ICHARG)
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)+4*EFER2X*
     *                              DLI_PP(IBRA,IKET,1,ICHARG)
C
             END DO
          END DO
C
          DO IBRA=1,LDBASE
C
             IKET=IBRA
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)-2*EFER2X
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)-2*EFER2X
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO IKET=1,LDBASE
                 DO IBRA=1,LDBASE
C
                    BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)+4*EFER2X*
     *                                  DLI_PM(IBRA,IKET,0,ICHARG)
                    BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)+4*EFER2X*
     *                                  DLI_PM(IBRA,IKET,1,ICHARG)
C
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C   NEUTRON    INSERTING THE LAMBDA2 TERM FROM LIPKIN METHOD
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.ICHARG.EQ.0.AND.(ILIPON.EQ.2.OR.ILIPON.EQ.4
     *    .OR.ILIPON.EQ.6)) THEN
C
          IF (IS_DLI(0).NE.1) STOP ' NO DLI_PP IN INTEGH (2)'
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)+4*LAM2_N*
     *                              DLI_PP(IBRA,IKET,0,ICHARG)
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)+4*LAM2_N*
     *                              DLI_PP(IBRA,IKET,1,ICHARG)
C
             END DO
          END DO
C
          DO IBRA=1,LDBASE
C
             IKET=IBRA
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)-2*LAM2_N
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)-2*LAM2_N
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
          STOP 'SIMPLEX BROKEN NOT IMPLEMENTED YET FOR PARTICLE
     *          NUMBER FLUCTUATION BY LIPKIN METHOD'
C
          END IF
C
      END IF
C
C
C=======================================================================
C  NEUTRON   INSERTING THE LAMBDA4 TERM FROM LIPKIN METHOD
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.ICHARG.EQ.0.AND.(ILIPON.EQ.4.OR.ILIPON.EQ.6))
     *                                                              THEN
C
          IF (IS_DLI(0).NE.1) STOP ' NO DLI_PP IN INTEGH (3)'
C
          IF (ISIMPY.NE.1) THEN
C
          STOP 'SIMPLEX BROKEN NOT IMPLEMENTED YET FOR PARTICLE
     *          NUMBER FLUCTUATION BY LIPKIN METHOD'
C
          END IF
C
          DO IBRA=1,LDBASE
C
             IKET=IBRA
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          -8*LAM4_N-12*LAM4_N*NLIPNU(2,1,0)
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          -8*LAM4_N-12*LAM4_N*NLIPNU(2,1,0)
C
          END DO
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *            +(24*NLIPNU(2,1,0)+112)*LAM4_N
     *          *DLI_PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *            +(24*NLIPNU(2,1,0)+112)*LAM4_N
     *          *DLI_PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *            -288*LAM4_N
     *          *DEN2PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *            -288*LAM4_N
     *          *DEN2PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *            +192*LAM4_N
     *          *DEN3PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *            +192*LAM4_N
     *          *DEN3PP(IBRA,IKET,1,ICHARG)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C   NEUTRON   INSERTING THE LAMBDA6 TERM FROM LIPKIN METHOD
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.ICHARG.EQ.0.AND.(ILIPON.EQ.6)) THEN
C
          IF (IS_DLI(0).NE.1) STOP ' NO DLI_PP IN INTEGH (4)'
C
          IF (ISIMPY.NE.1) THEN
C
          STOP 'SIMPLEX BROKEN NOT IMPLEMENTED YET FOR PARTICLE
     *          NUMBER FLUCTUATION BY LIPKIN METHOD'
C
          END IF
C
          DO IBRA=1,LDBASE
C
             IKET=IBRA
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          -32*LAM6_N-90*NLIPNU(2,1,0)**2*LAM6_N
     *          -80*REAL(NLIPNU(3,1,0))*LAM6_N
     *          -120*NLIPNU(2,1,0)*LAM6_N
     *          -30*REAL(RLIPNU(4,1,0))*LAM6_N
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          -32*LAM6_N-90*NLIPNU(2,1,0)**2*LAM6_N
     *          -80*REAL(NLIPNU(3,1,0))*LAM6_N
     *          -120*NLIPNU(2,1,0)*LAM6_N
     *          -30*REAL(RLIPNU(4,1,0))*LAM6_N
C
          END DO
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          +(1984+180*NLIPNU(2,1,0)**2
     *            +480*REAL(NLIPNU(3,1,0))+1680*NLIPNU(2,1,0)
     *            +60*REAL(RLIPNU(4,1,0)))
     *          *LAM6_N*DLI_PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          +(1984+180*NLIPNU(2,1,0)**2
     *            +480*REAL(NLIPNU(3,1,0))+1680*NLIPNU(2,1,0)
     *            +60*REAL(RLIPNU(4,1,0)))
     *          *LAM6_N*DLI_PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          -(17280+4320*NLIPNU(2,1,0)
     *            +480*REAL(NLIPNU(3,1,0)))
     *          *LAM6_N*DEN2PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          -(17280+4320*NLIPNU(2,1,0)
     *            +480*REAL(NLIPNU(3,1,0)))
     *          *LAM6_N*DEN2PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          +(49920+2880*NLIPNU(2,1,0))
     *          *LAM6_N*DEN3PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          +(49920+2880*NLIPNU(2,1,0))
     *          *LAM6_N*DEN3PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          -57600*LAM6_N*DEN4PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          -57600*LAM6_N*DEN4PP(IBRA,IKET,1,ICHARG)
C
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          +23040*LAM6_N*DEN5PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          +23040*LAM6_N*DEN5PP(IBRA,IKET,1,ICHARG)
C
             END DO
          END DO
C
      END IF
C=======================================================================
C   PROTON    INSERTING THE LAMBDA2 TERM FROM LIPKIN METHOD
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.ICHARG.EQ.1.AND.(ILIPOP.EQ.2.OR.ILIPOP.EQ.4
     *    .OR.ILIPOP.EQ.6)) THEN
C
          IF (IS_DLI(1).NE.1) STOP ' NO DLI_PP IN INTEGH (5)'
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)+4*LAM2_P*
     *                              DLI_PP(IBRA,IKET,0,ICHARG)
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)+4*LAM2_P*
     *                              DLI_PP(IBRA,IKET,1,ICHARG)
C
             END DO
          END DO
C
          DO IBRA=1,LDBASE
C
             IKET=IBRA
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)-2*LAM2_P
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)-2*LAM2_P
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
          STOP 'SIMPLEX BROKEN NOT IMPLEMENTED YET FOR PARTICLE
     *          NUMBER FLUCTUATION BY LIPKIN METHOD'
C
          END IF
C
      END IF
C
C=======================================================================
C  PROTON   INSERTING THE LAMBDA4 TERM FROM LIPKIN METHOD
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.ICHARG.EQ.1.AND.(ILIPOP.EQ.4.OR.ILIPOP.EQ.6))
     *                                                              THEN
C
          IF (IS_DLI(1).NE.1) STOP ' NO DLI_PP IN INTEGH (6)'
C
          IF (ISIMPY.NE.1) THEN
C
          STOP 'SIMPLEX BROKEN NOT IMPLEMENTED YET FOR PARTICLE
     *          NUMBER FLUCTUATION BY LIPKIN METHOD'
C
          END IF
C
          DO IBRA=1,LDBASE
C
             IKET=IBRA
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          -8*LAM4_P-12*LAM4_P*NLIPNU(2,1,1)
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          -8*LAM4_P-12*LAM4_P*NLIPNU(2,1,1)
C
          END DO
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *            +(24*NLIPNU(2,1,1)+112)*LAM4_P
     *          *DLI_PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *            +(24*NLIPNU(2,1,1)+112)*LAM4_P
     *          *DLI_PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *            -288*LAM4_P
     *          *DEN2PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *            -288*LAM4_P
     *          *DEN2PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *            +192*LAM4_P
     *          *DEN3PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *            +192*LAM4_P
     *          *DEN3PP(IBRA,IKET,1,ICHARG)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C   PROTON   INSERTING THE LAMBDA6 TERM FROM LIPKIN METHOD
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.ICHARG.EQ.1.AND.(ILIPOP.EQ.6)) THEN
C
          IF (IS_DLI(1).NE.1) STOP ' NO DLI_PP IN INTEGH (7)'
C
          IF (ISIMPY.NE.1) THEN
C
          STOP 'SIMPLEX BROKEN NOT IMPLEMENTED YET FOR PARTICLE
     *          NUMBER FLUCTUATION BY LIPKIN METHOD'
C
          END IF
C
          DO IBRA=1,LDBASE
C
             IKET=IBRA
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          -32*LAM6_P-90*NLIPNU(2,1,1)**2*LAM6_P
     *          -80*REAL(NLIPNU(3,1,1))*LAM6_P
     *          -120*NLIPNU(2,1,1)*LAM6_P
     *          -30*REAL(RLIPNU(4,1,1))*LAM6_P
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          -32*LAM6_P-90*NLIPNU(2,1,1)**2*LAM6_P
     *          -80*REAL(NLIPNU(3,1,1))*LAM6_P
     *          -120*NLIPNU(2,1,1)*LAM6_P
     *          -30*REAL(RLIPNU(4,1,1))*LAM6_P
C
          END DO
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          +(1984+180*NLIPNU(2,1,1)**2
     *            +480*REAL(NLIPNU(3,1,1))+1680*NLIPNU(2,1,1)
     *            +60*REAL(RLIPNU(4,1,1)))
     *          *LAM6_P*DLI_PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          +(1984+180*NLIPNU(2,1,1)**2
     *            +480*REAL(NLIPNU(3,1,1))+1680*NLIPNU(2,1,1)
     *            +60*REAL(RLIPNU(4,1,1)))
     *          *LAM6_P*DLI_PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          -(17280+4320*NLIPNU(2,1,1)
     *            +480*REAL(NLIPNU(3,1,1)))
     *          *LAM6_P*DEN2PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          -(17280+4320*NLIPNU(2,1,1)
     *            +480*REAL(NLIPNU(3,1,1)))
     *          *LAM6_P*DEN2PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          +(49920+2880*NLIPNU(2,1,1))
     *          *LAM6_P*DEN3PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          +(49920+2880*NLIPNU(2,1,1))
     *          *LAM6_P*DEN3PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          -57600*LAM6_P*DEN4PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          -57600*LAM6_P*DEN4PP(IBRA,IKET,1,ICHARG)
C
                BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *          +23040*LAM6_P*DEN5PP(IBRA,IKET,0,ICHARG)
C
                BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *          +23040*LAM6_P*DEN5PP(IBRA,IKET,1,ICHARG)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C          INSERTING THE EXACT COULOMB MATRIX ELEMENTS, WHICH ARE
C          SUPPOSED TO BE ALREADY CALCULATED BEFORE
C=======================================================================
C
      IF (ICHARG.EQ.1.AND.(ICOUDI.EQ.2.OR.ICOUEX.EQ.2)) THEN
C
          IF (INDCOE.EQ.1.OR.INDCOE.EQ.13.OR.INDCOE.EQ.9) THEN
C
              DO IKET=1,LDBATW(IND2HR(LTWCEN))
                 DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
                    MPY=NYVECT(IBRA,IND2HL(LTWCEN))
                    NPY=NYVECT(IKET,IND2HR(LTWCEN))
C
                    DO KARTEZ=0,NDKART
C
                       BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                                +COULSV(IBRA,IKET,KARTEZ,LTWCEN)
     *                                *IPHAPP(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
                       BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                                +COULSV(IBRA,IKET,KARTEZ,LTWCEN)
     *                                *IPHAMM(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
C
                    END DO
                 END DO
              END DO
C
              IF (ISIMPY.NE.1) THEN
C
                  DO IKET=1,LDBATW(IND2HR(LTWCEN))
                     DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
                        MPY=NYVECT(IBRA,IND2HL(LTWCEN))
                        NPY=NYVECT(IKET,IND2HR(LTWCEN))
C
                        DO KARTEZ=0,NDKART
C
                           BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                                  +COULSV(IBRA,IKET,KARTEZ,LTWCEN)
     *                                    *IPHAPM(MPY,NPY,KARTEZ)
     *                                    *PHACOM(KARTEZ)
                           BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                                  +COULSV(IBRA,IKET,KARTEZ,LTWCEN)
     *                                    *IPHAMP(MPY,NPY,KARTEZ)
     *                                    *PHACOM(KARTEZ)
C
                        END DO
                     END DO
                  END DO
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE YUKAWA MATRIX ELEMENTS, WHICH ARE SUPPOSED
C          TO BE ALREADY CALCULATED BEFORE
C=======================================================================
C
      IF (I_YUKA.GE.2) THEN
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                                +YUKASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *IPHAPP(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                                +YUKASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *IPHAMM(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
C
                END DO
             END DO
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                     BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                                  +YUKASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *IPHAPM(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
                     BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                                  +YUKASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *IPHAMP(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE GOGNY MATRIX ELEMENTS, WHICH ARE SUPPOSED
C          TO BE ALREADY CALCULATED BEFORE
C=======================================================================
C
      IF (I_GOGA.GE.2.AND.NEWGOG.EQ.0) THEN
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                                +GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *IPHAPP(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                                +GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *IPHAMM(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                     BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                                  +GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *IPHAPM(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
                     BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                                  +GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *IPHAMP(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE  REGULARIZED  SKYRME  OR  GOGNY  (FOR NEWGOG=1)
C          MATRIX ELEMENTS, WHICH ARE SUPPOSED TO BE ALREADY  CALCULATED
C          BEFORE.
C=======================================================================
C
      IF (I_REGA.GE.2.OR.(I_GOGA.GE.2.AND.NEWGOG.EQ.1)) THEN
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                                +REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *IPHAPP(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                                +REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *IPHAMM(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                     BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                                  +REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *IPHAPM(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
                     BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                                  +REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *IPHAMP(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE SEPARABLE MATRIX ELEMENTS, WHICH ARE
C          SUPPOSED TO BE ALREADY CALCULATED BEFORE
C=======================================================================
C
      IF (I_SEPA.GE.2) THEN
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                                +SEPASV(IBRA,IKET,KARTEZ,ITPNMX)
     *                                *IPHAPP(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                                +SEPASV(IBRA,IKET,KARTEZ,ITPNMX)
     *                                *IPHAMM(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                     BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                                  +SEPASV(IBRA,IKET,KARTEZ,ITPNMX)
     *                                  *IPHAPM(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
                     BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                                  +SEPASV(IBRA,IKET,KARTEZ,ITPNMX)
     *                                  *IPHAMP(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE FINITE-RANGE SPIN-ORBIT/TENSOR MATRIX ELEMENTS,
C          WHICH ARE SUPPOSED TO BE ALREADY CALCULATED BEFORE.
C=======================================================================
C
      IF (MAXVAL(I_FSTA).GE.2) THEN
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                                +FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *IPHAPP(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                                +FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *IPHAMM(MPY,NPY,KARTEZ)
     *                                *PHACOM(KARTEZ)
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                     BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                                  +FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *IPHAPM(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
                     BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                                  +FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *IPHAMP(MPY,NPY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE LINEAR-MOMENTUM-SQUARED EXCHANGE MATRIX ELMNTS,
C          WHICH ARE SUPPOSED TO BE ALREADY CALCULATED BEFORE
C=======================================================================
C
      IF (JETACM.EQ.2) THEN
C
          DO K=1,NDKART
C
             DO IKET=1,LDBASE
                DO IBRA=1,LDBASE
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)+HBMREN(K)*
     *                                 ALINPP(IBRA,IKET,K,0,ICHARG)
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)+HBMREN(K)*
     *                                 ALINPP(IBRA,IKET,K,1,ICHARG)
C
                END DO
             END DO
C
             IF (ISIMPY.NE.1) THEN
C
                 DO IKET=1,LDBASE
                    DO IBRA=1,LDBASE
C
                   BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)+HBMREN(K)*
     *                                 ALINPM(IBRA,IKET,K,0,ICHARG)
                   BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)+HBMREN(K)*
     *                                 ALINPM(IBRA,IKET,K,1,ICHARG)
C
                    END DO
                 END DO
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C          INSERTING THE ANGULAR-MOMENTUM-SQUARED EXCHANGE MATRIX
C          ELEMENTS, WHICH ARE SUPPOSED TO BE ALREADY CALCULATED BEFORE
C=======================================================================
C
      IF (KETA_R.EQ.2) THEN
C
          DO K=1,NDKART
C
             DO IKET=1,LDBASE
                DO IBRA=1,LDBASE
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)+ROTREN(K)*
     *                                 AROTPP(IBRA,IKET,K,0,ICHARG)
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)+ROTREN(K)*
     *                                 AROTPP(IBRA,IKET,K,1,ICHARG)
C
                END DO
             END DO
C
             IF (ISIMPY.NE.1) THEN
C
                 DO IKET=1,LDBASE
                    DO IBRA=1,LDBASE
C
                   BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)+ROTREN(K)*
     *                                 AROTPM(IBRA,IKET,K,0,ICHARG)
                   BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)+ROTREN(K)*
     *                                 AROTPM(IBRA,IKET,K,1,ICHARG)
C
                    END DO
                 END DO
C
             END IF
C
          END DO
C
      END IF
C=======================================================================
C
      END IF ! END OF ITPNMX.LE.1 (NOT INDENTED)
C
C=======================================================================
C         AXIALIZATION OF THE MEAN FIELDS
C=======================================================================
C
      IF (IABS(IAXIAP).EQ.1) CALL CYLDEN(NOSCIL,IF_THO)
C
C=======================================================================
      DEALLOCATE (HAUXPP,HAUXPM,HCOMPP,HCOMPM)
C=======================================================================
C
      CALL CPUTIM('INTEGH',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PNMCOP(IPNMIX,ITPNMX,ISIMPY)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE PNMXPP
      USE PNMXPM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(PNM_PP).AND.IPNMIX.EQ.1) THEN
          ALLOCATE (PNM_PP(1:2*NDBASE,1:2*NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PNM_PP','PNMCOP')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(PNM_PM).AND.IPNMIX.EQ.1.AND.ISIMPY.NE.1) THEN
          ALLOCATE (PNM_PM(1:2*NDBASE,1:2*NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PNM_PM','PNMCOP')
      END IF
C=======================================================================
C
C=======================================================================
C          THIS SUBROUTINE COPIES THE CALCULATED MATRIX ELEMENTS OF THE
C          MEAN-FIELD INTO THE PROTON-NEUTRON MIXING HAMILTONIAN
C=======================================================================
C
      IF (ITPNMX.EQ.0) THEN
C
          MBRA=0
          MKET=0
C
      END IF
C
      IF (ITPNMX.EQ.1) THEN
C
          MBRA=LDBASE
          MKET=LDBASE
C
      END IF
C
      IF (ITPNMX.EQ.2) THEN
C
          MBRA=0
          MKET=LDBASE
C
      END IF
C
      IF (ITPNMX.LT.0.OR.ITPNMX.GT.2)
     *                   STOP ' UNALLOWED VALUE OF ITPNMX IN PNMCOP'
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            PNM_PP(MBRA+IBRA,MKET+IKET,0)=BIG_PP(IBRA,IKET,0)
            PNM_PP(MBRA+IBRA,MKET+IKET,1)=BIG_PP(IBRA,IKET,1)
C
         END DO
      END DO
C
      IF (ISIMPY.NE.1) THEN
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                PNM_PM(MBRA+IBRA,MKET+IKET,0)=BIG_PM(IBRA,IKET,0)
                PNM_PM(MBRA+IBRA,MKET+IKET,1)=BIG_PM(IBRA,IKET,1)
C
             END DO
          END DO
C
      END IF
C
      IF (ITPNMX.EQ.2) THEN
C
          MBRA=LDBASE
          MKET=0
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                PNM_PP(MBRA+IBRA,MKET+IKET,0)=CONJG(BIG_PP(IKET,IBRA,0))
                PNM_PP(MBRA+IBRA,MKET+IKET,1)=CONJG(BIG_PP(IKET,IBRA,1))
C
             END DO
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.50J) AND (3.18E),  THE  INDICES
C                    "IREVER" (THE THIRD INDICES) OF "BIG_PM" BELOW WERE
C                    ERRONOUSLY EXCHANGED. THIS BUG  WAS  AFFECTING  THE
C                    PROTON-NEUTRON-MIXING  CALCULATIONS  PERFORMED  FOR
C                    THE BROKEN SIMPLEX SYMMETRY. THIS BUG WAS FOUND  BY
C                    ADRIAN SANCHEZ AND CORRECTED IN VERSION (3.18F)  ON
C                    31/03/2023.
C=======================================================================
C
              DO IKET=1,LDBASE
                 DO IBRA=1,LDBASE
C
                PNM_PM(MBRA+IBRA,MKET+IKET,0)=CONJG(BIG_PM(IKET,IBRA,1))
                PNM_PM(MBRA+IBRA,MKET+IKET,1)=CONJG(BIG_PM(IKET,IBRA,0))
C
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTEGD(ITPNMX,ISIMPY,ICHARG,
     *                  DELFIN,DELFIP,IDEFIN,IDEFIP,
     *                                JETACM,KETA_R,
     *                  IGOGPA,IREGPA,ISEPPA,ICOUPA,
     *                                NEWGOG,NEWCOU,
     *                         LTWCEN,ITWCEN,INDCOE)
C=======================================================================
      USE GOGKAP
      USE PAIDEL
      USE PLISTO
      USE PROSTO
      USE RPASTO
      USE CPASTO
      USE SPASTO
      USE FPASTO
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDFSTA=3)
C=======================================================================C
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          PHACOM
      COMPLEX
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX),
     *          VONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX,1:NDKART)
      COMPLEX
     *          HCOMPP,HCOMPM
C
C=======================================================================
      ALLOCATABLE HCOMPP(:,:)
      ALLOCATABLE HCOMPM(:,:)
C=======================================================================
      COMMON
     *       /B_PHAS/ JPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /HERSTO/ HERMTS(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /RENORM/ HBMREN(NDKART)
      COMMON
     *       /RENROT/ ROTREN(NDKART)
      COMMON
     *       /AXILIZ/ NOSCIL,IF_THO,IAXIAP
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('INTEGD',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(HAMIDE)) THEN
          ALLOCATE (HAMIDE(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HAMIDE','INTEGD')
      END IF
C
      IF (.NOT.ALLOCATED(HAM2DE)) THEN
          ALLOCATE (HAM2DE(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HAM2DE','INTEGD')
      END IF
C=======================================================================
      ALLOCATE (HCOMPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HCOMPP','INTEGD')
      ALLOCATE (HCOMPM(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HCOMPM','INTEGD')
C=======================================================================
C
C=======================================================================
C     THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF THE PAIRING FIELDS
C=======================================================================
C
      ZERO=0.0D0
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C     ZEROING ARRAYS WHEN A NEW TWO-CENTER BLOCK STARTS (PAIRING FORCE)
C=======================================================================
C
      IF (INDCOE.EQ.1.OR.INDCOE.EQ.13.OR.INDCOE.EQ.9.OR.INDCOE.EQ.5)
     * THEN
C
          HAMIDE(:,:,:)=C_ZERO
          HAM2DE(:,:,:)=C_ZERO
C
      END IF
C
C=======================================================================
C         PREPARE THE INPUT DATA
C=======================================================================
C
      IF (ITPNMX.EQ.0) THEN
C
          DELFIX=DELFIN
          IDEFIX=IDEFIN
C
      END IF
C
      IF (ITPNMX.EQ.1) THEN
C
          DELFIX=DELFIP
          IDEFIX=IDEFIP
C
      END IF
C
      IF (ITPNMX.NE.0.AND.ITPNMX.NE.1)
     *                      STOP ' UNALLOWED VALUES OF ITPNMX IN INTEGD'
C
C
C=======================================================================
C     CASE OF FIXED DELTA
C=======================================================================
C
      IF (IDEFIX.EQ.1) THEN
C
          DO IKET=1,LDBATW(IND2HR(LTWCEN))
             DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
                HAMIDE(IBRA,IKET,0)=C_ZERO
                HAMIDE(IBRA,IKET,1)=C_ZERO
C
             END DO
C
                HAMIDE(IKET,IKET,0)=CMPLX(+DELFIX,ZERO)
C
          END DO
C
      ELSE
C
C=======================================================================
C     CASE OF THE DENSITY-DEPENDENT DELTA PAIRING AND/OR SKYRME PAIRING
C=======================================================================
C
C          HAMIDE(:,:,:)=C_ZERO
C
          NDEGRE=0
C
          CALL BEGINC(WD_CEN(1,1,1,ITPNMX,INDCOE),SONBAS,NDEGRE,
     *                              HERMTS,FOURWG,INDCOE,ITWCEN)
C
          KARTEZ=0
C
          CALL INTCEN(SONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,ITWCEN,INDCOE)
C
C=======================================================================
C          THE SIGNS BELOW STEM FROM THE FACTS THAT (SEE  NOTES  7-41E):
C          1. THE "MP" BLOCK OF THE PAIRING FIELD IS PUT INTO THE  ARRAY
C             "HAMIDE" FOR IREVER=0. THE BLOCK IS CALCULATED IN COMPLETE
C             ANALOGY TO THE "PP" BLOCK  OF  THE  MEAN  FIELD,  BUT  HAS
C             DIFFERENT SIGNS OF DIFFERENT TERMS CORRESPONDING TO  PAULI
C             MATRICES AND IDENTITY. SEE DERVATION IN NOTES 9-100A.
C          2. THE "PP" BLOCK OF THE PAIRING FIELD IS PUT INTO THE  ARRAY
C             "HAMIDE" FOR IREVER=1. THE BLOCK IS CALCULATED IN COMPLETE
C             ANALOGY TO THE "PM" BLOCK  OF  THE  MEAN  FIELD,  BUT  HAS
C             DIFFERENT SIGNS OF DIFFERENT TERMS CORRESPONDING TO  PAULI
C             MATRICES AND IDENTITY. SEE DERVATION IN NOTES 9-100A.
C          IT MEANS THAT THE HFB EQUATION SPLIT INTO THE SIMPLEX  BLOCKS
C          DIFFERS BY SIGNS OF THE PAIRING FIELD FROM  THAT  WRITTEN  IN
C          THE RUSSION CONVENTION. CONSEQUENTLY, THE FIXED  PAIRING  GAP
C          WITH THE PLUS SIGN IS USED ABOVE FOR IDEFIX=1.
C=======================================================================
C          ATTENTION: SIGNS "+1" HAVE BEEN IMPLEMENTED IN THE CODE UP TO
C                     THE VERSION (2.16N).  AT THE SAME TIME,  INCORRECT
C                     SIGNS HAVE BEEN CODED FOR THE SECOND COMPONENTS OF
C                     THE HFB WAVE FUNCTIONS (SEE COMMENTS IN "DENSHF"),
C                     AND HENCE ALL RESULTS WERE CORRECT. THIS  BUG  WAS
C                     CORRECTED ON 07/04/05 IN VERSION (2.17).
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.71O AND 3.00, SIGNS OF  THE  P-P
C                    TERMS CORRESPONDING TO PAULI MATRICES AND  IDENTITY
C                    WERE COPIED  FROM  THOSE  PROGRAMMED  FOR  THE  P-H
C                    TERMS, WHICH WAS INCORRECT. BASED ON DERIVATION  IN
C                    NOTES 9-100A, THIS BUG WAS CORRECTED ON  16/10/2020
C                    IN VERSION 3.00F.
C=======================================================================
C
          HAMIDE(1:NDBASE,1:NDBASE,0)=HAMIDE(1:NDBASE,1:NDBASE,0)
     *                               -HCOMPP(1:NDBASE,1:NDBASE)
          HAMIDE(1:NDBASE,1:NDBASE,1)=HAMIDE(1:NDBASE,1:NDBASE,1)
     *                               -HCOMPM(1:NDBASE,1:NDBASE)
C
C=======================================================================
C          CALCULATING KINETIC TERM MATRIX ELEMENTS
C=======================================================================
C
          NDEGRE=2
C
          CALL BEGINC(WD_TAU(1,1,1,ITPNMX,INDCOE),SONBAS,NDEGRE,
     *                              HERMTS,FOURWG,INDCOE,ITWCEN)
C
          KARTEZ=0
C
          CALL INTMAS(SONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,ITWCEN,INDCOE)
C
          HAMIDE(1:NDBASE,1:NDBASE,0)= HAMIDE(1:NDBASE,1:NDBASE,0)
     *                                -HCOMPP(1:NDBASE,1:NDBASE)
          HAMIDE(1:NDBASE,1:NDBASE,1)= HAMIDE(1:NDBASE,1:NDBASE,1)
     *                                -HCOMPM(1:NDBASE,1:NDBASE)
C
C=======================================================================
C          CALCULATING  SPIN-ORBIT TERM MATRIX ELEMENTS
C=======================================================================
C
          NDEGRE=1
C
          DO K=1,NDKART
C
             DO L=1,NDKART
C
               CALL BEGINC(WD_SOR(1,1,1,L,K,ITPNMX,INDCOE),
     *                              VONBAS(0,0,0,L),NDEGRE,
     *                         HERMTS,FOURWG,INDCOE,ITWCEN)
C
             END DO
C
             KARTEZ=K
C
             CALL INTSOR(VONBAS,KARTEZ,ISIMPY,HCOMPP,HCOMPM,
     *                                        ITWCEN,INDCOE)
C
             IF (K.EQ.1) THEN
C
                 HAMIDE(1:NDBASE,1:NDBASE,0)
     *          =HAMIDE(1:NDBASE,1:NDBASE,0)
     *   -UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
C
                 HAMIDE(1:NDBASE,1:NDBASE,1)
     *          =HAMIDE(1:NDBASE,1:NDBASE,1)
     *   +UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
C
             END IF
C
             IF (K.EQ.2) THEN
C
                 HAMIDE(1:NDBASE,1:NDBASE,0)
     *          =HAMIDE(1:NDBASE,1:NDBASE,0)
     *   -UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
C
                 HAMIDE(1:NDBASE,1:NDBASE,1)
     *          =HAMIDE(1:NDBASE,1:NDBASE,1)
     *   -UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
C
             END IF
C
             IF (K.EQ.3) THEN
C
                 HAMIDE(1:NDBASE,1:NDBASE,0)
     *          =HAMIDE(1:NDBASE,1:NDBASE,0)
     *   -UNIT_I*HCOMPP(1:NDBASE,1:NDBASE)
     *          *(-UNIT_I)
C
                 HAMIDE(1:NDBASE,1:NDBASE,1)
     *          =HAMIDE(1:NDBASE,1:NDBASE,1)
     *   +UNIT_I*HCOMPM(1:NDBASE,1:NDBASE)
     *          *(-UNIT_I)
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C          ARRAY "HAM2DE" BELOW IS FILLED ACCORDING  TO CONVENTION:
C          1. THE "PM" BLOCK OF THE PAIRING FIELD IS PUT  INTO  THE
C             ARRAY "HAM2DE" FOR IREVER=0  AFTER  BEING  MULTIPLIED
C             BY THE FACTOR OF "-1".
C          2. THE "MM" BLOCK OF THE PAIRING FIELD IS PUT  INTO  THE
C             ARRAY "HAM2DE" FOR IREVER=1.
C          IN OTHER WORDS, THE  MATRIX OF  THE PAIRING FIELD IN THE
C          T-BASIS IS AS FOLLOWS:
C
C                               |t+>         |t->
C                    <t+|  | +HAMIDE(1)  -HAM2DE(0) |
C                          |                        |
C                    <t-|  | +HAMIDE(0)  +HAM2DE(1) |
C
C          THE ARRAY "HAM2DE" IS  ONLY USED WHEN SIMPLEX IS BROKEN,
C          I.E., IN ROUTINES  "HFBSIQ" AND "HFBSIZ",  AND  ONLY  IN
C          CASES SPECIFIED IN THE LOGICAL  VARIABLE  "REA2PP".  FOR
C          ZERO-RANGE PAIRING FORCES, "HAM2DE" IS COPIED FROM ARRAY
C          "HAMIDE".
C=======================================================================
C
      HAM2DE(1:NDBASE,1:NDBASE,0)=HAMIDE(1:NDBASE,1:NDBASE,0)
      HAM2DE(1:NDBASE,1:NDBASE,1)=HAMIDE(1:NDBASE,1:NDBASE,1)
C
C=======================================================================
C          INSERTING THE MATRIX ELEMENTS CORRESPONDING TO THE PAIRING
C          TERM OF <P^2>, WHICH ARE SUPPOSED TO BE ALREADY CALCULATED
C          BEFORE
C=======================================================================
C
      IF (JETACM.EQ.2) THEN
C
          IF (.NOT.ALLOCATED(PLINPM))
     *        STOP 'PLINPM NOT ALLOCATED IN INTEGD'
C
          IF (.NOT.ALLOCATED(PLINPP).AND.ISIMPY.NE.1)
     *        STOP 'PLINPP NOT ALLOCATED IN INTEGD'
C
          DO K=1,NDKART
C
             DO IKET=1,LDBASE
                DO IBRA=1,LDBASE
C
                   HAMIDE(IBRA,IKET,0)=HAMIDE(IBRA,IKET,0)+HBMREN(K)
     *                                *PLINPM(IBRA,IKET,K,1,ICHARG)
                   HAM2DE(IBRA,IKET,0)=HAM2DE(IBRA,IKET,0)-HBMREN(K)
     *                                *PLINPM(IBRA,IKET,K,0,ICHARG)
C
                   IF (ISIMPY.NE.1) THEN
C
                       HAMIDE(IBRA,IKET,1)=HAMIDE(IBRA,IKET,1)+HBMREN(K)
     *                                    *PLINPP(IBRA,IKET,K,0,ICHARG)
                       HAM2DE(IBRA,IKET,1)=HAM2DE(IBRA,IKET,1)+HBMREN(K)
     *                                    *PLINPP(IBRA,IKET,K,1,ICHARG)
C
                   END IF
C
                END DO
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C          INSERTING THE MATRIX ELEMENTS CORRESPONDING TO THE PAIRING
C          TERM OF <J^2>, WHICH ARE SUPPOSED TO BE ALREADY CALCULATED
C          BEFORE
C=======================================================================
C
      IF (KETA_R.EQ.2) THEN
C
          IF (.NOT.ALLOCATED(PROTPM))
     *        STOP 'PROTPM NOT ALLOCATED IN INTEGD'
C
          IF (.NOT.ALLOCATED(PROTPP).AND.ISIMPY.NE.1)
     *        STOP 'PROTPP NOT ALLOCATED IN INTEGD'
C
         DO K=1,NDKART
C
             DO IKET=1,LDBASE
                DO IBRA=1,LDBASE
C
                   HAMIDE(IBRA,IKET,0)=HAMIDE(IBRA,IKET,0)+ROTREN(K)
     *                                *PROTPM(IBRA,IKET,K,1,ICHARG)
                   HAM2DE(IBRA,IKET,0)=HAM2DE(IBRA,IKET,0)-ROTREN(K)
     *                                *PROTPM(IBRA,IKET,K,0,ICHARG)
C
                   IF (ISIMPY.NE.1) THEN
C
                       HAMIDE(IBRA,IKET,1)=HAMIDE(IBRA,IKET,1)+ROTREN(K)
     *                                    *PROTPP(IBRA,IKET,K,0,ICHARG)
                       HAM2DE(IBRA,IKET,1)=HAM2DE(IBRA,IKET,1)+ROTREN(K)
     *                                    *PROTPP(IBRA,IKET,K,1,ICHARG)
C
                   END IF
C
                END DO
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C          INSERTING THE GOGNY MATRIX ELEMENTS, WHICH ARE SUPPOSED
C          TO BE ALREADY CALCULATED BEFORE
C=======================================================================
C
      IF (IGOGPA.EQ.2.AND.NEWGOG.EQ.0) THEN
          IF (.NOT.ALLOCATED(GOGCHI))
     *        STOP 'GOGCHI NOT ALLOCATED IN INTEGD'
C
          DO KARTEZ=0,NDKART
             HAMIDE(:,:,0)=HAMIDE(:,:,0)+GOGCHI(:,:,KARTEZ,ICHARG)
          END DO
      END IF
C
C=======================================================================
C          INSERTING THE MATRIX ELEMENTS CORRESPONDING TO THE
C          REGULARIZED FINITE-RANGE PAIRING  TERM,  WHICH ARE
C          SUPPOSED TO BE ALREADY CALCULATED BEFORE.
C=======================================================================
C          THE COMPLEX CONJUGATION OF THE PHASE FACTOR  BELOW
C          REPRESENTS THE COMPLEX  CONJUGATION  OF  THE  LEFT
C          (BRA) PAULI MATRICES IN THE THE  PARTICLE-PARTICLE
C          REPRESENTATION, SEE NOTES 90-B AND 90-G.
C=======================================================================
C
      IF ((IREGPA.EQ.2.AND.NEWGOG.EQ.0).OR.
     *    (IGOGPA.EQ.2.AND.NEWGOG.EQ.1)) THEN
C
          IF (.NOT.ALLOCATED(REGPSV))
     *        STOP 'REGPSV NOT ALLOCATED IN INTEGD'
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   HAMIDE(IBRA,IKET,0)=HAMIDE(IBRA,IKET,0)
     *                                +REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *JPHAMP(MPY,NPY,KARTEZ)
     *                                *CONJG(PHACOM(KARTEZ))
                   HAM2DE(IBRA,IKET,0)=HAM2DE(IBRA,IKET,0)
     *                                -REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *JPHAPM(MPY,NPY,KARTEZ)
     *                                *CONJG(PHACOM(KARTEZ))
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                     HAMIDE(IBRA,IKET,1)=HAMIDE(IBRA,IKET,1)
     *                                  +REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *JPHAPP(MPY,NPY,KARTEZ)
     *                                  *CONJG(PHACOM(KARTEZ))
                     HAM2DE(IBRA,IKET,1)=HAM2DE(IBRA,IKET,1)
     *                                  +REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *JPHAMM(MPY,NPY,KARTEZ)
     *                                  *CONJG(PHACOM(KARTEZ))
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE MATRIX ELEMENTS CORRESPONDING TO THE
C          COULOMB PAIRING TERM, WHICH  ARE  SUPPOSED  TO  BE
C          ALREADY CALCULATED BEFORE.
C=======================================================================
C          THE COMPLEX CONJUGATION OF THE PHASE FACTOR  BELOW
C          REPRESENTS THE COMPLEX  CONJUGATION  OF  THE  LEFT
C          (BRA) PAULI MATRICES IN THE THE  PARTICLE-PARTICLE
C          REPRESENTATION, SEE NOTES 90-B AND 90-G.
C=======================================================================
C
      IF (ICOUPA.EQ.2.AND.ICHARG.EQ.1) THEN
C
          IF (NEWCOU.NE.1) STOP 'ICOUPA.EQ.2 AND NEWCOU.NE.1 IN INTEGD'
C
          IF (.NOT.ALLOCATED(COUPSV))
     *        STOP 'COUPSV NOT ALLOCATED IN INTEGD'
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   HAMIDE(IBRA,IKET,0)=HAMIDE(IBRA,IKET,0)
     *                                +COUPSV(IBRA,IKET,KARTEZ)
     *                                *JPHAMP(MPY,NPY,KARTEZ)
     *                                *CONJG(PHACOM(KARTEZ))
                   HAM2DE(IBRA,IKET,0)=HAM2DE(IBRA,IKET,0)
     *                                -COUPSV(IBRA,IKET,KARTEZ)
     *                                *JPHAPM(MPY,NPY,KARTEZ)
     *                                *CONJG(PHACOM(KARTEZ))
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                       HAMIDE(IBRA,IKET,1)=HAMIDE(IBRA,IKET,1)
     *                                    +COUPSV(IBRA,IKET,KARTEZ)
     *                                    *JPHAPP(MPY,NPY,KARTEZ)
     *                                    *CONJG(PHACOM(KARTEZ))
                       HAM2DE(IBRA,IKET,1)=HAM2DE(IBRA,IKET,1)
     *                                    +COUPSV(IBRA,IKET,KARTEZ)
     *                                    *JPHAMM(MPY,NPY,KARTEZ)
     *                                    *CONJG(PHACOM(KARTEZ))
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE MATRIX ELEMENTS CORRESPONDING TO THE
C          SEPARABLE FINITE-RANGE PAIRING  TERM,  WHICH ARE
C          SUPPOSED TO BE ALREADY CALCULATED BEFORE.
C=======================================================================
C          THE COMPLEX CONJUGATION OF THE PHASE FACTOR  BELOW
C          REPRESENTS THE COMPLEX  CONJUGATION  OF  THE  LEFT
C          (BRA) PAULI MATRICES IN THE THE  PARTICLE-PARTICLE
C          REPRESENTATION, SEE NOTES 90-B AND 90-G.
C=======================================================================
C
      IF (ISEPPA.EQ.2) THEN
C
          IF (.NOT.ALLOCATED(SEPPSV))
     *        STOP 'SEPPSV NOT ALLOCATED IN INTEGD'
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   HAMIDE(IBRA,IKET,0)=HAMIDE(IBRA,IKET,0)
     *                                +SEPPSV(IBRA,IKET,KARTEZ,ITPNMX)
     *                                *JPHAMP(MPY,NPY,KARTEZ)
     *                                *CONJG(PHACOM(KARTEZ))
                   HAM2DE(IBRA,IKET,0)=HAM2DE(IBRA,IKET,0)
     *                                -SEPPSV(IBRA,IKET,KARTEZ,ITPNMX)
     *                                *JPHAPM(MPY,NPY,KARTEZ)
     *                                *CONJG(PHACOM(KARTEZ))
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                     HAMIDE(IBRA,IKET,1)=HAMIDE(IBRA,IKET,1)
     *                                  +SEPPSV(IBRA,IKET,KARTEZ,ITPNMX)
     *                                  *JPHAPP(MPY,NPY,KARTEZ)
     *                                  *CONJG(PHACOM(KARTEZ))
                     HAM2DE(IBRA,IKET,1)=HAM2DE(IBRA,IKET,1)
     *                                  +SEPPSV(IBRA,IKET,KARTEZ,ITPNMX)
     *                                  *JPHAMM(MPY,NPY,KARTEZ)
     *                                  *CONJG(PHACOM(KARTEZ))
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C          INSERTING THE MATRIX ELEMENTS CORRESPONDING TO THE
C          FINITE-RANGE SPIN-ORBIT/TENSOR PAIRING TERM, WHICH
C          ARE SUPPOSED TO BE ALREADY CALCULATED BEFORE.
C=======================================================================
C          THE COMPLEX CONJUGATION OF THE PHASE FACTOR  BELOW
C          REPRESENTS THE COMPLEX  CONJUGATION  OF  THE  LEFT
C          (BRA) PAULI MATRICES IN THE THE  PARTICLE-PARTICLE
C          REPRESENTATION, SEE NOTES 90-B AND 90-G.
C=======================================================================
C
      IF (MAXVAL(IFSTPA).EQ.2) THEN
C
          IF (.NOT.ALLOCATED(FSTPSV))
     *        STOP 'FSTPSV NOT ALLOCATED IN INTEGD'
C
          DO KARTEZ=0,NDKART
C
             DO IKET=1,LDBASE
                NPY=NYVECT(IKET,1)
                DO IBRA=1,LDBASE
                   MPY=NYVECT(IBRA,1)
C
                   HAMIDE(IBRA,IKET,0)=HAMIDE(IBRA,IKET,0)
     *                                +FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *JPHAMP(MPY,NPY,KARTEZ)
     *                                *CONJG(PHACOM(KARTEZ))
                   HAM2DE(IBRA,IKET,0)=HAM2DE(IBRA,IKET,0)
     *                                -FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                *JPHAPM(MPY,NPY,KARTEZ)
     *                                *CONJG(PHACOM(KARTEZ))
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              DO KARTEZ=0,NDKART
C
                 DO IKET=1,LDBASE
                    NPY=NYVECT(IKET,1)
                    DO IBRA=1,LDBASE
                       MPY=NYVECT(IBRA,1)
C
                     HAMIDE(IBRA,IKET,1)=HAMIDE(IBRA,IKET,1)
     *                                  +FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *JPHAPP(MPY,NPY,KARTEZ)
     *                                  *CONJG(PHACOM(KARTEZ))
                     HAM2DE(IBRA,IKET,1)=HAM2DE(IBRA,IKET,1)
     *                                  +FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                  *JPHAMM(MPY,NPY,KARTEZ)
     *                                  *CONJG(PHACOM(KARTEZ))
C
                    END DO
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
      DEALLOCATE (HCOMPP,HCOMPM)
C=======================================================================
C
C=======================================================================
C         AXIALIZATION OF THE PAIRING FIELDS
C=======================================================================
C
      IPAIAX = 1
      IF (IABS(IAXIAP).EQ.1) CALL CYLPAI(NOSCIL,IF_THO,IPAIAX)
C
C=======================================================================
C
      CALL CPUTIM('INTEGD',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTEGG(FLDMAS,FLDCEN,FLDKIS,FLDSPI,FLDCUR,FLDSOR,
     *                  IMOVAX,ITILAX,ITISAX,IROTAT,ICHARG,ISIMPY,
     *                                       IOCONT,NMUCON,NSICON)
C=======================================================================
      USE HCOULO
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          TIMEPP,TIMEMM,TIMEPM,TIMEMP
      COMPLEX
     *          C_ZERO
C=======================================================================
      ALLOCATABLE HAUXPP(:,:)
      ALLOCATABLE HAUXPM(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('INTEGG',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPP','INTEGG')
      ALLOCATE (HAUXPM(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPM','INTEGG')
C=======================================================================
      IF (.NOT.ALLOCATED(BIG_PP)) THEN
          ALLOCATE (BIG_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PP','INTEGG')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(BIG_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (BIG_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PM','INTEGG')
      END IF
C=======================================================================
C
C=======================================================================
C          THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF THE  MEAN-FIELD
C          GIVEN BY A GAUSSIAN INTERACTION
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C          FOR PARTS DIAGONAL IN THE SIMPLEX:
C
C          AT THE BEGINNING: TIME-EVEN   PART  IS PUT INTO BIG_PP(,,0)
C                            TIME-ODD    PART  IS PUT INTO BIG_PP(,,1)
C          AT THE END:
C                            TIME-(+,+)  BLOCK IS PUT INTO BIG_PP(,,0)
C                            TIME-(-,-)  BLOCK IS PUT INTO BIG_PP(,,1)
C=======================================================================
C          FOR PARTS NON-DIAGONAL IN THE SIMPLEX:
C
C          AT THE BEGINNING: TIME-EVEN   PART  IS PUT INTO BIG_PM(,,0)
C                            TIME-ODD    PART  IS PUT INTO BIG_PM(,,1)
C          AT THE END:
C                            TIME-(+,-)  BLOCK IS PUT INTO BIG_PM(,,0)
C                            TIME-(-,+)  BLOCK IS PUT INTO BIG_PM(,,1)
C=======================================================================
C
      BIG_PP(:,:,:)=C_ZERO
      IF (ISIMPY.NE.1) THEN
          BIG_PM(:,:,:)=C_ZERO
      END IF
C
C=======================================================================
C         COMBINING THE  TIME-EVEN  AND  TIME-ODD   PARTS
C              INTO THE  TIME-UP    AND  TIME-DOWN  PARTS
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            TIMEPP=       BIG_PP(IBRA,IKET,0) + BIG_PP(IBRA,IKET,1)
            TIMEMM= CONJG(BIG_PP(IBRA,IKET,0) - BIG_PP(IBRA,IKET,1))
C
            BIG_PP(IBRA,IKET,0) = TIMEPP
            BIG_PP(IBRA,IKET,1) = TIMEMM
C
         END DO
      END DO
C
      IF (ISIMPY.NE.1) THEN
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                TIMEPM=       BIG_PM(IBRA,IKET,0) + BIG_PM(IBRA,IKET,1)
                TIMEMP=-CONJG(BIG_PM(IBRA,IKET,0) - BIG_PM(IBRA,IKET,1))
C
                BIG_PM(IBRA,IKET,0) = TIMEPM
                BIG_PM(IBRA,IKET,1) = TIMEMP
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
      DEALLOCATE (HAUXPP,HAUXPM)
C=======================================================================
C
      CALL CPUTIM('INTEGG',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INIPAI(ITPNMX,IPNMIX,ITWCEN,LDTWCE)
C=======================================================================
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *        DENSIC, DENCHC
C
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
     *       /DATPAA/               EFERMA,DELTAA
      COMMON
     *       /DENTOT/ DENSIT(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHA(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /CENPOS/ CENCOR(1:NDKART,1:NDTWCE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C          THIS SUBROUTINE INITIALIZES THE PAIRING FIELD AND
C          THE TOTAL DENSITY (A PROPERLY INITIALIZED VERSION
C          OF THE LATTER IS NEEDED IN SUBROUTINE EPAIRI).
C=======================================================================
C         PREPARE THE INPUT DATA
C=======================================================================
C
      IF (ITPNMX.EQ.0.AND.IPNMIX.NE.1) THEN
          PDELTA=DELTAN
      END IF
C
      IF (ITPNMX.EQ.1.AND.IPNMIX.NE.1) THEN
          PDELTA=DELTAP
      END IF
C
      IF (IPNMIX.EQ.1) THEN
          PDELTA=DELTAA
      END IF
C
      IF (ITPNMX.NE.0.AND.ITPNMX.NE.1.AND.ITPNMX.NE.2)
     *                  STOP ' UNALLOWED VALUES OF ITPNMX IN INIPAI (1)'
      IF (IPNMIX.NE.1.AND.ITPNMX.EQ.2)
     *                  STOP ' UNALLOWED VALUES OF ITPNMX IN INIPAI (2)'
      IF (IPNMIX.EQ.1.AND.LDTWCE.NE.1)
     *                  STOP ' UNALLOWED VALUE OF LDTWCE IN INIPAI '
      IF (ITWCEN.EQ.1.AND.LDTWCE.NE.1)
     *                STOP ' LDTWCE INCOMPATIBLE WITH ITWCEN IN INIPAI '
C
C=======================================================================
C
      ZERO=0.0D0
C
      IF (ITWCEN.EQ.1) THEN
C
          WD_CEN(1:NXHERM,1:NYHERM,1:NZHERM,ITPNMX,1)=
     *    CMPLX(-PDELTA,ZERO)/EXPAUX(1:NXHERM,1:NYHERM,1:NZHERM,1)
C
          DENSIT(1:NXHERM,1:NYHERM,1:NZHERM,1)=
     *                -PDELTA*EXPAUX(1:NXHERM,1:NYHERM,1:NZHERM,1)
C
          DENSIC(1:NXHERM,1:NYHERM,1:NZHERM,1)=
     *            CMPLX(DENSIT(1:NXHERM,1:NYHERM,1:NZHERM,1),ZERO)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
C=======================================================================
C     HERE EXPAUX CAN BE REALLY SMALL AND CAUSE NUMERICAL PROBLEMS. TO
C     WARN THE USERS ABOUT THE ISSUE WE TELL THEM THE DISTANCE BETWEEN
C     CENTERS. USUALLY THE PROBLEM APPEARS FOR SEPARATIONS BIGGER THAN
C     50 FM.
C=======================================================================
C
         IF (ABS(CENCOR(1,ITWCEN)-CENCOR(1,1)).GT.50.OR.
     *       ABS(CENCOR(2,ITWCEN)-CENCOR(2,1)).GT.50.OR.
     *       ABS(CENCOR(3,ITWCEN)-CENCOR(3,1)).GT.50) THEN
                  WRITE(NFIPRI,'(
     *              '' ////////////////////////////////////////'',
     *              ''/////////////////////////////////////'',/,
     *              '' //// WARNING: VERY SMALL DENSITY IN'',
     *              '' INIPAI (NUMERICAL INSTABILITY AHEAD) ////'',/,
     *              '' ////////////////////////////////////////'',
     *              ''/////////////////////////////////////'')')


         END IF
C
          DO LTWCEN=1,LDTWCE
C
             WD_CEN(1:NXHERM,1:NYHERM,1:NZHERM,ITPNMX,LTWCEN)=
     *       CMPLX(-PDELTA,ZERO)/4
     *       /EXPAUX(1:NXHERM,1:NYHERM,1:NZHERM,LTWCEN)
C
             IF (LTWCEN.EQ.1) THEN
C
                 IEXP11=1
                 IEXP22=17
                 IEXP21=18
C
             ELSEIF (LTWCEN.EQ.2.OR.LTWCEN.EQ.3.OR.
     *               LTWCEN.EQ.5.OR.LTWCEN.EQ.9) THEN
C
                 IEXP11=5
                 IEXP22=19
                 IEXP21=3
C
             ELSEIF (LTWCEN.EQ.4 .OR.LTWCEN.EQ.6 .OR.
     *               LTWCEN.EQ.7 .OR.LTWCEN.EQ.10.OR.
     *               LTWCEN.EQ.11.OR.LTWCEN.EQ.13) THEN
C
                 IEXP11=13
                 IEXP22=4
                 IEXP21=7
C
             ELSEIF (LTWCEN.EQ.8 .OR.LTWCEN.EQ.12.OR.
     *               LTWCEN.EQ.14.OR.LTWCEN.EQ.15) THEN
C
                 IEXP11=20
                 IEXP22=8
                 IEXP21=15
C
             ELSEIF (LTWCEN.EQ.16) THEN
C
                 IEXP11=21
                 IEXP22=16
                 IEXP21=22
C
             END IF
C
             DENSIT(1:NXHERM,1:NYHERM,1:NZHERM,LTWCEN)=
     *       - PDELTA * (EXPAUX(1:NXHERM,1:NYHERM,1:NZHERM,IEXP11)
     *       +           EXPAUX(1:NXHERM,1:NYHERM,1:NZHERM,IEXP22)
     *       + 2.00D0 *  EXPAUX(1:NXHERM,1:NYHERM,1:NZHERM,IEXP21))
C
          END DO
C
          DENSIC(:,:,:,:)=CMPLX(DENSIT(:,:,:,:),ZERO)
C
      ELSE
C
          STOP 'WRONG ITWCEN IN INIPAI'
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTKIN(HAMKIN,HBMACT,LTWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          HAMKIN(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('INTKIN',1)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE KINETIC ENERGY MATRIX ELEMENTS
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            NXBRA=NXVECT(IBRA,IND2HL(LTWCEN))
            NYBRA=NYVECT(IBRA,IND2HL(LTWCEN))
            NZBRA=NZVECT(IBRA,IND2HL(LTWCEN))
C
            NXKET=NXVECT(IKET,IND2HR(LTWCEN))
            NYKET=NYVECT(IKET,IND2HR(LTWCEN))
            NZKET=NZVECT(IKET,IND2HR(LTWCEN))
C
            TTTZ=0.0D0
C
            IF (NXBRA.EQ.NXKET) THEN
C
                IF (NYBRA.EQ.NYKET) THEN
C
                    IF (NZBRA.EQ.NZKET) THEN
                        TTTZ=REAL(2*NZBRA+1)
                    END IF
C
                    IF (NZBRA.EQ.(NZKET+2)) THEN
                        TTTZ=-SQRT(REAL(NZBRA*(NZKET+1)))
                    END IF
C
                    IF (NZBRA.EQ.(NZKET-2)) THEN
                        TTTZ=-SQRT(REAL(NZKET*(NZBRA+1)))
                    END IF
C
                    TTTZ=TTTZ*HOMSCA(3,IND2HR(LTWCEN))**2
C
                END IF
C
            END IF
C
C=======================================================================
C
            TTTY=0.0D0
C
            IF (NXBRA.EQ.NXKET) THEN
C
                IF (NZBRA.EQ.NZKET) THEN
C
                    IF (NYBRA.EQ.NYKET) THEN
                        TTTY=REAL(2*NYBRA+1)
                    END IF
C
                    IF (NYBRA.EQ.(NYKET+2)) THEN
                        TTTY=-SQRT(REAL(NYBRA*(NYKET+1)))
                    END IF
C
                    IF (NYBRA.EQ.(NYKET-2)) THEN
                        TTTY=-SQRT(REAL(NYKET*(NYBRA+1)))
                    END IF
C
                    TTTY=TTTY*HOMSCA(2,IND2HR(LTWCEN))**2
C
                END IF
C
            END IF
C
C=======================================================================
C
            TTTX=0.0D0
C
            IF (NYBRA.EQ.NYKET) THEN
C
                IF (NZBRA.EQ.NZKET) THEN
C
                    IF (NXBRA.EQ.NXKET) THEN
                        TTTX=REAL(2*NXBRA+1)
                    END IF
C
                    IF (NXBRA.EQ.(NXKET+2)) THEN
                        TTTX=-SQRT(REAL(NXBRA*(NXKET+1)))
                    END IF
C
                    IF (NXBRA.EQ.(NXKET-2)) THEN
                        TTTX=-SQRT(REAL(NXKET*(NXBRA+1)))
                    END IF
C
                    TTTX=TTTX*HOMSCA(1,IND2HR(LTWCEN))**2
C
                END IF
C
            END IF
C
            HAMKIN(IBRA,IKET)=0.5D0*HBMACT*(TTTX+TTTY+TTTZ)
     *
     *                                    *IPHAPP(NYBRA,NYKET,0)
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTKIN',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NPLUSP(IN_FIX,IZ_FIX,IDOPLM,NRAORD,ITWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      COMPLEX
     *          C_ZERO
      COMPLEX
     *          QMUT_N,QMUT_P,QMUT_T
      COMPLEX
     *          AMUT_N,AMUT_P,AMUT_T
      COMPLEX
     *          WMUT_N,WMUT_P,WMUT_T
      COMPLEX
     *          TKINSQ
      COMPLEX
     *          DKINSN,DKINSP,DKINST,
     *          EKINSN,EKINSP,EKINST,
     *          PKINSN,PKINSP,PKINST,
     *          TKINSN,TKINSP,TKINST,
     *          AKINLN,AKINLP,AKINLT,
     *          PKINLN,PKINLP,PKINLT,
     *          PKINKN,PKINKP,PKINKT
C
      COMPLEX
     *          TKOTSQ
      COMPLEX
     *          DKOTSN,DKOTSP,DKOTST,
     *          EKOTSN,EKOTSP,EKOTST,
     *          PKOTSN,PKOTSP,PKOTST,
     *          TKOTSN,TKOTSP,TKOTST,
     *          AKOTLN,AKOTLP,AKOTLT,
     *          PKOTLN,PKOTLP,PKOTLT,
     *          PKOTKN,PKOTKP,PKOTKT
C
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /ANGSPI/ SPIN_N(1:NDKART),SPIN_P(1:NDKART),SPIN_T(1:NDKART)
      COMMON
     *       /QMUTTI/ QMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /PMULTI/ PMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                PMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                PMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VMULTI/ VMUL_N(0:NDMULT,-NDMULT:NDMULT,1:NDKART),
     *                VMUL_P(0:NDMULT,-NDMULT:NDMULT,1:NDKART),
     *                VMUL_T(0:NDMULT,-NDMULT:NDMULT,1:NDKART)
      COMMON
     *       /AMUTTI/ AMUT_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUT_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUT_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /AMULTI/ AMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /WMUTTI/ WMUT_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUT_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUT_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /WMULTI/ WMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                WMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /LINMOM/ DLINSN(0:NDKART),DLINSP(0:NDKART),DLINST(0:NDKART)
     *               ,ELINSN(0:NDKART),ELINSP(0:NDKART),ELINST(0:NDKART)
     *               ,TLINSN(0:NDKART),TLINSP(0:NDKART),TLINST(0:NDKART)
     *               ,ALINLN(0:NDKART),ALINLP(0:NDKART),ALINLT(0:NDKART)
      COMMON
     *       /KINMOM/ DKINSN(0:NDKART),DKINSP(0:NDKART),DKINST(0:NDKART)
     *               ,EKINSN(0:NDKART),EKINSP(0:NDKART),EKINST(0:NDKART)
     *               ,TKINSN(0:NDKART),TKINSP(0:NDKART),TKINST(0:NDKART)
     *               ,AKINLN(0:NDKART),AKINLP(0:NDKART),AKINLT(0:NDKART)
      COMMON
     *       /LINPAI/ PLINSN(0:NDKART),PLINSP(0:NDKART),PLINST(0:NDKART)
     *               ,PLINLN(0:NDKART),PLINLP(0:NDKART),PLINLT(0:NDKART)
     *               ,PLINKN(0:NDKART),PLINKP(0:NDKART),PLINKT(0:NDKART)
      COMMON
     *       /KINPAI/ PKINSN(0:NDKART),PKINSP(0:NDKART),PKINST(0:NDKART)
     *               ,PKINLN(0:NDKART),PKINLP(0:NDKART),PKINLT(0:NDKART)
     *               ,PKINKN(0:NDKART),PKINKP(0:NDKART),PKINKT(0:NDKART)
      COMMON
     *       /ROTMOM/ DROTSN(0:NDKART),DROTSP(0:NDKART),DROTST(0:NDKART)
     *               ,EROTSN(0:NDKART),EROTSP(0:NDKART),EROTST(0:NDKART)
     *               ,TROTSN(0:NDKART),TROTSP(0:NDKART),TROTST(0:NDKART)
     *               ,AROTLN(0:NDKART),AROTLP(0:NDKART),AROTLT(0:NDKART)
      COMMON
     *       /KOTMOM/ DKOTSN(0:NDKART),DKOTSP(0:NDKART),DKOTST(0:NDKART)
     *               ,EKOTSN(0:NDKART),EKOTSP(0:NDKART),EKOTST(0:NDKART)
     *               ,TKOTSN(0:NDKART),TKOTSP(0:NDKART),TKOTST(0:NDKART)
     *               ,AKOTLN(0:NDKART),AKOTLP(0:NDKART),AKOTLT(0:NDKART)
      COMMON
     *       /ROTPAI/ PROTSN(0:NDKART),PROTSP(0:NDKART),PROTST(0:NDKART)
     *               ,PROTLN(0:NDKART),PROTLP(0:NDKART),PROTLT(0:NDKART)
     *               ,PROTKN(0:NDKART),PROTKP(0:NDKART),PROTKT(0:NDKART)
      COMMON
     *       /KOTPAI/ PKOTSN(0:NDKART),PKOTSP(0:NDKART),PKOTST(0:NDKART)
     *               ,PKOTLN(0:NDKART),PKOTLP(0:NDKART),PKOTLT(0:NDKART)
     *               ,PKOTKN(0:NDKART),PKOTKP(0:NDKART),PKOTKT(0:NDKART)
      COMMON
     *       /RMSRAD/ RADI_N(0:NDKART),
     *                RADI_P(0:NDKART),
     *                RADI_T(0:NDKART)
      COMMON
     *       /RMSRAH/ RMSRAN(1:NDMORD),
     *                RMSRAP(1:NDMORD),
     *                RMSRAT(1:NDMORD)
      COMMON
     *       /QMUTWC/ QFRA_N(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QFRA_P(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QFRA_T(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
C
C=======================================================================
C       THIS SUBROUTINE ADDS THE PROTON AND NEUTRON CONTRIBUTIONS OF
C       WHATEVER WE NEED.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      QMUL_T(:,:) = QMUL_N(:,:)+QMUL_P(:,:)
      QMUT_T(:,:) = QMUT_N(:,:)+QMUT_P(:,:)
C
      IF (ITWCEN.EQ.2) THEN
          QFRA_T(:,:,:)=QFRA_N(:,:,:)+QFRA_P(:,:,:)
      END IF
C
      SMUL_T(:,:) = SMUL_N(:,:)+SMUL_P(:,:)
C
      IF (IDOPLM.EQ.1) THEN
          PMUL_T(:,:) = PMUL_N(:,:)+PMUL_P(:,:)
      END IF
C
      AMUL_T(:,:,:) = AMUL_N(:,:,:)+AMUL_P(:,:,:)
      AMUT_T(:,:,:) = AMUT_N(:,:,:)+AMUT_P(:,:,:)
C
      WMUL_T(:,:,:) = WMUL_N(:,:,:)+WMUL_P(:,:,:)
      WMUT_T(:,:,:) = WMUT_N(:,:,:)+WMUT_P(:,:,:)
C
      VMUL_T(:,:,:) = VMUL_N(:,:,:) + VMUL_P(:,:,:)
C
      DO KARTEZ=0,NDKART
         RADI_T(KARTEZ)=SQRT((RADI_N(KARTEZ)**2*IN_FIX+
     *                        RADI_P(KARTEZ)**2*IZ_FIX)/(IN_FIX+IZ_FIX))
      END DO
C
      DO NUMORD=1,NRAORD
         RMSRAT(NUMORD)=(RMSRAN(NUMORD)*IN_FIX+
     *                   RMSRAP(NUMORD)*IZ_FIX)/(IN_FIX+IZ_FIX)
      END DO
C
      ANGU_T(:)=ANGU_N(:)+ANGU_P(:)
      SPIN_T(:)=SPIN_N(:)+SPIN_P(:)
C
C=======================================================================
C        ATTENTION: IN THE AVERAGE MOMENTUM SQUARED, THE  NEUTRON-PROTON
C                   TERM WAS MISSING IN VERSIONS UP TO 2.39L,  AND  THIS
C                   BUG HAS BEEN CORRECTED IN VERSION 2.39M ON 31/05/09.
C=======================================================================
C
      TLINSQ=0.0D0
      TKINSQ=C_ZERO
C
      DO KARTEZ=1,NDKART
C
         DLINST(KARTEZ)=DLINSN(KARTEZ)+DLINSP(KARTEZ)
         ELINST(KARTEZ)=ELINSN(KARTEZ)+ELINSP(KARTEZ)
         PLINST(KARTEZ)=PLINSN(KARTEZ)+PLINSP(KARTEZ)
         TLINST(KARTEZ)=TLINSN(KARTEZ)+TLINSP(KARTEZ)
     *               +2*ALINLN(KARTEZ)*ALINLP(KARTEZ)
         ALINLT(KARTEZ)=ALINLN(KARTEZ)+ALINLP(KARTEZ)
         PLINLT(KARTEZ)=PLINLN(KARTEZ)+PLINLP(KARTEZ)
         PLINKT(KARTEZ)=PLINKN(KARTEZ)+PLINKP(KARTEZ)
C
         TLINSQ        =TLINSQ
     *                 +ALINLN(KARTEZ)*ALINLP(KARTEZ)
C
         DKINST(KARTEZ)=DKINSN(KARTEZ)+DKINSP(KARTEZ)
         EKINST(KARTEZ)=EKINSN(KARTEZ)+EKINSP(KARTEZ)
         PKINST(KARTEZ)=PKINSN(KARTEZ)+PKINSP(KARTEZ)
         TKINST(KARTEZ)=TKINSN(KARTEZ)+TKINSP(KARTEZ)
     *               +2*AKINLN(KARTEZ)*AKINLP(KARTEZ)
         AKINLT(KARTEZ)=AKINLN(KARTEZ)+AKINLP(KARTEZ)
         PKINLT(KARTEZ)=PKINLN(KARTEZ)+PKINLP(KARTEZ)
         PKINKT(KARTEZ)=PKINKN(KARTEZ)+PKINKP(KARTEZ)
C
         TKINSQ        =TKINSQ
     *                 +AKINLN(KARTEZ)*AKINLP(KARTEZ)
C
      END DO
C
      DLINST(0)=DLINSN(0)+DLINSP(0)
      ELINST(0)=ELINSN(0)+ELINSP(0)
      PLINST(0)=PLINSN(0)+PLINSP(0)
      TLINST(0)=TLINSN(0)+TLINSP(0)+2*TLINSQ
      ALINLT(0)=ALINLN(0)+ALINLP(0)+2*TLINSQ
      PLINLT(0)=PLINLN(0)+PLINLP(0)
      PLINKT(0)=PLINKN(0)+PLINKP(0)
C
      DKINST(0)=DKINSN(0)+DKINSP(0)
      EKINST(0)=EKINSN(0)+EKINSP(0)
      PKINST(0)=PKINSN(0)+PKINSP(0)
      TKINST(0)=TKINSN(0)+TKINSP(0)+2*TKINSQ
      AKINLT(0)=AKINLN(0)+AKINLP(0)+2*TKINSQ
      PKINLT(0)=PKINLN(0)+PKINLP(0)
      PKINKT(0)=PKINKN(0)+PKINKP(0)
C
C=======================================================================
C
      TROTSQ=0.0D0
      TKOTSQ=C_ZERO
C
      DO KARTEZ=1,NDKART
C
         DROTST(KARTEZ)=DROTSN(KARTEZ)+DROTSP(KARTEZ)
         EROTST(KARTEZ)=EROTSN(KARTEZ)+EROTSP(KARTEZ)
         PROTST(KARTEZ)=PROTSN(KARTEZ)+PROTSP(KARTEZ)
         TROTST(KARTEZ)=TROTSN(KARTEZ)+TROTSP(KARTEZ)
     *               +2*AROTLN(KARTEZ)*AROTLP(KARTEZ)
         AROTLT(KARTEZ)=AROTLN(KARTEZ)+AROTLP(KARTEZ)
         PROTLT(KARTEZ)=PROTLN(KARTEZ)+PROTLP(KARTEZ)
         PROTKT(KARTEZ)=PROTKN(KARTEZ)+PROTKP(KARTEZ)
C
         TROTSQ        =TROTSQ
     *                 +AROTLN(KARTEZ)*AROTLP(KARTEZ)
C
         DKOTST(KARTEZ)=DKOTSN(KARTEZ)+DKOTSP(KARTEZ)
         EKOTST(KARTEZ)=EKOTSN(KARTEZ)+EKOTSP(KARTEZ)
         PKOTST(KARTEZ)=PKOTSN(KARTEZ)+PKOTSP(KARTEZ)
         TKOTST(KARTEZ)=TKOTSN(KARTEZ)+TKOTSP(KARTEZ)
     *               +2*AKOTLN(KARTEZ)*AKOTLP(KARTEZ)
         AKOTLT(KARTEZ)=AKOTLN(KARTEZ)+AKOTLP(KARTEZ)
         PKOTLT(KARTEZ)=PKOTLN(KARTEZ)+PKOTLP(KARTEZ)
         PKOTKT(KARTEZ)=PKOTKN(KARTEZ)+PKOTKP(KARTEZ)
C
         TKOTSQ        =TKOTSQ
     *                 +AKOTLN(KARTEZ)*AKOTLP(KARTEZ)
C
      END DO
C
      DROTST(0)=DROTSN(0)+DROTSP(0)
      EROTST(0)=EROTSN(0)+EROTSP(0)
      PROTST(0)=PROTSN(0)+PROTSP(0)
      TROTST(0)=TROTSN(0)+TROTSP(0)+2*TROTSQ
      AROTLT(0)=AROTLN(0)+AROTLP(0)+2*TROTSQ
      PROTLT(0)=PROTLN(0)+PROTLP(0)
      PROTKT(0)=PROTKN(0)+PROTKP(0)
C
      DKOTST(0)=DKOTSN(0)+DKOTSP(0)
      EKOTST(0)=EKOTSN(0)+EKOTSP(0)
      PKOTST(0)=PKOTSN(0)+PKOTSP(0)
      TKOTST(0)=TKOTSN(0)+TKOTSP(0)+2*TKOTSQ
      AKOTLT(0)=AKOTLN(0)+AKOTLP(0)+2*TKOTSQ
      PKOTLT(0)=PKOTLN(0)+PKOTLP(0)
      PKOTKT(0)=PKOTKN(0)+PKOTKP(0)
C
C     NUMCAL=0
C
C     WRITE(*,'(I5,100(1PD12.4))') NUMCAL,
C    *                           TKOTST(0)-PKOTST(0),
C    *                           TKOTSN(0)-PKOTSN(0),
C    *                           TKOTSP(0)-PKOTSP(0),
C    *                           PKOTST(0),PKOTSN(0),PKOTSP(0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TOTANG
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
      COMPLEX
     *          TKOTSQ
      COMPLEX
     *          DKOTSN,DKOTSP,DKOTST,
     *          EKOTSN,EKOTSP,EKOTST,
     *          PKOTSN,PKOTSP,PKOTST,
     *          TKOTSN,TKOTSP,TKOTST,
     *          AKOTLN,AKOTLP,AKOTLT,
     *          PKOTLN,PKOTLP,PKOTLT,
     *          PKOTKN,PKOTKP,PKOTKT
C
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /ANGSPI/ SPIN_N(1:NDKART),SPIN_P(1:NDKART),SPIN_T(1:NDKART)
      COMMON
     *       /ROTMOM/ DROTSN(0:NDKART),DROTSP(0:NDKART),DROTST(0:NDKART)
     *               ,EROTSN(0:NDKART),EROTSP(0:NDKART),EROTST(0:NDKART)
     *               ,TROTSN(0:NDKART),TROTSP(0:NDKART),TROTST(0:NDKART)
     *               ,AROTLN(0:NDKART),AROTLP(0:NDKART),AROTLT(0:NDKART)
      COMMON
     *       /KOTMOM/ DKOTSN(0:NDKART),DKOTSP(0:NDKART),DKOTST(0:NDKART)
     *               ,EKOTSN(0:NDKART),EKOTSP(0:NDKART),EKOTST(0:NDKART)
     *               ,TKOTSN(0:NDKART),TKOTSP(0:NDKART),TKOTST(0:NDKART)
     *               ,AKOTLN(0:NDKART),AKOTLP(0:NDKART),AKOTLT(0:NDKART)
      COMMON
     *       /ROTPAI/ PROTSN(0:NDKART),PROTSP(0:NDKART),PROTST(0:NDKART)
     *               ,PROTLN(0:NDKART),PROTLP(0:NDKART),PROTLT(0:NDKART)
     *               ,PROTKN(0:NDKART),PROTKP(0:NDKART),PROTKT(0:NDKART)
      COMMON
     *       /KOTPAI/ PKOTSN(0:NDKART),PKOTSP(0:NDKART),PKOTST(0:NDKART)
     *               ,PKOTLN(0:NDKART),PKOTLP(0:NDKART),PKOTLT(0:NDKART)
     *               ,PKOTKN(0:NDKART),PKOTKP(0:NDKART),PKOTKT(0:NDKART)
C
C     DATA NUMCAL /0/
C
C=======================================================================
C       THIS SUBROUTINE ADDS THE PROTON AND NEUTRON CONTRIBUTIONS OF
C       ANGULAR MOMENTA.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      ANGU_T(:)=ANGU_N(:)+ANGU_P(:)
      SPIN_T(:)=SPIN_N(:)+SPIN_P(:)
C
C=======================================================================
C
      TROTSQ=0.0D0
      TKOTSQ=C_ZERO
C
      DO KARTEZ=1,NDKART
C
         DROTST(KARTEZ)=DROTSN(KARTEZ)+DROTSP(KARTEZ)
         EROTST(KARTEZ)=EROTSN(KARTEZ)+EROTSP(KARTEZ)
         PROTST(KARTEZ)=PROTSN(KARTEZ)+PROTSP(KARTEZ)
         TROTST(KARTEZ)=TROTSN(KARTEZ)+TROTSP(KARTEZ)
     *               +2*AROTLN(KARTEZ)*AROTLP(KARTEZ)
         AROTLT(KARTEZ)=AROTLN(KARTEZ)+AROTLP(KARTEZ)
         PROTLT(KARTEZ)=PROTLN(KARTEZ)+PROTLP(KARTEZ)
         PROTKT(KARTEZ)=PROTKN(KARTEZ)+PROTKP(KARTEZ)
C
         TROTSQ        =TROTSQ
     *                 +AROTLN(KARTEZ)*AROTLP(KARTEZ)
C
         DKOTST(KARTEZ)=DKOTSN(KARTEZ)+DKOTSP(KARTEZ)
         EKOTST(KARTEZ)=EKOTSN(KARTEZ)+EKOTSP(KARTEZ)
         PKOTST(KARTEZ)=PKOTSN(KARTEZ)+PKOTSP(KARTEZ)
         TKOTST(KARTEZ)=TKOTSN(KARTEZ)+TKOTSP(KARTEZ)
     *               +2*AKOTLN(KARTEZ)*AKOTLP(KARTEZ)
         AKOTLT(KARTEZ)=AKOTLN(KARTEZ)+AKOTLP(KARTEZ)
         PKOTLT(KARTEZ)=PKOTLN(KARTEZ)+PKOTLP(KARTEZ)
         PKOTKT(KARTEZ)=PKOTKN(KARTEZ)+PKOTKP(KARTEZ)
C
         TKOTSQ        =TKOTSQ
     *                 +AKOTLN(KARTEZ)*AKOTLP(KARTEZ)
C
      END DO
C
      DROTST(0)=DROTSN(0)+DROTSP(0)
      EROTST(0)=EROTSN(0)+EROTSP(0)
      PROTST(0)=PROTSN(0)+PROTSP(0)
      TROTST(0)=TROTSN(0)+TROTSP(0)+2*TROTSQ
      AROTLT(0)=AROTLN(0)+AROTLP(0)+2*TROTSQ
      PROTLT(0)=PROTLN(0)+PROTLP(0)
      PROTKT(0)=PROTKN(0)+PROTKP(0)
C
      DKOTST(0)=DKOTSN(0)+DKOTSP(0)
      EKOTST(0)=EKOTSN(0)+EKOTSP(0)
      PKOTST(0)=PKOTSN(0)+PKOTSP(0)
      TKOTST(0)=TKOTSN(0)+TKOTSP(0)+2*TKOTSQ
      AKOTLT(0)=AKOTLN(0)+AKOTLP(0)+2*TKOTSQ
      PKOTLT(0)=PKOTLN(0)+PKOTLP(0)
      PKOTKT(0)=PKOTKN(0)+PKOTKP(0)
C
C     NUMCAL=NUMCAL+1
C
C     WRITE(*,'(I5,100(1PD12.4))') NUMCAL,
C    *                           TKOTST(0)-PKOTST(0),
C    *                           TKOTSN(0)-PKOTSN(0),
C    *                           TKOTSP(0)-PKOTSP(0),
C    *                           PKOTST(0),PKOTSN(0),PKOTSP(0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
#if(USE_MPI==1)
C=======================================================================
C
      SUBROUTINE batch(NFIREP,NFIREC,NFILIP,NFILIC,
     *                 FILREP,FILREC,FILLIP,FILLIC,
     *                 NUDATA,IF_THO,
     *                        NXHERM,NYHERM,NZHERM,IRENMA,IRENIN,
     *                 REFERN,REFERP,REDELN,REDELP,REFE2N,REFE2P,
     *                 IFIBLN,INIBLN,IFIBLP,INIBLP,NMUMAX,NSIMAX,
     *                                             NMUCON,ISHIFT,
     *                 ICONTI,IPCONT,ILCONT,IACONT,IGCONT,IGPCON,
     *                               ISCONT,ITCONT,IMCONT,IRCONT,
     *                 IPAIRI,LIPKIN,LIPKIP,I_GOGA,IGOGPA,I_YUKA,
     *                                      ITWOLI,JETACM,KETA_R,
     *                 IPNMIX,Q_NECK,QACTUA,QORIGI,QINCRE,INDJOB,
     *                 batch_init)
C=======================================================================
      USE hfodd_mpiio
      USE hfodd_sizes
C=======================================================================
C
      LOGICAL
     *          INCREP,INCREC,INCLIP,INCLIC
      INTEGER
     *          batch_init
      CHARACTER
     *          FILREP*68,FILREC*68,FILLIP*68,FILLIC*68
C
      DIMENSION
     *          QACTUA(0:NDMULT,-NDMULT:NDMULT),
     *          QORIGI(0:NDMULT,-NDMULT:NDMULT),
     *          QINCRE(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /ITERTS/ ITESTA,ITESTO,NOITER,NUMITE
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
C=======================================================================
C
C                        PARALLEL BATCH MODE
C
C       In parallel mode, this is the option to approach the target
C       value of a given constraint (multipole moments or neck) by
C       n_batch consecutive "batch" increments. Each batch sequence
C       uses only N/n_batch iterations. The target value for a given
C       batch sequence k is
C                            q_orig + (k-1) \delta q,
C       with
C                  \delta q = (q_target - q_orig)/n_batch
C
C       q_target is the original requested value for the constraint,
C       and q_orig the value of that constraint read from disk (if
C       not, it is zero). Such a construct is convenient to perform
C       multi-constrained calculations where the values of the
C       constraints are "large" compared to the initial solutions.
C
C=======================================================================
C
      IF (batch_init.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *          ''*      PARALLEL BATCH MODE: INITIALIZATION'',36X,
     *          ''*'',/,''*  NUMBER OF BATCHES: '',I3,53X,''*'',/,
     *          ''*  MULTIPOLE MOMENTS'',58X,''*'',/,
     *          ''*      LAMBDA   MIU   VALUE READ   '',
     *          ''REQUESTED      TARGET     INCREMENT        *'')')
     *
     *            number_batch
C
C          Manipulation of the record files: in parallel batch
C          jobs, the record and replay files in continuation mode
C          are originally distinct. After the first batch sequence,
C          they must be the same: we rename them, close them both,
C          and reopen the unique file
C
          INCREC=.FALSE.
          INCREP=.FALSE.
C
          INQUIRE(UNIT=NFIREP,OPENED=INCREP)
                                 IF (INCREP) CLOSE(NFIREP)
          INQUIRE(UNIT=NFIREC,OPENED=INCREC)
                                 IF (INCREC) CLOSE(NFIREC)
C
          NFIREP=NFIREC
          FILREP=FILREC
C
          IERROR=0
          OPEN(NFIREP,FILE=FILREP,STATUS='UNKNOWN',IOSTAT=IERROR,
     *                FORM='UNFORMATTED')
C
          IF (IERROR.NE.0) THEN
C
              WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                 ''FILE NOT FOUND ON DISC'',
     *                                             2X,26(1H/),/,
     *                 1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                 1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                 1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                 1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                             2X,26(1H/))')
     *             FILREP
C
               STOP ' FILE FILREP NOT FOUND ON DISC'
C
          END IF
C
C          Same game with the Lipkin files
C
          IF (LIPKIN.EQ.1.OR.LIPKIP.EQ.1) THEN
C
              INCLIC=.FALSE.
              INCLIP=.FALSE.
C
              INQUIRE(UNIT=NFILIP,OPENED=INCLIP)
                                     IF (INCLIP) CLOSE(NFILIP)
              INQUIRE(UNIT=NFILIC,OPENED=INCLIC)
                                     IF (INCLIC) CLOSE(NFILIC)
C
              NFILIP=NFILIC
              FILLIP=FILLIC
C
              IERROR=0
              OPEN(NFILIP,FILE=FILLIP,STATUS='UNKNOWN',IOSTAT=IERROR,
     *                    FORM='UNFORMATTED')
C
              IF (IERROR.NE.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,26(1H/),2X,
     *                     ''FILE NOT FOUND ON DISC'',
     *                                                 2X,26(1H/),/,
     *                     1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                     1X, 3(1H/),2X,A68,          2X, 3(1H/),/,
     *                     1X, 3(1H/),2X,68X,          2X, 3(1H/),/,
     *                     1X,26(1H/),2X,''FILE NOT FOUND ON DISC'',
     *                                                 2X,26(1H/))')
     *                 FILLIP
C
                   STOP 'BATCH: FILE FILLIP NOT FOUND ON DISC'
C
              END IF
C
          END IF
C
C          Reset of continuation flags to 1: this is *not* official
C          HFODD practice and is only allowed in this experimental
C          version.
C
          IF (IF_THO.EQ.0) THEN
C
              ICONTI=1
              IACONT=1
              IF (IPAIRI.GE.1) IPCONT=1
              IF (LIPKIN.EQ.1.OR.LIPKIP.EQ.1) ILCONT=1
              IF (I_GOGA.GE.1) IGCONT=1
              IF (IGOGPA.GE.1) IGPCON=1
              IF (I_YUKA.GE.1) IYCONT=1
              IF (JETACM.EQ.2) IMCONT=1
              IF (KETA_R.EQ.2) IRCONT=1
C
          END IF
C
      END IF
C
      IF (number_batch.GT.1) THEN
C
C          First batch: define the increment that will be used to set a
C          "dynamic" target value for each collective variable in each
C          step of the batch process. Values of multipole moments have
C          been read in RECORD() or initalized at 0; values of the neck
C          operator have been either read in RECORD(), recalculated on
C          the fly (after that call to RECORD()), or initialized at 0;
C          Same for the constraint on the fragment distance and mass
C          asymmetry.
C
          IF (NUDATA.EQ.1) THEN
C
C              Number of iteration per batch item
              NOITER = NOITER / number_batch
C
              IF (NOITER.EQ.0) NOITER=1
C
              ITESTO = NUMITE + NOITER
C
              DO i=1,number_constraint_batch
C
                 LAMACT = lambda_batch(i)
                 MIUACT =    miu_batch(i)
C
C                 Ordinary multipole moments
                 IF (LAMACT.GE.1.AND.MIUACT.GE.0) THEN
C
                     QORIGI(LAMACT,MIUACT) = QASKED(LAMACT,MIUACT)
                     QACTUA(LAMACT,MIUACT) = QMUL_T(LAMACT,MIUACT)
C
                     QSHIFT = QORIGI(LAMACT,MIUACT)
     *                      - QACTUA(LAMACT,MIUACT)
                     QINCRE(LAMACT,MIUACT) = QSHIFT / number_batch
C
C                     New target value for the first batch
                     QASKED(LAMACT,MIUACT) = QACTUA(LAMACT,MIUACT)
     *                                     + QINCRE(LAMACT,MIUACT)
     *                                 *REAL(NUDATA,KIND=KIND(1.0))
C
                     WRITE(NFIPRI,'(''*'',3X,2(6X,I1),4(5X,F8.3),
     *                              8X,''*'')')
     *                           LAMACT,MIUACT,QACTUA(LAMACT,MIUACT),
     *                   QORIGI(LAMACT,MIUACT),QASKED(LAMACT,MIUACT),
     *                   QINCRE(LAMACT,MIUACT)
C
                 END IF
C
C                 Neck
                 IF (LAMACT.EQ.0.AND.MIUACT.EQ.0) THEN
C
                     QORIGI(LAMACT,MIUACT) = Q0NECK
                     QACTUA(LAMACT,MIUACT) = Q_NECK
C
                     QSHIFT = QORIGI(LAMACT,MIUACT)
     *                      - QACTUA(LAMACT,MIUACT)
                     QINCRE(LAMACT,MIUACT) = QSHIFT / number_batch
C
                     Q0NECK = QACTUA(LAMACT,MIUACT)
     *                      + QINCRE(LAMACT,MIUACT)
     *                      *REAL(NUDATA)
C
                     WRITE(NFIPRI,'(''*'',3X,2(6X,I1),4(5X,F8.3),
     *                              8X,''*'')')
     *                           LAMACT,MIUACT,QACTUA(LAMACT,MIUACT),
     *                   QORIGI(LAMACT,MIUACT),Q0NECK,
     *                   QINCRE(LAMACT,MIUACT)
C
                 END IF
C
              END DO
C
              WRITE(NFIPRI,'(''*'',77X,''*'',/,79(''*''),/)')
C
C              When relooping in parallel mode, do not read data again
              batch_init = 0
C
C          All other batches: increment the target value
C
          ELSE
C
C              If HFBTHO is used, continuation modes are set to 0, and
C              HFODD record files are not read. The call below is needed
C              to update the value Fermi levels.
C
              IF (IF_THO.EQ.1) THEN
C
                  INPFLD=1
                  IERROR=0
C
                  CALL RECORD(NFIREP,NFIREC,INPFLD,NUMITE,
     *                        IVEREP,NXHERM,NYHERM,NZHERM,
     *                                      IPCONT,ILCONT,
     *                               ISCONT,ITCONT,IACONT,
     *                                      IMCONT,IRCONT,
     *                                      IRENMA,IRENIN,
     *                                      LIPKIN,LIPKIP,
     *                                      REFERN,REFERP,
     *                                      REDELN,REDELP,
     *                                      REFE2N,REFE2P,
     *                                      IDSIGN,IDSIGP,
     *                                      IDSIMN,IDSIMP,
     *                                      IDSIQN,IDSIQP,
     *                                      IDSIZN,IDSIZP,
     *                                             INIBLN,
     *                                             INIBLP,
     *                                      NMUMAX,NSIMAX,
     *                                      IPNMIX,ISHIFT,
     *                                      JETA_T,JETAPA,IERROR,
     *                                             LDTWCE,LDTWDD,
     *                                                    IFRCNT)
C
              END IF
C
              WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *              ''*      PARALLEL BATCH MODE: CALCULATION OF '',
     *              ''BATCH NUMBER '',I3,19X,''*'',/,
     *              ''*  MULTIPOLE MOMENTS'',58X,''*'',/,
     *              ''*      LAMBDA   MIU   VALUE READ   '',
     *              ''REQUESTED      TARGET     INCREMENT        *'')')
     *
     *                NUDATA
C
              DO i=1,number_constraint_batch
C
                 LAMACT = lambda_batch(i)
                 MIUACT =    miu_batch(i)
C
C                 Ordinary multipole moments
                 IF (LAMACT.GE.1.AND.MIUACT.GE.0) THEN
C
                     Q_READ = QMUL_T(LAMACT,MIUACT)
C
                     QASKED(LAMACT,MIUACT) = QACTUA(LAMACT,MIUACT)
     *                                     + QINCRE(LAMACT,MIUACT)
     *                               * REAL(NUDATA,KIND=KIND(1.0))
C
                     WRITE(NFIPRI,'(''*'',3X,2(6X,I1),4(5X,F8.3),
     *                              8X,''*'')')
     *                           LAMACT,MIUACT,Q_READ,
     *                   QORIGI(LAMACT,MIUACT),QASKED(LAMACT,MIUACT),
     *                   QINCRE(LAMACT,MIUACT)
C
                 END IF
C
C                 Neck
                 IF (LAMACT.EQ.0.AND.MIUACT.EQ.0) THEN
C
                     Q_READ = Q_NECK
C
                     Q0NECK = QACTUA(LAMACT,MIUACT)
     *                      + QINCRE(LAMACT,MIUACT)
     *                      *REAL(NUDATA)
C
                     WRITE(NFIPRI,'(''*'',3X,2(6X,I1),4(5X,F8.3),
     *                              8X,''*'')')
     *                           LAMACT,MIUACT,Q_READ,
     *                   QORIGI(LAMACT,MIUACT),Q0NECK,
     *                   QINCRE(LAMACT,MIUACT)
C
                 END IF
C
              END DO
C
              WRITE(NFIPRI,'(''*'',77X,''*'',/,79(''*''),/)')
C
          END IF
C
      END IF
C
      RETURN
      END
#endif
C=======================================================================
C
      SUBROUTINE QMULCM(COFMUL,IBROYD,MIXMAT,SLOWEV,
     *                         SLOWOD,NUMITE,NZMAXX)
C=======================================================================
      USE SAVQUA
      USE hfodd_fission_fragments
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO,C_UNIT,C_MINU,CPLMUL
      COMPLEX
     *          FN12PL,FP12PL,FN11PL,FP11PL,FN11MI,FP11MI
      COMPLEX
     *          CMPLXN,CMPLXP,CSUM_N,CSUM_P
      COMPLEX
     *          T_TERM
C=======================================================================
      ALLOCATABLE FN12PL(:,:,:),FP12PL(:,:,:)
      ALLOCATABLE FN11PL(:,:,:),FP11PL(:,:,:)
      ALLOCATABLE FN11MI(:,:,:),FP11MI(:,:,:)
      ALLOCATABLE CMPLXN(:,:),CMPLXP(:,:),CSUM_N(:,:),CSUM_P(:,:)
      ALLOCATABLE ELEMUL(:,:),CPLMUL(:,:)
C=======================================================================
      DIMENSION
     *          CNSMAT(1:NDCONS,1:NDCONS)
      DIMENSION
     *          CNSVEC(1:NDCONS),WORKCN(1:NDCONS),VECLAM(1:NDCONS)
      DIMENSION
     *          IPIVOT(1:NDCONS)
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
      COMMON
     *       /GCTEMP/ TEMP_T
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /CNSQLM/ VECCNS(1:NDCONS)
     *       /CNSOLD/ VECOLD(1:NDCONS)
      COMMON
     *       /CNSCOR/ LAMCNS(1:NDCONS),MIUCNS(1:NDCONS)
     *       /CNSNUM/ NOFCNS
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /QUAISO/ EQPISO(1:2*NDSTAT,0:NDREVE,0:NDISOS),
     *                VQPISO(1:2*NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /QUAPER/ DELTEN(1:NDBASE,0:NDREVE),
     *                DELTEP(1:NDBASE,0:NDREVE)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS ROUTINE UPDATES THE  LAGRANGE  MULTIPLIERS OF THE MULTI-
C       DIMENSIONAL LINEAR CONSTRAINTS  BASED ON THE VARIATION OF THE
C       GENERALIZED DENSITY MATRIX AND THE RPA MATRIX AT THE CRANKING
C       APPROXIMATION.
C
C       REFERENCES:  (1) Phys. Rev. C21, 1568 (1980)
C                    (2) Phys. Rev. C80, 054313 (2009)
C=======================================================================
C
      CALL CPUTIM('QMULCM',1)
C
C=======================================================================
C
      IF (NDSTAT.LT.LDBASE) THEN
C
          WRITE(NFIPRI,'(
     *            1H*,20(1H/),2X,''NDSTAT='',I4,'' < LDBASE='',I4,
     *                           '' IS  NOT'',   2X,20(1H/),1H*,/,
     *            1H*,20(1H/),2X,''ALLOWED IN QMULCM. RECOMPILE'',
     *                           '' WITH'',      2X,20(1H/),1H*,/,
     *            1H*,20(1H/),2X,''NDSTAT=LDBASE AND RERUN THE '',
     *                           '' CODE'',      2X,20(1H/),1H*,/)')
     *    NDSTAT,LDBASE
C
          STOP 'NDSTAT < LDBASE NOT ALLOWED IN QMULCM'
C
      END IF
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE(ELEMUL(1:NDBASE,1:NDBASE))
      IF (IALLOC.NE.0) CALL NOALLO('ELEMUL','QMULCM')
      ALLOCATE(CPLMUL(1:NDBASE,1:NDBASE))
      IF (IALLOC.NE.0) CALL NOALLO('CPLMUL','QMULCM')
C=======================================================================
C
      R_ZERO=0.0D0
      R_UNIT=1.0D0
C
      C_UNIT=CMPLX( R_UNIT,R_ZERO)
      C_ZERO=CMPLX( R_ZERO,R_ZERO)
      C_MINU=CMPLX(-R_UNIT,R_ZERO)
C
C      Determining the old Lagrange multiplier for each constraint
C
      DO I=1,NOFCNS
C
         LAMACT=lamcns(I)
         MIUACT=miucns(I)
C         Regular multipole moments
         IF (LAMACT.GE.1.AND.MIUACT.GE.0) THEN
             VECOLD(I)=GALMUQ(LAMACT,MIUACT)
             CNSVEC(I)=QASKED(LAMACT,MIUACT)-QMUL_N(LAMACT,MIUACT)
     *                                      -QMUL_P(LAMACT,MIUACT)
             VECLAM(I)=GALMUQ(LAMACT,MIUACT)
         END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C         Constraint on the size of the neck
         IF (LAMACT.EQ.0.AND.MIUACT.EQ.0) THEN
             VECOLD(I)=G_NECK
             CNSVEC(I)=Q0NECK-Q_NECK
             VECLAM(I)=G_NECK
         END IF
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
      END DO
C
C      Proceeding to determine the matrix of the constraint operators
C      in the q.p. basis
C
      ALLOCATE (FN12PL(1:NDSTAT,1:NDSTAT,1:NOFCNS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FN12PL','QMULCM')
      ALLOCATE (FP12PL(1:NDSTAT,1:NDSTAT,1:NOFCNS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FP12PL','QMULCM')
C
      FN12PL(:,:,:) = C_ZERO
      FP12PL(:,:,:) = C_ZERO
C
      ALLOCATE (FN11PL(1:NDSTAT,1:NDSTAT,1:NOFCNS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FN11PL','QMULCM')
      ALLOCATE (FP11PL(1:NDSTAT,1:NDSTAT,1:NOFCNS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FP11PL','QMULCM')
      ALLOCATE (FN11MI(1:NDSTAT,1:NDSTAT,1:NOFCNS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FN11MI','QMULCM')
      ALLOCATE (FP11MI(1:NDSTAT,1:NDSTAT,1:NOFCNS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FP11MI','QMULCM')
C
      FN11PL(:,:,:) = C_ZERO
      FP11PL(:,:,:) = C_ZERO
      FN11MI(:,:,:) = C_ZERO
      FP11MI(:,:,:) = C_ZERO
C
      IMAREA=1
C
C      Neutron sector
C
      ICHARG=0
C
      ALLOCATE (CMPLXN(1:NDBASE,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMPLXN','QMULCM')
C
      CMPLXN(:,:) = C_ZERO
      ELEMUL(:,:) = R_ZERO
C
      DO I=1,NOFCNS
C
         LAMACT=LAMCNS(I)
         MIUACT=MIUCNS(I)
C
C         Matrix of the constraint operator in the HO basis:
C          - regular multipole moments
         IF (LAMACT.GE.1.AND.MIUACT.GE.0) THEN
             CALL INTMUL(IPHAPP(0,0,0),ELEMUL,COFMUL,
     *                                 LAMACT,MIUACT,IMAREA)
         END IF
C          - constraint on the size of the neck
         IF (LAMACT.EQ.0.AND.MIUACT.EQ.0) THEN
             CALL INT_QN(NZMAXX,ELEMUL)
         END IF
C
         DO L=1,NDBASE
            DO K=1,NDBASE
               CPLMUL(K,L)=ELEMUL(K,L)*C_UNIT
            END DO
         END DO
C
C         Matrix of the constraint operator in the qp basis. Due to
C         the q.p. cut-off the actual size of the q.p. basis is not
C         the same as the s.p. (HO) basis, and it is  not the  same
C         for protons and neutrons.  The formulas implemented below
C         differ from the 2 references for 3 reasons:
C          - different  phase convention for the Bogoliubov  matrix
C          - block structure of the Bogoliubov matrix in HFODD
C          - storage in A() and B() arrays correspond to complex
C            conjugate of the actual matrices
C
C         Second term: V_{+}^{+} F_{+}^{*} U_{+}^{*}
C                    = B_{+}^{T} F_{+}     A_{+}
C
C      print *, "1 zgemm", LDBASE,NDBASE,NDSTAT
         CALL ZGEMM('N','N',LDBASE,NUMBQP(0,0),LDBASE,
     *                           C_UNIT,CPLMUL,NDBASE,
     *                         ASVQUA(1,1,0,0),NDBASE,
     *                           C_ZERO,CMPLXN,NDSTAT)
C
         CALL ZGEMM('T','N',NUMBQP(0,0),NUMBQP(0,0),LDBASE,
     *                       C_UNIT,BSVQUA(1,1,0,0),NDBASE,
     *                                       CMPLXN,NDSTAT,
     *                         C_ZERO,FN12PL(1,1,I),NDSTAT)
C
C         First term:  U_{-}^{+} F_{-} V_{-}^{*}
C                    = A_{-}^{T} F_{-} B_{-}
C
         CALL ZGEMM('N','N',LDBASE,NUMBQP(1,0),LDBASE,
     *                           C_UNIT,CPLMUL,NDBASE,
     *                         BSVQUA(1,1,1,0),NDBASE,
     *                           C_ZERO,CMPLXN,NDSTAT)
C
         CALL ZGEMM('T','N',NUMBQP(1,0),NUMBQP(1,0),LDBASE,
     *                       C_UNIT,ASVQUA(1,1,1,0),NDBASE,
     *                                       CMPLXN,NDSTAT,
     *                         C_MINU,FN12PL(1,1,I),NDSTAT)
C
CLP@+
        if (IFTEMP.gt.0) then
CLP@-
C
C         Computing \tilde{F}^{11}
C
C         Second term: V_{+}^{+} F_{+}^{*} V_{+}
C                    = B_{+}^{T}(B_{+}^{T} F_{+}^{T})^{+}
C
         CALL ZGEMM('T','T',NUMBQP(0,0),LDBASE,LDBASE,
     *                  C_UNIT,BSVQUA(1,1,0,0),NDBASE,
     *                                  CPLMUL,NDBASE,
     *                           C_ZERO,CMPLXN,NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(0,0),NUMBQP(0,0),LDBASE,
     *                       C_UNIT,BSVQUA(1,1,0,0),NDBASE,
     *                                       CMPLXN,NDSTAT,
     *                         C_ZERO,FN11PL(1,1,I),NDSTAT)
C
C         First term:  U_{-}^{+} F_{-} U_{-}
C                    = A_{-}^{T}(A_{-}^{T} F_{-}^{+})^{+}
C
         CALL ZGEMM('T','C',NUMBQP(1,0),LDBASE,LDBASE,
     *                  C_UNIT,ASVQUA(1,1,1,0),NDBASE,
     *                                  CPLMUL,NDBASE,
     *                           C_ZERO,CMPLXN,NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(1,0),NUMBQP(1,0),LDBASE,
     *                       C_UNIT,ASVQUA(1,1,1,0),NDBASE,
     *                                       CMPLXN,NDSTAT,
     *                         C_MINU,FN11PL(1,1,I),NDSTAT)
C
C
C
         CALL ZGEMM('T','T',NUMBQP(1,0),LDBASE,LDBASE,
     *                  C_UNIT,BSVQUA(1,1,1,0),NDBASE,
     *                                  CPLMUL,NDBASE,
     *                           C_ZERO,CMPLXN,NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(1,0),NUMBQP(1,0),LDBASE,
     *                       C_UNIT,BSVQUA(1,1,1,0),NDBASE,
     *                                       CMPLXN,NDSTAT,
     *                         C_ZERO,FN11MI(1,1,I),NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(0,0),LDBASE,LDBASE,
     *                  C_UNIT,ASVQUA(1,1,0,0),NDBASE,
     *                                  CPLMUL,NDBASE,
     *                           C_ZERO,CMPLXN,NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(0,0),NUMBQP(0,0),LDBASE,
     *                       C_UNIT,ASVQUA(1,1,0,0),NDBASE,
     *                                       CMPLXN,NDSTAT,
     *                         C_MINU,FN11MI(1,1,I),NDSTAT)
CLP@+
      endif
CLP@-
C
      END DO
C
      DEALLOCATE(CMPLXN)
C
C      Proton sector
C
      ICHARG=1
C
      ALLOCATE (CMPLXP(1:NDBASE,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMPLXP','QMULCM')
C
      CMPLXP(:,:) = C_ZERO
      ELEMUL(:,:) = R_ZERO
C
      DO I=1,NOFCNS
C
         LAMACT=LAMCNS(I)
         MIUACT=MIUCNS(I)
C
C         Matrix of the constraint operator in the HO basis:
C          - regular multipole moments
         IF (LAMACT.GE.1.AND.MIUACT.GE.0) THEN
             CALL INTMUL(IPHAPP(0,0,0),ELEMUL,COFMUL,
     *                                 LAMACT,MIUACT,IMAREA)
         END IF
C          - constraint on the size of the neck
         IF (LAMACT.EQ.0.AND.MIUACT.EQ.0) THEN
             CALL INT_QN(NZMAXX,ELEMUL)
         END IF
C
         DO L=1,NDBASE
            DO K=1,NDBASE
               CPLMUL(K,L)=ELEMUL(K,L)*C_UNIT
            END DO
         END DO
C
C         Second term: V_{+}^{+} F_{+}^{*} U_{+}^{*}
C                    = B_{+}^{T} F_{+}     A_{+}
C
         CALL ZGEMM('N','N',LDBASE,NUMBQP(0,1),LDBASE,
     *                           C_UNIT,CPLMUL,NDBASE,
     *                         ASVQUA(1,1,0,1),NDBASE,
     *                           C_ZERO,CMPLXP,NDSTAT)
C
         CALL ZGEMM('T','N',NUMBQP(0,1),NUMBQP(0,1),LDBASE,
     *                       C_UNIT,BSVQUA(1,1,0,1),NDBASE,
     *                                       CMPLXP,NDSTAT,
     *                         C_ZERO,FP12PL(1,1,I),NDSTAT)
C
C         First term:  U_{-}^{+} F_{-} V_{-}^{*}
C                    = A_{-}^{T} F_{-} B_{-}
C
         CALL ZGEMM('N','N',LDBASE,NUMBQP(0,1),LDBASE,
     *                           C_UNIT,CPLMUL,NDBASE,
     *                         BSVQUA(1,1,1,1),NDBASE,
     *                           C_ZERO,CMPLXP,NDSTAT)
C
         CALL ZGEMM('T','N',NUMBQP(0,1),NUMBQP(0,1),LDBASE,
     *                       C_UNIT,ASVQUA(1,1,1,1),NDBASE,
     *                                       CMPLXP,NDSTAT,
     *                         C_MINU,FP12PL(1,1,I),NDSTAT)
C
CLP@+
        if (IFTEMP.gt.0) then
CLP@-
C
C         Computing \tilde{F}^{11}
C
C         Second term: V_{+}^{+} F_{+}^{*} V_{+}
C                    = B_{+}^{T}(B_{+}^{T} F_{+}^{T})^{+}
C
         CALL ZGEMM('T','T',NUMBQP(0,1),LDBASE,LDBASE,
     *                  C_UNIT,BSVQUA(1,1,0,1),NDBASE,
     *                                  CPLMUL,NDBASE,
     *                           C_ZERO,CMPLXP,NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(0,1),NUMBQP(0,1),LDBASE,
     *                       C_UNIT,BSVQUA(1,1,0,1),NDBASE,
     *                                       CMPLXP,NDSTAT,
     *                         C_ZERO,FP11PL(1,1,I),NDSTAT)
C
C         First term:  U_{-}^{+} F_{-} U_{-}
C                    = A_{-}^{T}(A_{-}^{T} F_{-}^{+})^{+}
C
         CALL ZGEMM('T','C',NUMBQP(1,1),LDBASE,LDBASE,
     *                  C_UNIT,ASVQUA(1,1,1,1),NDBASE,
     *                                  CPLMUL,NDBASE,
     *                           C_ZERO,CMPLXP,NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(1,1),NUMBQP(1,1),LDBASE,
     *                       C_UNIT,ASVQUA(1,1,1,1),NDBASE,
     *                                       CMPLXP,NDSTAT,
     *                         C_MINU,FP11PL(1,1,I),NDSTAT)
C
C
C
         CALL ZGEMM('T','T',NUMBQP(1,1),LDBASE,LDBASE,
     *                  C_UNIT,BSVQUA(1,1,1,1),NDBASE,
     *                                  CPLMUL,NDBASE,
     *                           C_ZERO,CMPLXP,NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(1,1),NUMBQP(1,1),LDBASE,
     *                       C_UNIT,BSVQUA(1,1,1,1),NDBASE,
     *                                       CMPLXP,NDSTAT,
     *                         C_ZERO,FP11MI(1,1,I),NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(0,1),LDBASE,LDBASE,
     *                  C_UNIT,ASVQUA(1,1,0,1),NDBASE,
     *                                  CPLMUL,NDBASE,
     *                           C_ZERO,CMPLXP,NDSTAT)
C
         CALL ZGEMM('T','C',NUMBQP(0,1),NUMBQP(0,1),LDBASE,
     *                       C_UNIT,ASVQUA(1,1,0,1),NDBASE,
     *                                       CMPLXP,NDSTAT,
     *                         C_MINU,FP11MI(1,1,I),NDSTAT)
C
CLP@+
        endif
CLP@-
C
      END DO
C
      DEALLOCATE(CMPLXP)
C
C      Computing the correlation matrix of the multiple constraints
C
      ALLOCATE (CMPLXN(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMPLXN','QMULCM')
      ALLOCATE (CMPLXP(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMPLXP','QMULCM')
      ALLOCATE (CSUM_N(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CSUM_N','QMULCM')
      ALLOCATE (CSUM_P(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CSUM_P','QMULCM')
C
      CMPLXN(:,:) = C_ZERO
      CMPLXP(:,:) = C_ZERO
      CSUM_N(:,:) = C_ZERO
      CSUM_P(:,:) = C_ZERO
C
      DO I=1,NOFCNS
         DO J=1,NOFCNS
C
            IF (IFTEMP.EQ.0) THEN
C
                DO L=1,NUMBQP(0,0)
                   DO K=1,NUMBQP(0,0)
                      CMPLXN(K,L)=CONJG(FN12PL(K,L,I))
     *                          /(EQPISO(K,0,0)+EQPISO(L,0,0))
                   END DO
                END DO
C
                DO L=1,NUMBQP(0,1)
                   DO K=1,NUMBQP(0,1)
                      CMPLXP(K,L)=CONJG(FP12PL(K,L,I))
     *                          /(EQPISO(K,0,1)+EQPISO(L,0,1))
                   END DO
                END DO
C
                CALL ZGEMM('T','N',NUMBQP(0,0),NUMBQP(0,0),NUMBQP(0,0),
     *                                C_UNIT,FN12PL(1,1,J),NDSTAT,
     *                                              CMPLXN,NDSTAT,
     *                                       C_ZERO,CSUM_N,NDSTAT)
C
                CALL ZGEMM('T','N',NUMBQP(0,1),NUMBQP(0,1),NUMBQP(0,1),
     *                                C_UNIT,FP12PL(1,1,J),NDSTAT,
     *                                              CMPLXP,NDSTAT,
     *                                       C_ZERO,CSUM_P,NDSTAT)
C
            ELSE
C
C                Term corresponding to F^12
C
                DO L=1,NUMBQP(0,0)
                   DO K=1,NUMBQP(0,0)
                      TEMP_K=FERMFN(K,0)
                      TEMP_L=FERMFN(L,0)
                      CMPLXN(K,L)=CONJG(FN12PL(K,L,I))
     *                          *(1.0+TEMP_K+TEMP_L)
     *                          /(EQPISO(K,0,0)+EQPISO(L,0,0))
                   END DO
                END DO
C
                DO L=1,NUMBQP(0,1)
                   DO K=1,NUMBQP(0,1)
                      TEMP_K=FERMFN(K,1)
                      TEMP_L=FERMFN(L,1)
                      CMPLXP(K,L)=CONJG(FP12PL(K,L,I))
     *                          *(1.0+TEMP_K+TEMP_L)
     *                          /(EQPISO(K,0,1)+EQPISO(L,0,1))
                   END DO
                END DO
C
                CALL ZGEMM('T','N',NUMBQP(0,0),NUMBQP(0,0),NUMBQP(0,0),
     *                                C_UNIT,FN12PL(1,1,J),NDSTAT,
     *                                              CMPLXN,NDSTAT,
     *                                       C_ZERO,CSUM_N,NDSTAT)
C
                CALL ZGEMM('T','N',NUMBQP(0,1),NUMBQP(0,1),NUMBQP(0,1),
     *                                C_UNIT,FP12PL(1,1,J),NDSTAT,
     *                                              CMPLXP,NDSTAT,
     *                                       C_ZERO,CSUM_P,NDSTAT)
C
C                First term: positive simplex
C
                DO L=1,NUMBQP(0,0)
                   DO K=1,NUMBQP(0,0)
C
                      TEMP_K=FERMFN(K,0)
                      TEMP_L=FERMFN(L,0)
C
                      IF (K.NE.L) THEN
C
                          T_TERM=-(TEMP_K     -TEMP_L)
     *                           /(EQPISO(K,0,0)-EQPISO(L,0,0))
     *
                      ELSE
C
                          T_TERM=-TEMP_K*(TEMP_K-1.0)/TEMP_T
C
                      END IF
C
                      CMPLXN(K,L)=0.5*T_TERM*FN11PL(K,L,I)
C
                   END DO
                END DO
C
                DO L=1,NUMBQP(0,1)
                   DO K=1,NUMBQP(0,1)
C
                      TEMP_K=FERMFN(K,1)
                      TEMP_L=FERMFN(L,1)
C
                      IF (K.NE.L) THEN
C
                          T_TERM=-(TEMP_K     -TEMP_L)
     *                           /(EQPISO(K,0,1)-EQPISO(L,0,1))
     *
                      ELSE
C
                          T_TERM=-TEMP_K*(TEMP_K-1.0)/TEMP_T
C
                      END IF
C
                      CMPLXP(K,L)=0.5*T_TERM*FP11PL(K,L,I)
C
                   END DO
                END DO
C
                CALL ZGEMM('N','N',NUMBQP(0,0),NUMBQP(0,0),NUMBQP(0,0),
     *                                C_UNIT,FN11PL(1,1,J),NDSTAT,
     *                                              CMPLXN,NDSTAT,
     *                                       C_UNIT,CSUM_N,NDSTAT)
C
                CALL ZGEMM('N','N',NUMBQP(0,1),NUMBQP(0,1),NUMBQP(0,1),
     *                                C_UNIT,FP11PL(1,1,J),NDSTAT,
     *                                              CMPLXP,NDSTAT,
     *                                       C_UNIT,CSUM_P,NDSTAT)
C
C                Second term: negative simplex
C
                DO L=1,NUMBQP(1,0)
                   DO K=1,NUMBQP(1,0)
C
                      TEMP_K=FERMFN(K,0)
                      TEMP_L=FERMFN(L,0)
C
                      IF (K.NE.L) THEN
C
                          T_TERM=-(TEMP_K     -TEMP_L)
     *                           /(EQPISO(K,1,0)-EQPISO(L,1,0))
     *
                      ELSE
C
                          T_TERM=-TEMP_K*(TEMP_K-1.0)/TEMP_T
C
                      END IF
C
                      CMPLXN(K,L)=0.5*T_TERM*FN11MI(K,L,I)
C
                   END DO
                END DO
C
                DO L=1,NUMBQP(1,1)
                   DO K=1,NUMBQP(1,1)
C
                      TEMP_K=FERMFN(K,1)
                      TEMP_L=FERMFN(L,1)
C
                      IF (K.NE.L) THEN
C
                          T_TERM=-(TEMP_K     -TEMP_L)
     *                           /(EQPISO(K,1,1)-EQPISO(L,1,1))
     *
                      ELSE
C
                          T_TERM=-TEMP_K*(TEMP_K-1.0)/TEMP_T
C
                      END IF
C
                      CMPLXP(K,L)=0.5*T_TERM*FP11MI(K,L,I)
C
                   END DO
                END DO
C
                CALL ZGEMM('N','N',NUMBQP(1,0),NUMBQP(1,0),NUMBQP(1,0),
     *                                C_UNIT,FN11MI(1,1,J),NDSTAT,
     *                                              CMPLXN,NDSTAT,
     *                                       C_UNIT,CSUM_N,NDSTAT)
C
                CALL ZGEMM('N','N',NUMBQP(1,1),NUMBQP(1,1),NUMBQP(1,1),
     *                                C_UNIT,FP11MI(1,1,J),NDSTAT,
     *                                              CMPLXP,NDSTAT,
     *                                       C_UNIT,CSUM_P,NDSTAT)
C
            END IF
C
C            Taking the trace of the resulting matrix
C
            RESULT=R_ZERO
            DO L=1,NUMBQP(0,0)
               RESULT=RESULT+REAL(CSUM_N(L,L))
            END DO
            DO L=1,NUMBQP(0,1)
               RESULT=RESULT+REAL(CSUM_P(L,L))
            END DO
C
CCD     to be checked, what this factor 1/2 means;
            CNSMAT(I,J)=RESULT ! Two simplex blocks, but factor 1/2
C
         END DO
C
      END DO
C
C      Computing the inverse of the correlation matrix
C
      IERROR=0
C
      CALL DGETRF(NOFCNS,NOFCNS,CNSMAT,NDCONS,IPIVOT,IERROR)
C
      IERROR=0
C
      CALL DGETRI(NOFCNS,CNSMAT,NDCONS,IPIVOT,WORKCN,NDCONS,IERROR)
C
C      Constructing the vector of variations of the linear constraints
C
      CALL DGEMV('N',NOFCNS,NOFCNS,R_UNIT,CNSMAT,NDCONS,CNSVEC,1,
     *                                           R_ZERO,WORKCN,1)
C
C      Updating the linear constraint vector (mixing has to be done
C      simultaneously).
C
      IF (NUMITE.EQ.0) THEN
          BRAKEV=0.0
          BRAKOD=0.0
      ELSE
          BRAKEV=SLOWEV
          BRAKOD=SLOWOD
      END IF
C
CLP@+ This loop moved from the conditional below
        do i=1,nofcns
                     VECCNS(I)=VECLAM(I)+WORKCN(I)
        enddo
CLP@-
C
      IF (IBROYD.LT.1.OR.MIXMAT.EQ.1) THEN
C
          DO I=1,NOFCNS
C
             LAMACT=LAMCNS(I)
             MIUACT=MIUCNS(I)
C
CLP@+
C             VECCNS(I)=VECLAM(I)+WORKCN(I)
CLP@-
C
C             Regular multipole moments
             IF (LAMACT.GE.1.AND.MIUACT.GE.0) THEN
                 GALMUQ(LAMACT,MIUACT)=BRAKEV *VECOLD(I)
     *                           +(1.0-BRAKEV)*VECCNS(I)
             END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C             Constraint on the size of the neck
             IF (LAMACT.EQ.0.AND.MIUACT.EQ.0) THEN
                 G_NECK=BRAKOD*VECOLD(I)+(1.0-BRAKOD)*VECCNS(I)
             END IF
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
          END DO
C
      END IF
C
C=======================================================================
      DEALLOCATE(FN12PL,FP12PL,FN11PL,FP11PL,FN11MI,FP11MI)
      DEALLOCATE(ELEMUL,CPLMUL)
      DEALLOCATE(CMPLXN,CMPLXP,CSUM_N,CSUM_P)
C=======================================================================
C
      CALL CPUTIM('QMULCM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NUMCON(IF_RPA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
c       subroutine calculates number of linear constraints used in the
c       RPA moments calculations (NOFCNS) and creates arrays LAMCNS     and
c       MIUCNS; the neck constraint is also added
c       called in the main program after the line
c       "C REMOVED INTERFACES 170407"
C
C
      COMMON /CNSCOR/ LAMCNS(1:NDCONS),MIUCNS(1:NDCONS)
     *       /CNSNUM/ NOFCNS
      COMMON /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON /NCKFLA/ IFNECK
C
C=======================================================================
C
      NOFCNS=0
C
C
      IF (IF_RPA.GE.1) THEN
          ICOUNT=0
          DO LAMBDA=0,NDMULT
             DO MIU=0,LAMBDA
C
                IF (IFLALQ(LAMBDA,MIU).EQ.-1) THEN
                    ICOUNT=ICOUNT+1
                    LAMCNS(ICOUNT)=LAMBDA
                    MIUCNS(ICOUNT)=MIU
CLP@+           print *, "numcon", IF_RPA,icount,lambda,miu
C
CLP@-
                END IF
             END DO
          END DO
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C          Additional constraint on the number of particles in the neck
C
                           NOFCNS=ICOUNT
          IF (IFNECK.EQ.2) NOFCNS=NOFCNS+1
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
      END IF
        return
        end
C
      SUBROUTINE QCNTRS(NMUCON,EMULCO,EMUSLO,EMUREA,IF_RPA,ITWCEN)
C=======================================================================
      USE hfodd_sizes
      USE hfodd_fission_fragments
C=======================================================================
      DIMENSION
     *                QMUL_V(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VCNSTR/ STIFFV(0:NDMULT,-NDMULT:NDMULT),
     *                VASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /GCNSTR/ STIFFG(0:NDMULT),
     *                GASKED(0:NDMULT),
     *                IFLAGG(0:NDMULT)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
     *       /NCKFLA/ IFNECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /QMUTWC/ QFRA_N(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QFRA_P(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QFRA_T(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
      COMMON
     *       /QTWCNS/ STQTWC(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                QTWCAS(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                IFLQTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE),
     *                GALMTW(0:NDMULT,-NDMULT:NDMULT,1:NDTWCE)
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE ENERGY CONTRIBUTIONS ASSOCIATED
C       WITH THE MULTIPOLE CONSTRAINTS.
C=======================================================================
C
      QMUL_V(:,:)=QMUL_N(:,:)-QMUL_P(:,:)
C
      EMULCO=0.0D0
      EMUSLO=0.0D0
      EMUREA=0.0D0
C
      DO LAMBDA=0,NMUCON
C
         RESULT=0.0D0
C
         DO MIU=-LAMBDA,LAMBDA
C
            NIU=IABS(MIU)
C
            RESULT=RESULT+(QMUL_T(LAMBDA,MIU)/QUNITS(LAMBDA,NIU))**2
C
         END DO
C
         GMUL_T=SQRT(RESULT)*QUNITS(LAMBDA,0)
C
         DO MIU=-LAMBDA,LAMBDA
C
C=======================================================================
C           QUADRATIC CONSTRAINTS
C=======================================================================
C
            IF (IFLAGQ(LAMBDA,MIU).EQ.1) THEN
C
C                Quadratic constraints only added if the RPA
C                multiconstraint method is not employed
C
                IF (IF_RPA.NE.1) THEN
C
                    EMULCO=EMULCO
     *                + (QMUL_T(LAMBDA,MIU) - QASKED(LAMBDA,MIU))**2
     *                                      * STIFFQ(LAMBDA,MIU)
                    EMUSLO=EMUSLO
     *                - (QMUL_T(LAMBDA,MIU) - QASKED(LAMBDA,MIU))
     *                *                       STIFFQ(LAMBDA,MIU)*2.0D0
C
                    EMUREA=EMUREA
     *                + (QMUL_T(LAMBDA,MIU) - QASKED(LAMBDA,MIU))
     *                *  QMUL_T(LAMBDA,MIU) * STIFFQ(LAMBDA,MIU)
C
                END IF
C
C=======================================================================
C           LINEAR CONSTRAINTS
C=======================================================================
C
                IF (ABS(IFLALQ(LAMBDA,MIU)).EQ.1) THEN
C
                    EMULCO=EMULCO
     *                    -  GALMUQ(LAMBDA,MIU)
     *                    * (QMUL_T(LAMBDA,MIU) - QASKED(LAMBDA,MIU))
C
                    EMUSLO=EMUSLO
     *                    +  GALMUQ(LAMBDA,MIU) * QMUL_T(LAMBDA,MIU)
C
                    EMUREA=EMUREA
     *                    -  GALMUQ(LAMBDA,MIU) * QMUL_T(LAMBDA,MIU)/2
C
C=======================================================================
C               UPDATE THE LAGRANGE MULTIPLIER ESTIMATES
C=======================================================================
C
                    IF (IFLALQ(LAMBDA,MIU).EQ.1.AND.IF_RPA.NE.1) THEN
C
                        GALMUQ(LAMBDA,MIU)=GALMUQ(LAMBDA,MIU)
     *                       - (QMUL_T(LAMBDA,MIU) - QASKED(LAMBDA,MIU))
     *                       *  STIFFQ(LAMBDA,MIU)*2.0D0
C
                    END IF
C
                END IF
C
            END IF
C
            IF (IFLAGV(LAMBDA,MIU).EQ.1) THEN
C
C                Quadratic constraints only added if the RPA
C                multiconstraint method is not employed
C
                IF (IF_RPA.NE.1) THEN
C
                    EMULCO=EMULCO
     *                + (QMUL_V(LAMBDA,MIU) - VASKED(LAMBDA,MIU))**2
     *                                      * STIFFV(LAMBDA,MIU)
                    EMUSLO=EMUSLO
     *                - (QMUL_V(LAMBDA,MIU) - VASKED(LAMBDA,MIU))
     *                *                       STIFFV(LAMBDA,MIU)*2.0D0
C
                    EMUREA=EMUREA
     *                + (QMUL_V(LAMBDA,MIU) - VASKED(LAMBDA,MIU))
     *                *  QMUL_V(LAMBDA,MIU) * STIFFV(LAMBDA,MIU)
C
                END IF
C
C=======================================================================
C           LINEAR CONSTRAINTS
C=======================================================================
C
                IF (ABS(IFLALV(LAMBDA,MIU)).EQ.1) THEN
C
                    EMULCO=EMULCO
     *                    -  GALMUV(LAMBDA,MIU)
     *                    * (QMUL_V(LAMBDA,MIU) - VASKED(LAMBDA,MIU))
C
                    EMUSLO=EMUSLO
     *                    +  GALMUV(LAMBDA,MIU) * QMUL_V(LAMBDA,MIU)
C
                    EMUREA=EMUREA
     *                    -  GALMUV(LAMBDA,MIU) * QMUL_V(LAMBDA,MIU)/2
C
C=======================================================================
C               UPDATE THE LAGRANGE MULTIPLIER ESTIMATES
C=======================================================================
C
                    IF (IFLALV(LAMBDA,MIU).EQ.1.AND.IF_RPA.NE.1) THEN
C
                        GALMUV(LAMBDA,MIU)=GALMUV(LAMBDA,MIU)
     *                       - (QMUL_V(LAMBDA,MIU) - VASKED(LAMBDA,MIU))
     *                       *  STIFFV(LAMBDA,MIU)*2.0D0
C
                    END IF
C
                END IF
C
            END IF
C
C=======================================================================
C        TWO-CENTER FRAGMENTS
C=======================================================================
C
            IF (ITWCEN.EQ.2) THEN
C
                DO LTWCEN=1,ITWCEN
C
                   IF (IFLQTW(LAMBDA,MIU,LTWCEN).EQ.1) THEN
C
                   EMUREA=EMUREA
     *         + (QFRA_T(LAMBDA,MIU,LTWCEN) - QTWCAS(LAMBDA,MIU,LTWCEN))
     *         *  QFRA_T(LAMBDA,MIU,LTWCEN) * STQTWC(LAMBDA,MIU,LTWCEN)
     *           -GALMTW(LAMBDA,MIU,LTWCEN)*QFRA_T(LAMBDA,MIU,LTWCEN)/2
C
                   GALMTW(LAMBDA,MIU,LTWCEN)= GALMTW(LAMBDA,MIU,LTWCEN)
     *        - (QFRA_T(LAMBDA,MIU,LTWCEN)  - QTWCAS(LAMBDA,MIU,LTWCEN))
     *                               *  STQTWC(LAMBDA,MIU,LTWCEN)*2.0D0
C
                   END IF
C
                END DO
C
            END IF
C
         END DO
C
C=======================================================================
C        SCALAR CONSTRAINTS
C=======================================================================
C
         IF (IFLAGG(LAMBDA).EQ.1) THEN
C
             EMULCO=EMULCO
     *             + (GMUL_T - GASKED(LAMBDA))**2
     *                       * STIFFG(LAMBDA)
             EMUSLO=EMUSLO
     *             - (GMUL_T - GASKED(LAMBDA))
     *             *           STIFFG(LAMBDA)*2.0D0
C
             EMUREA=EMUREA
     *             + (GMUL_T - GASKED(LAMBDA))
     *             *  GMUL_T * STIFFG(LAMBDA)
C
         END IF
C
      END DO
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C=======================================================================
C      GAUSSIAN CONSTRAINT ON THE NECK
C=======================================================================
C
      IF (IFNECK.EQ.2) THEN
C
          EMULCO = EMULCO - G_NECK*(Q_NECK - Q0NECK)
C
          EMUSLO = EMUSLO + G_NECK* Q_NECK
C
          EMUREA = EMUREA - G_NECK* Q_NECK*0.5D0
C
      END IF
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SCNTRS(NSICON,ESIFCO,ESISLO,ESIREA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SCNSTR/ STIFFS(0:NDMULT,-NDMULT:NDMULT),
     *                SASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE ENERGY CONTRIBUTIONS ASSOCIATED
C       WITH THE SURFACE OR SCHIFF CONSTRAINTS.
C=======================================================================
C
      ESIFCO=0.0D0
      ESISLO=0.0D0
      ESIREA=0.0D0
C
      DO LAMBDA=0,NSICON
         DO MIU=-LAMBDA,LAMBDA
C
C=======================================================================
C           QUADRATIC CONSTRAINTS FOR TOTAL MOMENTS
C=======================================================================
C
            IF (IFLAGS(LAMBDA,MIU).EQ.1) THEN
C
                ESIFCO=ESIFCO
     *                + (SMUL_T(LAMBDA,MIU) - SASKED(LAMBDA,MIU))**2
     *                                      * STIFFS(LAMBDA,MIU)
                ESISLO=ESISLO
     *                - (SMUL_T(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                *                       STIFFS(LAMBDA,MIU)*2.0D0
C
                ESIREA=ESIREA
     *                + (SMUL_T(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                *  SMUL_T(LAMBDA,MIU) * STIFFS(LAMBDA,MIU)
C
C=======================================================================
C           LINEAR CONSTRAINTS FOR TOTAL MOMENTS
C=======================================================================
C
                IF (ABS(IFLALS(LAMBDA,MIU)).EQ.1) THEN
C
                    ESIFCO=ESIFCO
     *                    -  GALMUS(LAMBDA,MIU)
     *                    * (SMUL_T(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
C
                    ESISLO=ESISLO
     *                    +  GALMUS(LAMBDA,MIU) * SMUL_T(LAMBDA,MIU)
C
                    ESIREA=ESIREA
     *                     - GALMUS(LAMBDA,MIU) * SMUL_T(LAMBDA,MIU)/2
C
C=======================================================================
C               UPDATE THE LAGRANGE MULTIPLIER ESTIMATES
C=======================================================================
C
                    IF (IFLALS(LAMBDA,MIU).EQ.1) THEN
C
                        GALMUS(LAMBDA,MIU)=GALMUS(LAMBDA,MIU)
     *                    - (SMUL_T(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                    *  STIFFS(LAMBDA,MIU)*2.0D0
C
                    END IF
                END IF
            END IF
C
C=======================================================================
C           QUADRATIC CONSTRAINTS FOR NEUTRON MOMENTS
C=======================================================================
C
            IF (IFLAGS(LAMBDA,MIU).EQ.2) THEN
C
                ESIFCO=ESIFCO
     *                + (SMUL_N(LAMBDA,MIU) - SASKED(LAMBDA,MIU))**2
     *                                      * STIFFS(LAMBDA,MIU)
                ESISLO=ESISLO
     *                - (SMUL_N(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                *                       STIFFS(LAMBDA,MIU)*2.0D0
C
                ESIREA=ESIREA
     *                + (SMUL_N(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                *  SMUL_N(LAMBDA,MIU) * STIFFS(LAMBDA,MIU)
C
C=======================================================================
C           LINEAR CONSTRAINTS FOR NEUTRON MOMENTS
C=======================================================================
C
                IF (ABS(IFLALS(LAMBDA,MIU)).EQ.2) THEN
C
                    ESIFCO=ESIFCO
     *                    -  GALMUS(LAMBDA,MIU)
     *                    * (SMUL_N(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
C
                    ESISLO=ESISLO
     *                    +  GALMUS(LAMBDA,MIU) * SMUL_N(LAMBDA,MIU)
C
                    ESIREA=ESIREA
     *                     - GALMUS(LAMBDA,MIU) * SMUL_N(LAMBDA,MIU)/2
C
C=======================================================================
C               UPDATE THE LAGRANGE MULTIPLIER ESTIMATES
C=======================================================================
C
                    IF (IFLALS(LAMBDA,MIU).EQ.2) THEN
C
                        GALMUS(LAMBDA,MIU)=GALMUS(LAMBDA,MIU)
     *                    - (SMUL_N(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                    *  STIFFS(LAMBDA,MIU)*2.0D0
C
                    END IF
                END IF
            END IF
C
C=======================================================================
C           QUADRATIC CONSTRAINTS FOR PROTON MOMENTS
C=======================================================================
C
            IF (IFLAGS(LAMBDA,MIU).EQ.3) THEN
C
                ESIFCO=ESIFCO
     *                + (SMUL_P(LAMBDA,MIU) - SASKED(LAMBDA,MIU))**2
     *                                      * STIFFS(LAMBDA,MIU)
                ESISLO=ESISLO
     *                - (SMUL_P(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                *                       STIFFS(LAMBDA,MIU)*2.0D0
C
                ESIREA=ESIREA
     *                + (SMUL_P(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                *  SMUL_P(LAMBDA,MIU) * STIFFS(LAMBDA,MIU)
C
C=======================================================================
C           LINEAR CONSTRAINTS FOR PROTON MOMENTS
C=======================================================================
C
                IF (ABS(IFLALS(LAMBDA,MIU)).EQ.3) THEN
C
                    ESIFCO=ESIFCO
     *                    -  GALMUS(LAMBDA,MIU)
     *                    * (SMUL_P(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
C
                    ESISLO=ESISLO
     *                    +  GALMUS(LAMBDA,MIU) * SMUL_P(LAMBDA,MIU)
C
                    ESIREA=ESIREA
     *                     - GALMUS(LAMBDA,MIU) * SMUL_P(LAMBDA,MIU)/2
C
C=======================================================================
C               UPDATE THE LAGRANGE MULTIPLIER ESTIMATES
C=======================================================================
C
                    IF (IFLALS(LAMBDA,MIU).EQ.3) THEN
C
                        GALMUS(LAMBDA,MIU)=GALMUS(LAMBDA,MIU)
     *                    - (SMUL_P(LAMBDA,MIU) - SASKED(LAMBDA,MIU))
     *                    *  STIFFS(LAMBDA,MIU)*2.0D0
C
                    END IF
                END IF
            END IF
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ICNTRS(ITILAX,ITISAX,XOLDOD,ESPICO,ESPSLO,ESPREA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /ICNSTR/ STIFFI(1:NDKART),
     *                ASKEDI(1:NDKART),
     *                IFLAGI(1:NDKART)
      COMMON
     *       /ICNTTR/ STIFTI(1:NDKART),
     *                ASKETI(1:NDKART),
     *                IFTAGI(1:NDKART)
      COMMON
     *       /ILASTR/ GALSPI(1:NDKART),
     *                DALSPI(1:NDKART),
     *                IFLALI(1:NDKART)
      COMMON
     *       /ACNSTR/ STIFFA,ASKEDA,IFLAGA
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /OMEGAS/ OMEGAX,OMEGAY,OMEGAZ
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /ITERTS/ ITESTA,ITESTO,NOITER,NUMITE
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE ENERGY CONTRIBUTIONS  ASSOCIATED
C       WITH THE SPIN CONSTRAINT.
C=======================================================================
C       ESPSLO HAS THE MEANING OF THE ENERGY DERIVATIVE WITH RESPECT TO
C       SPIN IF ONLY  O N E  OMEGA IS NOT EQUAL TO ZERO.
C=======================================================================
C
C       IFLAGI = 0  -  LINEAR               CONSTRAINT ON SPIN
C       IFLAGI = 1  -  LINEAR AND QUADRATIC CONSTRAINT ON SPIN
C
C       IFTAGI = 0  -  LINEAR               ISOVECTOR CONSTRAINT ON SPIN
C       IFTAGI = 1  -  LINEAR AND QUADRATIC ISOVECTOR CONSTRAINT ON SPIN
C
C=======================================================================
C
C=======================================================================
C       AUGMENTED LAGRANGE METHOD FOR THE SPIN CONSTRAINT
C=======================================================================
C
      IF (IFLALI(1).EQ.1) THEN
C
          GALSPI(1)=GALSPI(1)-2*STIFFI(1)*(ANGU_T(1)-ASKEDI(1))
     *                                                   *(1.0D0-XOLDOD)
          OMOVAX=OMEGAX+GALSPI(1)
C
      END IF
C
      IF (IFLALI(2).EQ.1) THEN
C
          GALSPI(2)=GALSPI(2)-2*STIFFI(2)*(ANGU_T(2)-ASKEDI(2))
     *                                                   *(1.0D0-XOLDOD)
          OMOVAY=OMEGAY+GALSPI(2)
C
      END IF
C
      IF (IFLALI(3).EQ.1) THEN
C
          GALSPI(3)=GALSPI(3)-2*STIFFI(3)*(ANGU_T(3)-ASKEDI(3))
     *                                                   *(1.0D0-XOLDOD)
          OMOVAZ=OMEGAZ+GALSPI(3)
C
      END IF
C
C=======================================================================
C       LINEAR CONSTRAINT
C=======================================================================
C
      ESPICO=-OMOVAY*(ANGU_N(2)+ANGU_P(2))-OMISOY*(ANGU_N(2)-ANGU_P(2))
      ESPSLO= OMOVAY+OMISOY
C
      IF (ITILAX.NE.0) THEN
C
          ESPICO=ESPICO-OMOVAX*(ANGU_N(1)+ANGU_P(1))
     *                 -OMOVAZ*(ANGU_N(3)+ANGU_P(3))
          ESPSLO=ESPSLO+OMOVAX+OMOVAZ
C
      END IF
C
      IF (ITISAX.NE.0) THEN
C
          ESPICO=ESPICO-OMISOX*(ANGU_N(1)-ANGU_P(1))
     *                 -OMISOZ*(ANGU_N(3)-ANGU_P(3))
          ESPSLO=ESPSLO+OMISOX+OMISOZ
C
      END IF
C
      ESPREA=ESPICO/2
C
C=======================================================================
C       QUADRATIC CONSTRAINT
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         IF (IFLAGI(KARTEZ).NE.0) THEN
C
             ESPREA=ESPREA+STIFFI(KARTEZ)*ANGU_T(KARTEZ)*
     *                    (ANGU_T(KARTEZ)-ASKEDI(KARTEZ))
             ESPICO=ESPICO+STIFFI(KARTEZ)*
     *                    (ANGU_T(KARTEZ)-ASKEDI(KARTEZ))**2
             ESPSLO=ESPSLO-2*STIFFI(KARTEZ)*
     *                    (ANGU_T(KARTEZ)-ASKEDI(KARTEZ))
C
         END IF
C
         IF (IFTAGI(KARTEZ).NE.0) THEN
C
             ESPREA=ESPREA+STIFTI(KARTEZ)*
     *                    (ANGU_N(KARTEZ)-ANGU_P(KARTEZ))*
     *                    (ANGU_N(KARTEZ)-ANGU_P(KARTEZ)-ASKETI(KARTEZ))
             ESPICO=ESPICO+STIFTI(KARTEZ)*
     *                    (ANGU_N(KARTEZ)-ANGU_P(KARTEZ)-ASKETI(KARTEZ))
     *                                                               **2
             ESPSLO=ESPSLO-2*STIFTI(KARTEZ)*
     *                    (ANGU_N(KARTEZ)-ANGU_P(KARTEZ)-ASKETI(KARTEZ))
C
         END IF
C
      END DO
C
C=======================================================================
C       QUADRATIC CONSTRAINT ON PRODUCT OMEGA TIMES SPIN
C=======================================================================
C
      IF (IFLAGA.NE.0) THEN
C
          OMEGAT=OMOVAX**2+OMOVAY**2+OMOVAZ**2
C
          OMEGAJ=OMOVAX*ANGU_T(1)+
     *           OMOVAY*ANGU_T(2)+
     *           OMOVAZ*ANGU_T(3)
C
          ANGUTT=ANGU_T(1)**2+ANGU_T(2)**2+ANGU_T(3)**2
C
          ESPREA=ESPREA+STIFFA*(OMEGAT*ANGUTT-OMEGAJ**2)/OMEGAT
C
          ESPICO=ESPICO+STIFFA*(OMEGAT*ANGUTT-OMEGAJ**2)/OMEGAT
C
          ESPSLO=ESPSLO-2*STIFFA*(ANGU_T(1)*OMEGAT
     *                           -OMOVAX   *OMEGAJ)/OMEGAT
          ESPSLO=ESPSLO-2*STIFFA*(ANGU_T(2)*OMEGAT
     *                           -OMOVAY   *OMEGAJ)/OMEGAT
          ESPSLO=ESPSLO-2*STIFFA*(ANGU_T(3)*OMEGAT
     *                           -OMOVAZ   *OMEGAJ)/OMEGAT
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TCNTRS(XOLDEV,XOLDOD,EISOCO,EISSLO,EISREA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /TCNSTR/ STIFFT(1:NDKART),
     *                ASKEDT(1:NDKART),
     *                IFLAGT(1:NDKART)
      COMMON
     *       /TLASTR/ GALISO(1:NDKART),
     *                DALISO(1:NDKART),
     *                IFLALT(1:NDKART)
      COMMON
     *       /ISOFER/ FERISO(0:NDKART)
      COMMON
     *       /MOVFER/ FERMOV(0:NDKART)
      COMMON
     *       /ISOTOT/ TOTISO(0:NDKART),TOTIS2(0:NDKART)
      COMMON
     *       /ITERTS/ ITESTA,ITESTO,NOITER,NUMITE
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE ENERGY CONTRIBUTIONS  ASSOCIATED
C       WITH THE ISOSPIN CONSTRAINT.
C=======================================================================
C       EISSLO HAS THE MEANING OF THE ENERGY DERIVATIVE WITH RESPECT TO
C       ISOSPIN IF ONLY  O N E  FERMI ENERGY IS NOT EQUAL TO ZERO.
C=======================================================================
C
C       IFLAGT = 0  -  LINEAR               CONSTRAINT ON ISOSPIN
C       IFLAGT = 1  -  LINEAR AND QUADRATIC CONSTRAINT ON ISOSPIN
C
C=======================================================================
C       ATTENTION! THE CODE USES  LINEAR  CONSTRAINTS  CORRESPONDING  TO
C                             S T A N D A R D   I S O S P I N
C                  THAT IS, CONSTRAINING TERM IN THE  Z-DIRECTION  READS
C                  -FERISO(3)*(IN_FIX-IZ_FIX)/2 = -FERISO(3)*TOTISO(3)
C                  THIS IS DONE TO KEEP THE CONSISTENCY WITH DEFINITIONS
C                  GIVEN IN 1308.1997  BUT  BREAKS  THE  SYMMETRY  WITH
C                  RESPECT TO THE ISOSCALAR CONSTRAINT, WHICH DEPENDS ON
C                  THE ISOSCALAR FERMI ENERGY AS:
C                               -FERISO(0)*(IN_FIX+IZ_FIX)
C                  THAT IS, IT DOES  NOT  CONTAIN  THE  FACTOR  OF  1/2.
C                  THEREFORE, THE FACTORS OF 1/2 MUST EXPLICITLY  APPEAR
C                  WHENEVER THE ISOVECTOR FERMI ENERGIES ARE USED IN THE
C                  MEAN FIELDS.
C=======================================================================
C
C=======================================================================
C       AUGMENTED LAGRANGE METHOD FOR THE ISOSPIN CONSTRAINT
C=======================================================================
C
         IF (IFLALT(1).EQ.1) THEN
C
             GALISO(1)=GALISO(1)-2*STIFFT(1)*(TOTISO(1)-ASKEDT(1))
     *                                                   *(1.0D0-XOLDEV)
             FERMOV(1)=FERISO(1)+GALISO(1)
C
         END IF
C
         IF (IFLALT(2).EQ.1) THEN
C
             GALISO(2)=GALISO(2)-2*STIFFT(2)*(TOTISO(2)-ASKEDT(2))
     *                                                   *(1.0D0-XOLDOD)
             FERMOV(2)=FERISO(2)+GALISO(2)
C
         END IF
C
         IF (IFLALT(3).EQ.1) THEN
C
             GALISO(3)=GALISO(3)-2*STIFFT(3)*(TOTISO(3)-ASKEDT(3))
     *                                                   *(1.0D0-XOLDEV)
             FERMOV(3)=FERISO(3)+GALISO(3)
C
         END IF
C
C=======================================================================
C       LINEAR CONSTRAINT
C=======================================================================
C
      EISOCO=0.0D0
      EISSLO=0.0D0
C
      DO KARTEZ=1,NDKART
C
         EISOCO=EISOCO-FERMOV(KARTEZ)*TOTISO(KARTEZ)
         EISSLO=EISSLO+FERMOV(KARTEZ)
C
      END DO
C
      EISREA=EISOCO/2
C
C=======================================================================
C       QUADRATIC CONSTRAINT
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         IF (IFLAGT(KARTEZ).NE.0) THEN
C
             EISREA=EISREA+STIFFT(KARTEZ)*TOTISO(KARTEZ)*
     *                    (TOTISO(KARTEZ)-ASKEDT(KARTEZ))
             EISOCO=EISOCO+STIFFT(KARTEZ)*
     *                    (TOTISO(KARTEZ)-ASKEDT(KARTEZ))**2
             EISSLO=EISSLO-2*STIFFT(KARTEZ)*
     *                    (TOTISO(KARTEZ)-ASKEDT(KARTEZ))
C
         END IF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTCON(ISIMPY,ICHARG,ISCHIF,NMUCON,NSICON,
     *                                HPPCON,HPMCON,IF_RPA)
C=======================================================================
      USE hfodd_sizes
      USE hfodd_twocen
C=======================================================================
      DIMENSION
     *          HPPCON(1:NDBASE,1:NDBASE),
     *          HPMCON(1:NDBASE,1:NDBASE)
C=======================================================================
      ALLOCATABLE ELEMUL(:,:)
      ALLOCATABLE ELESIF(:,:)
C=======================================================================
      DIMENSION
     *          CMUL_T(0:NDMULT,-NDMULT:NDMULT),
     *          FACSIF(0:NDMULT,-NDMULT:NDMULT),
     *          FACMUL(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          CMUL_V(0:NDMULT,-NDMULT:NDMULT),
     *          QMUL_V(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VCNSTR/ STIFFV(0:NDMULT,-NDMULT:NDMULT),
     *                VASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SCNSTR/ STIFFS(0:NDMULT,-NDMULT:NDMULT),
     *                SASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /GCNSTR/ STIFFG(0:NDMULT),
     *                GASKED(0:NDMULT),
     *                IFLAGG(0:NDMULT)
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VLASTR/ GALMUV(0:NDMULT,-NDMULT:NDMULT),
     *                VLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALV(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SLASTR/ GALMUS(0:NDMULT,-NDMULT:NDMULT),
     *                SLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALS(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (ELEMUL(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELEMUL','INTCON')
      ALLOCATE (ELESIF(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELESIF','INTCON')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE MULTIPOLE-MOMENT,
C       SURFACE-MOMENT AND SCHIFF-MOMENT CONSTRAINING FIELDS
C=======================================================================
C
      QMUL_V(:,:)=QMUL_N(:,:)-QMUL_P(:,:)
C
      HPPCON(:,:)=0.0D0
      HPMCON(:,:)=0.0D0
      ELEMUL(:,:)=0.0D0
      ELESIF(:,:)=0.0D0
C
C=======================================================================
C        CALCULATING THE COEFFICIENTS THAT IN THE CONSTRAINT TERMS
C        MULTIPLY THE MULTIPOLE MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NMUCON
C
         RESULT=0.0D0
C
         DO MIU=-LAMBDA,LAMBDA
            NIU=IABS(MIU)
            RESULT=RESULT+(QMUL_T(LAMBDA,MIU)/QUNITS(LAMBDA,NIU))**2
         END DO
C
         GMUL_T=SQRT(RESULT)*QUNITS(LAMBDA,0)
C
         DO MIU=-LAMBDA,LAMBDA
C
            NIU=IABS(MIU)
C
            CMUL_T(LAMBDA,MIU)=0.0D0
C
            IF (IFLAGQ(LAMBDA,MIU).EQ.1) THEN
C
                IF (IF_RPA.NE.1)
     *              CMUL_T(LAMBDA,MIU)=CMUL_T(LAMBDA,MIU)
     *                +2.0D0*(QMUL_T(LAMBDA,MIU)-QASKED(LAMBDA,MIU))
     *                      * STIFFQ(LAMBDA,MIU)
C
                IF (ABS(IFLALQ(LAMBDA,MIU)).EQ.1)
     *
     *              CMUL_T(LAMBDA,MIU)=CMUL_T(LAMBDA,MIU)
     *                                -GALMUQ(LAMBDA,MIU)
C
            END IF
C
            IF (IFLAGG(LAMBDA).EQ.1.AND.GMUL_T.GT.0)
     *
     *          CMUL_T(LAMBDA,MIU)=CMUL_T(LAMBDA,MIU)
     *                +2.0D0*(GMUL_T            -GASKED(LAMBDA))
     *                      * STIFFG(LAMBDA)
     *                      * QMUL_T(LAMBDA,MIU)/GMUL_T
     *                      * QUNITS(LAMBDA, 0 )**2
     *                      / QUNITS(LAMBDA,NIU)**2
C
            CMUL_V(LAMBDA,MIU)=0.0D0
C
            IF (IFLAGV(LAMBDA,MIU).EQ.1) THEN
C
                IF (IF_RPA.NE.1)
     *              CMUL_V(LAMBDA,MIU)=CMUL_V(LAMBDA,MIU)
     *                +2.0D0*(QMUL_V(LAMBDA,MIU)-VASKED(LAMBDA,MIU))
     *                      * STIFFV(LAMBDA,MIU)
C
                IF (ABS(IFLALV(LAMBDA,MIU)).EQ.1)
     *
     *              CMUL_V(LAMBDA,MIU)=CMUL_V(LAMBDA,MIU)
     *                                -GALMUV(LAMBDA,MIU)
C
            END IF
C
         END DO
C
      END DO
C
C=======================================================================
C        CALCULATING THE COEFFICIENTS THAT IN THE CONSTRAINT TERMS
C        MULTIPLY THE SURFACE OR SCHIFF MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NSICON
         DO MIU=-LAMBDA,LAMBDA
C
            FACSIF(LAMBDA,MIU)=0.0D0
            FACMUL(LAMBDA,MIU)=0.0D0
C
C=======================================================================
C           FACTORS FOR CONSTRAINTS ON MASS MOMENTS
C=======================================================================
C
            IF (IFLAGS(LAMBDA,MIU).EQ.1) THEN
C
                FACSIF(LAMBDA,MIU)=2.0D0*(SMUL_T(LAMBDA,MIU)
     *                                   -SASKED(LAMBDA,MIU))
     *                                   *STIFFS(LAMBDA,MIU)
C
                IF (ABS(IFLALS(LAMBDA,MIU)).EQ.1)
     *
     *              FACSIF(LAMBDA,MIU)=FACSIF(LAMBDA,MIU)
     *                                -GALMUS(LAMBDA,MIU)
C
                IF (ISCHIF.EQ.1)
     *
     *          FACMUL(LAMBDA,MIU)=-5.0D0/3.0D0*SMUL_T(0,0)/QMUL_T(0,0)
     *                                   *FACSIF(LAMBDA,MIU)
C
            END IF
C
C=======================================================================
C           FACTORS FOR CONSTRAINTS ON NEUTRON MOMENTS
C=======================================================================
C
            IF (IFLAGS(LAMBDA,MIU).EQ.2.AND.ICHARG.EQ.0) THEN
C
                FACSIF(LAMBDA,MIU)=2.0D0*(SMUL_N(LAMBDA,MIU)
     *                                   -SASKED(LAMBDA,MIU))
     *                                   *STIFFS(LAMBDA,MIU)
C
                IF (ABS(IFLALS(LAMBDA,MIU)).EQ.2)
     *
     *              FACSIF(LAMBDA,MIU)=FACSIF(LAMBDA,MIU)
     *                                -GALMUS(LAMBDA,MIU)
C
                IF (ISCHIF.EQ.1)
     *
     *          FACMUL(LAMBDA,MIU)=-5.0D0/3.0D0*SMUL_N(0,0)/QMUL_N(0,0)
     *                                   *FACSIF(LAMBDA,MIU)
C
            END IF
C
C=======================================================================
C           FACTORS FOR CONSTRAINTS ON PROTON MOMENTS
C=======================================================================
C
            IF (IFLAGS(LAMBDA,MIU).EQ.3.AND.ICHARG.EQ.1) THEN
C
                FACSIF(LAMBDA,MIU)=2.0D0*(SMUL_P(LAMBDA,MIU)
     *                                   -SASKED(LAMBDA,MIU))
     *                                   *STIFFS(LAMBDA,MIU)
C
                IF (ABS(IFLALS(LAMBDA,MIU)).EQ.3)
     *
     *              FACSIF(LAMBDA,MIU)=FACSIF(LAMBDA,MIU)
     *                                -GALMUS(LAMBDA,MIU)
C
                IF (ISCHIF.EQ.1)
     *
     *          FACMUL(LAMBDA,MIU)=-5.0D0/3.0D0*SMUL_P(0,0)/QMUL_P(0,0)
     *                                   *FACSIF(LAMBDA,MIU)
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        HERE WE CALCULATE CONTRIBUTIONS FROM REAL PARTS OF THE
C        MULTIPOLE MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NMUCON
         DO MIU=0,LAMBDA
C
            IF (IFLAGQ(LAMBDA,MIU).EQ.1.OR.
     *          IFLAGV(LAMBDA,MIU).EQ.1.OR.IFLAGG(LAMBDA).EQ.1) THEN
C
                IMAREA=1
C
                CALL INTMUL(IPHAPP(0,0,0),ELEMUL,COMULT,
     *                                LAMBDA,MIU,IMAREA)
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      IF (IFLAGQ(LAMBDA,MIU).EQ.1)
     *                    HPPCON(IBRA,IKET)=HPPCON(IBRA,IKET)
     *                                     +ELEMUL(IBRA,IKET)
     *                                     *CMUL_T(LAMBDA,MIU)
C
                      IF (IFLAGV(LAMBDA,MIU).EQ.1) THEN
C
                          IF (ICHARG.EQ.0)
     *                    HPPCON(IBRA,IKET)=HPPCON(IBRA,IKET)
     *                                     +ELEMUL(IBRA,IKET)
     *                                     *CMUL_V(LAMBDA,MIU)
                          IF (ICHARG.EQ.1)
     *                    HPPCON(IBRA,IKET)=HPPCON(IBRA,IKET)
     *                                     -ELEMUL(IBRA,IKET)
     *                                     *CMUL_V(LAMBDA,MIU)
                      END IF
C
                   END DO
                END DO
C
             END IF
C
         END DO
      END DO
C
C=======================================================================
C        HERE WE CALCULATE CONTRIBUTIONS FROM REAL PARTS OF THE
C        SURFACE OR SCHIFF MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NSICON
         DO MIU=0,LAMBDA
C
            IF (IFLAGS(LAMBDA,MIU).EQ.1.OR.
     *         (IFLAGS(LAMBDA,MIU).EQ.2.AND.ICHARG.EQ.0).OR.
     *         (IFLAGS(LAMBDA,MIU).EQ.3.AND.ICHARG.EQ.1)) THEN
C
                IMAREA=1
C
                CALL INTSIF(IPHAPP(0,0,0),ELESIF,COMULT,
     *                                LAMBDA,MIU,IMAREA)
C
                IF (ISCHIF.EQ.1)
     *          CALL INTMUL(IPHAPP(0,0,0),ELEMUL,COMULT,
     *                                LAMBDA,MIU,IMAREA)
C
C=======================================================================
C               INSERTING THE CONSTRAINTS
C=======================================================================
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      HPPCON(IBRA,IKET)=HPPCON(IBRA,IKET)
     *
     *                                 +ELESIF(IBRA,IKET)
     *                                               *FACSIF(LAMBDA,MIU)
     *                                 +ELEMUL(IBRA,IKET)
     *                                               *FACMUL(LAMBDA,MIU)
                   END DO
                END DO
C
             END IF
C
         END DO
      END DO
C
C=======================================================================
C        CONTRIBUTIONS FROM IMAGINARY PARTS ARE CALCULATED ONLY
C        FOR BROKEN SIMPLEX SYMMETRY
C=======================================================================
C
      IF (ISIMPY.EQ.1.OR.NMUCON.EQ.0) GO TO 2
C
C=======================================================================
C        HERE WE CALCULATE CONTRIBUTIONS FROM IMAGINARY PARTS OF THE
C        MULTIPOLE MOMENTS
C=======================================================================
C
      DO LAMBDA=1,NMUCON
         DO MIU=-LAMBDA,-1
C
            IF (IFLAGQ(LAMBDA,MIU).EQ.1.OR.
     *          IFLAGV(LAMBDA,MIU).EQ.1.OR.IFLAGG(LAMBDA).EQ.1) THEN
C
                IMAREA=-1
C
                CALL INTMUL(IPHAPM(0,0,0),ELEMUL,COMULT,
     *                                LAMBDA,MIU,IMAREA)
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      IF (IFLAGQ(LAMBDA,MIU).EQ.1)
     *                    HPMCON(IBRA,IKET)=HPMCON(IBRA,IKET)
     *                                     +ELEMUL(IBRA,IKET)
     *                                     *CMUL_T(LAMBDA,MIU)
C
                      IF (IFLAGV(LAMBDA,MIU).EQ.1) THEN
C
                          IF (ICHARG.EQ.0)
     *                    HPMCON(IBRA,IKET)=HPMCON(IBRA,IKET)
     *                                     +ELEMUL(IBRA,IKET)
     *                                     *CMUL_V(LAMBDA,MIU)
                          IF (ICHARG.EQ.1)
     *                    HPMCON(IBRA,IKET)=HPMCON(IBRA,IKET)
     *                                     -ELEMUL(IBRA,IKET)
     *                                     *CMUL_V(LAMBDA,MIU)
                      END IF
C
                   END DO
                END DO
C
             END IF
C
         END DO
      END DO
C
C=======================================================================
C        HERE WE CALCULATE CONTRIBUTIONS FROM IMAGINARY PARTS OF THE
C        SURFACE OR SCHIFF MOMENTS
C=======================================================================
C
    2 IF (ISIMPY.EQ.1.OR.NSICON.EQ.0) GO TO 1
C
C=======================================================================
C
      DO LAMBDA=1,NSICON
         DO MIU=-LAMBDA,-1
C
            IF (IFLAGS(LAMBDA,MIU).EQ.1.OR.
     *         (IFLAGS(LAMBDA,MIU).EQ.2.AND.ICHARG.EQ.0).OR.
     *         (IFLAGS(LAMBDA,MIU).EQ.3.AND.ICHARG.EQ.1)) THEN
C
                IMAREA=-1
C
                CALL INTSIF(IPHAPM(0,0,0),ELESIF,COMULT,
     *                                LAMBDA,MIU,IMAREA)
C
                IF (ISCHIF.EQ.1)
     *          CALL INTMUL(IPHAPM(0,0,0),ELEMUL,COMULT,
     *                                LAMBDA,MIU,IMAREA)
C
C=======================================================================
C               INSERTING THE CONSTRAINTS
C=======================================================================
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      HPMCON(IBRA,IKET)=HPMCON(IBRA,IKET)
     *
     *                                 +ELESIF(IBRA,IKET)
     *                                               *FACSIF(LAMBDA,MIU)
     *                                 +ELEMUL(IBRA,IKET)
     *                                               *FACMUL(LAMBDA,MIU)
                   END DO
                END DO
C
             END IF
C
         END DO
      END DO
C
C=======================================================================
C
    1 CONTINUE
C
C=======================================================================
      DEALLOCATE (ELEMUL,ELESIF)
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFUNI(NMUMAX,NSIMAX,NMAMAX,NASMAX)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /SIFUNI/ SUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /PLMUNI/ PUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /VMUUNI/ VUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /RADUNI/ RUNITS(0:NDMORD)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /ASMUNI/ BUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C       THIS SUBROUTINE DEFINES THE UNITS OF MULTIPOLE MOMENTS THAT  MAY
C       D I F F E R  FROM THE ELECTROMAGNETIC UNITS USED BY J.D. JACKSON
C       CH.4, EQ.(4.3), IN THE FOLLOWING WAY:
C
C       THE SPHERICAL HARMONICS USED BY THE PROGRAM, HAVE THE FORM  THAT
C       IS IDENTICAL WITH THOSE USED BY JACKSON AND ALSO VARSHALOVICH.
C
C       JACKSON'S MULTIPOLE MOMENTS ARE DEFINED AS  THE  AVERAGE  VALUES
C       OF THE ABOVE SPHERICAL HARMONICS. SOME OF OUR MULTIPOLE  MOMENTS
C       HAVE THE ADDITIONAL MULTIPLICATIVE FACTORS STORED FOR  DIFFERENT
C       MOMENTS IN THE ARRAYS "?UNITS".
C
C       THE COMMON UNIT OF THE AVERAGE VALUES OF X**2,  Y**2,  Z**2, AND
C       R**2 IS STORED IN "RUNITS(1)" AND THOSE OF R**(2N) ARE STORED IN
C       "RUNITS(N)".
C
C       NOTE I M P O R T A N T: THOSE UNITS ARE ONLY USED TO COMMUNICATE
C       WITH THE USER AND IMPLEMENTED BEFOR PRINTING THE RESULTS. WITHIN
C       THE BODY OF THE CODE, THE MULIPOLE MOMENTS ARE KEPT IN THE  FORM
C       OF SPHERICAL TENSORS DEFINED BY THE SPHERICAL HARMONICS.
C
C=======================================================================
C
      SQR4PI=SQRT(16.0D0*ATAN(1.0D0))
C
      IF (NMUMAX  .GT.NDMULT) STOP 'NMUMAX  .GT.NDMULT IN DEFUNI'
      IF (NSIMAX  .GT.NDMULT) STOP 'NSIMAX  .GT.NDMULT IN DEFUNI'
      IF (NMAMAX+1.GT.NDMULT) STOP 'NMAMAX+1.GT.NDMULT IN DEFUNI'
      IF (NASMAX+1.GT.NDMULT) STOP 'NASMAX+1.GT.NDMULT IN DEFUNI'
C
      DO LAMBDA=0,NDMULT
         DO MIU=0,LAMBDA
            QUNITS(LAMBDA,MIU)=1.0D0
            SUNITS(LAMBDA,MIU)=1.0D0
            PUNITS(LAMBDA,MIU)=1.0D0
            VUNITS(LAMBDA,MIU)=1.0D0
            AUNITS(LAMBDA,MIU)=1.0D0
            BUNITS(LAMBDA,MIU)=1.0D0
         END DO
      END DO
C
      RUNITS(:)=1.0D0
C
C=======================================================================
C         E X P L I C I T   D E F I N I T I O S
C=======================================================================
C
      QUNITS(0,0)=+SQR4PI
C
C=======================================================================
C     WITH THE ABOVE, OUR Q(0,0)-MOMENT GIVES THE PARTICLE NUMBER
C=======================================================================
C
      QUNITS(1,0)=+SQR4PI/SQRT(3.0D0)
      QUNITS(1,1)=-SQR4PI/SQRT(3.0D0)*SQRT(2.0D0)
C
C=======================================================================
C     WITH THE ABOVE, OUR Q(1,0), Re[Q(1,1)],  AND Im[Q(1,-1)] MOMENTS
C     GIVE THE EXPECTATION VALUES OF "Z", "X", AND "-Y",  RESPECTIVELY.
C=======================================================================
C
      QUNITS(2,0)=+SQR4PI/SQRT(5.0D0)*2.0D0
      QUNITS(2,1)=-SQR4PI/SQRT(15.D0)*SQRT(2.0D0)
      QUNITS(2,2)=+SQR4PI/SQRT(5.0D0)*2.0D0*SQRT(2.0D0)
C
C=======================================================================
C
C     ATTENTION:  IN THE PREVIOUS VERSIONS OF THE CODE, THE VALUE OF
C                 QUNITS(2,2) WAS INCORRECT, I.E., INCONSISTENT WITH
C                 THE INTENTIONS EXPRESSED IN THE COMMENTS BELOW.
C
C                 IN THE VERSION  1.67A , AND IN ALL OLDER VERSIONS,
C                 THIS VALUE WAS A SQRT(6) TOO SMALL.
C
C                 SINCE THE VERSION 1.67B AND UNTIL THE VERSION 1.74
C                 THIS VALUE WAS A SQRT(2) TOO LARGE.
C
C                 STARTING FROM THE VERSION 1.75 AND ALSO IN ALL THE
C                 BIFURCATED VERSIONS 1.70A,B,C, AND THE LATER ONES,
C                 THIS VALUE IS PRESUMED CORRECT (TILL THE NEXT BUG)
C
C=======================================================================
C
C=======================================================================
C      WITH THE ABOVE, OUR Q(2,0)-MOMENT GIVES THE EXPECTATION VALUE
C      OF "( 2*Z**2 - X**2 - Y**2 )". IN ADDITION, OUR Q(2,2)-MOMENT
C      CONTAINS THE BOHR'S SQR(2), THAT IMPLIES THAT USING THIS UNIT
C      IS EQUIVALENT TO TREATING  Q(2,+2) & Q(2,-2)), COMBINED. CON-
C      SEQUENTLY, BOHR'S "BETA = SQRT(Q(2,0)**2 + Q(2,2)**2)", WHILE
C      BOHR'S "GAMMA = ATAN (Q(2,2)/Q(2,0))".
C=======================================================================
C
C=======================================================================
C      ALL HIGHER MULTIPOLES ARE LEFT IN PEACE, SO FAR.
C=======================================================================
C
C=======================================================================
C      MOREOVER, TO MAKE ENEMIES LIFE DIFFICULT, THE MOMENTS ARE
C      CALCULATED IN UNITS OF ( 10 * FERMI ) ** LAMBDA.
C=======================================================================
C
      DO LAMBDA=0,MAX(NMUMAX,NSIMAX)
         DO MIU=0,LAMBDA
            QUNITS(LAMBDA,MIU)=QUNITS(LAMBDA,MIU) / (10.0D0)**LAMBDA
         END DO
      END DO
C
C=======================================================================
C     UNITS OF SURFACE MOMENTS ARE LEFT IDENTICAL TO THOSE OF THE
C     MULTIPOLE MOMENTS, APART FROM THE FACTOR OF 100 THAT  COMES
C     FROM THE UNITS OF ( 10 * FERMI ) ** (LAMBDA+2).
C=======================================================================
C
      DO LAMBDA=0,MAX(NMUMAX,NSIMAX)
         DO MIU=0,LAMBDA
            SUNITS(LAMBDA,MIU)=QUNITS(LAMBDA,MIU)/100.
         END DO
      END DO
C
C=======================================================================
C     UNITS OF PENSURFACE MOMENTS ARE LEFT IDENTICAL TO THOSE OF THE
C     MULTIPOLE MOMENTS, APART FROM THE FACTOR OF 10000  THAT  COMES
C     FROM THE UNITS OF ( 10 * FERMI ) ** (LAMBDA+4).
C=======================================================================
C
      DO LAMBDA=0,MAX(NMUMAX,NSIMAX)
         DO MIU=0,LAMBDA
            PUNITS(LAMBDA,MIU)=QUNITS(LAMBDA,MIU)/10000.
         END DO
      END DO
C
C=======================================================================
C     UNITS OF VECTOR MOMENTS ARE LEFT IDENTICAL TO THOSE OF THE
C     MULTIPOLE MOMENTS, APART FROM THE FACTOR OF 10  THAT COMES
C     FROM THE UNITS OF ( 10 * FERMI ) ** (LAMBDA+1).
C=======================================================================
C
      DO LAMBDA=0,MAX(NMUMAX,NSIMAX)
         DO MIU=0,LAMBDA
            VUNITS(LAMBDA,MIU)=QUNITS(LAMBDA,MIU)/10.
         END DO
      END DO
C
C=======================================================================
C     SO FAR, NO INGENIOUS UNITS HAVE BEEN INVENTED FOR MAGNETIC
C     MOMENTS APART FROM THE NUCLEAR MAGNETON, BUT WAIT A WHILE...
C=======================================================================
C
      DO LAMBDA=0,NMAMAX
         DO MIU=0,LAMBDA
            AUNITS(LAMBDA,MIU)=1.0D0
         END DO
      END DO
C
C=======================================================================
C     SO FAR, NO INGENIOUS UNITS HAVE BEEN INVENTED FOR SPIN-ASYMMETRY
C     MOMENTS APART FROM HBAR, BUT WAIT A WHILE...
C=======================================================================
C
      DO LAMBDA=0,NASMAX
         DO MIU=0,LAMBDA
            BUNITS(LAMBDA,MIU)=1.0D0
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_HO(POT_HO,HBMACT,ESCALE,HBACTX,HBACTY,HBACTZ,
     *                                                     LTWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          POT_HO(1:NDBASE,1:NDBASE)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF THE HO POTENTIAL
C=======================================================================
C
      IF (LTWCEN.GT.2) STOP 'WRONG LTWCEN IN INT_HO'
C
      DO IKET=1,LDBATW(IND2HR(LTWCEN))
         DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
            NXBRA=NXVECT(IBRA,LTWCEN)
            NYBRA=NYVECT(IBRA,LTWCEN)
            NZBRA=NZVECT(IBRA,LTWCEN)
C
            NXKET=NXVECT(IKET,LTWCEN)
            NYKET=NYVECT(IKET,LTWCEN)
            NZKET=NZVECT(IKET,LTWCEN)
C
C=======================================================================
C       Z**2 TERM
C=======================================================================
C
            TTTZ=0.0D0
C
            IF (NXBRA.EQ.NXKET) THEN
C
                IF (NYBRA.EQ.NYKET) THEN
C
                    IF (NZBRA.EQ.NZKET) THEN
                        TTTZ=REAL(2*NZBRA+1)
                    END IF
C
                    IF (NZBRA.EQ.(NZKET+2)) THEN
                        TTTZ=SQRT(REAL(NZBRA*(NZKET+1)))
                    END IF
C
                    IF (NZBRA.EQ.(NZKET-2)) THEN
                        TTTZ=SQRT(REAL(NZKET*(NZBRA+1)))
                    END IF
C
                    TTTZ=TTTZ/HOMSCA(3,LTWCEN)**2
C
                END IF
C
            END IF
C
            TTTZ=TTTZ/2
C
C=======================================================================
C       Y**2 TERM
C=======================================================================
C
            TTTY=0.0D0
C
            IF (NXBRA.EQ.NXKET) THEN
C
                IF (NZBRA.EQ.NZKET) THEN
C
                    IF (NYBRA.EQ.NYKET) THEN
                        TTTY=REAL(2*NYBRA+1)
                    END IF
C
                    IF (NYBRA.EQ.(NYKET+2)) THEN
                        TTTY=SQRT(REAL(NYBRA*(NYKET+1)))
                    END IF
C
                    IF (NYBRA.EQ.(NYKET-2)) THEN
                        TTTY=SQRT(REAL(NYKET*(NYBRA+1)))
                    END IF
C
                    TTTY=TTTY/HOMSCA(2,LTWCEN)**2
C
                END IF
C
            END IF
C
            TTTY=TTTY/2
C
C=======================================================================
C       X**2 TERM
C=======================================================================
C
            TTTX=0.0D0
C
            IF (NYBRA.EQ.NYKET) THEN
C
                IF (NZBRA.EQ.NZKET) THEN
C
                    IF (NXBRA.EQ.NXKET) THEN
                        TTTX=REAL(2*NXBRA+1)
                    END IF
C
                    IF (NXBRA.EQ.(NXKET+2)) THEN
                        TTTX=SQRT(REAL(NXBRA*(NXKET+1)))
                    END IF
C
                    IF (NXBRA.EQ.(NXKET-2)) THEN
                        TTTX=SQRT(REAL(NXKET*(NXBRA+1)))
                    END IF
C
                    TTTX=TTTX/HOMSCA(1,LTWCEN)**2
C
                END IF
C
            END IF
C
            TTTX=TTTX/2
C
C=======================================================================
C           POTENTIAL ENERGY
C=======================================================================
C
            POT_HO(IBRA,IKET)=(HBACTX**2*TTTX
     *                        +HBACTY**2*TTTY
     *                        +HBACTZ**2*TTTZ)/HBMACT/4.0D0
     *
     *                        * IPHAPP(NYBRA,NYKET,0)
C
         END DO
      END DO
C
C=======================================================================
C           THE POTENTIAL ENERGY IS SHIFTED BY A CONSTANT.
C=======================================================================
C
      DO IBRA=1,LDBASE
C
         POT_HO(IBRA,IBRA)=POT_HO(IBRA,IBRA)-ESCALE
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SPENSU(MREVER,ENESUM,ICHARG,ISIMPY,ITWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /TWCDIA/ TWCSPE(1:2*NDSTAT,0:NDISOS)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE SUM OF SINGLE-PARTICLE ENERGIES
C=======================================================================
C
      IF (ITWCEN.EQ.2) THEN
C
         DO IALLST=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            SPENER(IALLST,ICHARG)=TWCSPE(IALLST,ICHARG)
C
         END DO
C
      END IF
C
      ENESUM=0.0D0
C
      IF (ISIMPY.EQ.1) THEN
C
          IF (IFTEMP.EQ.0) THEN
C
              DO IREVER=0,MREVER
C
                 DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                    SPOCCU(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)=
     *              V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))**2
C
                    ENESUM=ENESUM
     *             +SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *             *SPOCCU(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                 END DO
C
              END DO
C
          ELSE
C
              DO IREVER=0,MREVER
C
                 DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                    SPOCCU(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)=
     *              V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))**2
     *
     *    +(1.0D0-2*V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))**2)
     *             *FERMFN(ISTATE,ICHARG)
C
                    ENESUM=ENESUM
     *             +SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *             *SPOCCU(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                 END DO
C
              END DO
C
          END IF
C
      ELSE
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
             SPOCCU(ISTATE,ICHARG)=V_OCCU(ISTATE)**2
C
             ENESUM=ENESUM
     *             +SPENER(ISTATE,ICHARG)*SPOCCU(ISTATE,ICHARG)
C
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PNENSU(MREVER,ENESUM,ISIMPY)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /MIOCCU/ VMOCCU(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE SUM OF SINGLE-PARTICLE ENERGIES
C       IN THE CASE OF PROTON-NEUTRON MIXING
C=======================================================================
C
      ENESUM=0.0D0
C
      IF (ISIMPY.EQ.1) THEN
C
          IF (IFTEMP.EQ.0) THEN
C
              DO IREVER=0,MREVER
C
                 DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
                    PNOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *              VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))**2
C
                    ENESUM=ENESUM
     *             +PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *             *PNOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                 END DO
C
              END DO
C
          ELSE
C
              STOP ' IFTEMP=1 NOT YET IMPLEMENTED IN PNENSU'
C
          END IF
C
      ELSE
C
          DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
             PNOCCU(ISTATE)=VMOCCU(ISTATE)**2
C
             ENESUM=ENESUM+PNENER(ISTATE)*PNOCCU(ISTATE)
C
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE QPENSU(MREVER,ENESUM,EFERMI,ICHARG)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE SUM OF QUASIPARTICLE ENERGIES
C       SEE KARIM'S EMAIL OF 24/03/2017
C=======================================================================
C
      ENESUM=0.0D0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
            ENESUM=ENESUM-(ENQUAP(ISTATE,IREVER)-EFERMI)
     *                    *V2QUAP(ISTATE,IREVER)
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DENMAC(MREVER,ICHARG,ISIMPY,IPAHFB,WALEFT,WARIGH
     *                                                    ,LTWCEN)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          W_LEFT,W_RIGH
      COMPLEX
     *          WALEFT,WARIGH
      COMPLEX
     *          PHASPI,C_ZERO,C_UNIT
      COMPLEX
     *          WALEFP,WALEFM,WARIGP,WARIGM
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C=======================================================================
      ALLOCATABLE W_LEFT(:,:),W_RIGH(:,:)
C=======================================================================
      DIMENSION
     *          WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN)
C
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /AXILIZ/ NOSCIL,IF_THO,IAXIAP
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
C
C=======================================================================
C
      CALL CPUTIM('DENMAC',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(BIG_PP)) THEN
          ALLOCATE (BIG_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PP','DENMAC')
      END IF
      IF (.NOT.ALLOCATED(BIG_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (BIG_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PM','DENMAC')
      END IF
C=======================================================================
C
C=======================================================================
C     THIS SUBROUTINE CALCULATES THE TRANSITION DENSITY MATRIX
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
      LUPPER=LDUPPE(ICHARG)
C
C=======================================================================
C                       CONSERVED SIMPLEX
C=======================================================================
C
      IF (ISIMPY.EQ.1) THEN
C
          BIG_PP(:,:,:)=C_ZERO
C
          IF (IFTEMP.EQ.0) THEN
C
              DO IREVER=0,MREVER
C
C                 OpenMP and (threaded) BLAS acceleration
#if(USE_OPENMP==1)
C
                 ALLOCATE(W_LEFT(1:NDBASE,1:LUPPER))
                 ALLOCATE(W_RIGH(1:NDBASE,1:LUPPER))
C
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(STATIC)
!$OMP& SHARED(LUPPER,LDBASE,W_LEFT,WALEFT,PHASPI,W_RIGH,WARIGH,
!$OMP&                                                  IREVER)
!$OMP& PRIVATE(ISTATE,I_BASE)
                 DO ISTATE=1,LUPPER
                    DO I_BASE=1,LDBASE
C
                        W_LEFT(I_BASE,ISTATE)=WALEFT(I_BASE,ISTATE,0)
     *                                 *CONJG(PHASPI(I_BASE,IREVER,0,1))
     *                                       +WALEFT(I_BASE,ISTATE,1)
     *                                 *CONJG(PHASPI(I_BASE,IREVER,1,1))
                        W_RIGH(I_BASE,ISTATE)=WARIGH(I_BASE,ISTATE,0)
     *                                 *CONJG(PHASPI(I_BASE,IREVER,0,1))
     *                                       +WARIGH(I_BASE,ISTATE,1)
     *                                 *CONJG(PHASPI(I_BASE,IREVER,1,1))
C
                    END DO
                 END DO
!$OMP END PARALLEL DO
C
                 CALL ZGEMM('N','C',LDBASE,LDBASE,LUPPER,
     *                              C_UNIT,W_LEFT,NDBASE,
     *                                     W_RIGH,NDBASE,
     *                  C_ZERO,BIG_PP(1,1,IREVER),NDBASE)
C
                 DEALLOCATE(W_LEFT,W_RIGH)
C
#else
C
C                 Basic coding not taking advantage of shared memory
C                 or high-performance BLAS libraries
                 DO ISTATE=1,LUPPER
C
C=======================================================================
C                    FROM VERSION   249f  (INCLUDED) TO VERSION  249m
C                    (INCLUDED),  WALEFP  WAS DEFINED OUTSIDE THE LOOP
C                    OVER INDEX IBRA. THIS CAUSED A BUG WHEN USING THE
C                    LAHEY COMPILER WITH THE  --fast  OPTION ACTIVATED
C                    AND HAS THEREFORE BEEN CORRECTED FOR PORTABILITY.
C=======================================================================
C
                    DO IKET=1,LDBASE
C
                        DO IBRA=1,LDBASE
C
                           WALEFP=WALEFT(IKET,ISTATE,0)
     *                     *CONJG(PHASPI(IKET,IREVER,0,1))
     *                           +WALEFT(IKET,ISTATE,1)
     *                     *CONJG(PHASPI(IKET,IREVER,1,1))
C
                           WARIGP=WARIGH(IBRA,ISTATE,0)
     *                     *CONJG(PHASPI(IBRA,IREVER,0,1))
     *                           +WARIGH(IBRA,ISTATE,1)
     *                     *CONJG(PHASPI(IBRA,IREVER,1,1))
C
                           BIG_PP(IBRA,IKET,IREVER)
     *                    =BIG_PP(IBRA,IKET,IREVER)
     *                        +WARIGP*CONJG(WALEFP)
C
                       END DO
C
                    END DO
C
                 END DO
#endif
C
              END DO ! end IREVER
C
          ELSE
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
              DO IREVER=0,MREVER
C
                 ALLOCATE(W_LEFT(1:NDBASE,1:LUPPER))
                 ALLOCATE(W_RIGH(1:NDBASE,1:LUPPER))
C
C                 (Possibly threaded) BLAS acceleration
                 DO ISTATE=1,LUPPER
                    DO I_BASE=1,LDBASE
C
                        W_LEFT(I_BASE,ISTATE)=WALEFT(I_BASE,ISTATE,0)
     *                                 *CONJG(PHASPI(I_BASE,IREVER,0,1))
     *                                       +WALEFT(I_BASE,ISTATE,1)
     *                                 *CONJG(PHASPI(I_BASE,IREVER,1,1))
                        W_RIGH(I_BASE,ISTATE)=WARIGH(I_BASE,ISTATE,0)
     *                                 *CONJG(PHASPI(I_BASE,IREVER,0,1))
     *                                       +WARIGH(I_BASE,ISTATE,1)
     *                                 *CONJG(PHASPI(I_BASE,IREVER,1,1))
C
                    END DO
                 END DO
C
                 DO ISTATE=1,LUPPER
                    CORECT=1.0D0-FERMFN(ISTATE,ICHARG)
                    CALL ZDSCAL(LDBASE,CORECT,W_LEFT(1,ISTATE),1)
                 END DO
C
                 CALL ZGEMM('N','C',LDBASE,LDBASE,LUPPER,
     *                              C_UNIT,W_LEFT,NDBASE,
     *                                     W_RIGH,NDBASE,
     *                  C_ZERO,BIG_PP(1,1,IREVER),NDBASE)
C
                 LREVER=IREVER
                 LD_MAX=LUPPER
C
                 IF (IPAHFB.GE.1) THEN
                     LREVER=1
                     LD_MAX=LDTIMU(ICHARG)
                 END IF
C
                 DO ISTATE=1,LD_MAX
                    JSTATE=LUPPER+ISTATE
                    DO I_BASE=1,LDBASE
C
                        W_LEFT(I_BASE,ISTATE)
     *                          =CONJG(WALEFT(I_BASE,JSTATE,0))
     *                                *PHASPI(I_BASE,IREVER,0,1)
     *                          +CONJG(WALEFT(I_BASE,JSTATE,1))
     *                                *PHASPI(I_BASE,IREVER,1,1)
                        W_RIGH(I_BASE,ISTATE)
     *                         =CONJG(WARIGH(I_BASE,JSTATE,0))
     *                               *PHASPI(I_BASE,IREVER,0,1)
     *                         +CONJG(WARIGH(I_BASE,JSTATE,1))
     *                               *PHASPI(I_BASE,IREVER,1,1)
C
                    END DO
                 END DO
C
C                 For MREVER=0, we have LDTIMU(ICHARG)=LDUPPE(ICHARG)
C                 (Attention: HFB only)
C
                 IF (MREVER.NE.0) THEN
C
                     DO ISTATE=LDTIMU(ICHARG)+1,LUPPER
                        JSTATE=LUPPER+ISTATE-LDTIMU(ICHARG)
                        DO I_BASE=1,LDBASE
C
                            W_LEFT(I_BASE,ISTATE)
     *                     =WALEFT(I_BASE,JSTATE,0)
     *               *CONJG(PHASPI(I_BASE,LREVER,0,1))
     *                     +WALEFT(I_BASE,JSTATE,1)
     *               *CONJG(PHASPI(I_BASE,LREVER,1,1))
                            W_RIGH(I_BASE,ISTATE)
     *                     =WARIGH(I_BASE,JSTATE,0)
     *               *CONJG(PHASPI(I_BASE,LREVER,0,1))
     *                     +WARIGH(I_BASE,JSTATE,1)
     *               *CONJG(PHASPI(I_BASE,LREVER,1,1))
C
                        END DO
                     END DO
C
                 END IF
C
                 DO ISTATE=1,LD_MAX
                    CORECT=FERMFN(ISTATE,ICHARG)
                    CALL ZDSCAL(LDBASE,CORECT,W_RIGH(1,ISTATE),1)
                 END DO
C
                 CALL ZGEMM('N','C',LDBASE,LDBASE,LD_MAX,
     *                              C_UNIT,W_LEFT,NDBASE,
     *                                     W_RIGH,NDBASE,
     *                  C_UNIT,BIG_PP(1,1,IREVER),NDBASE)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
                 DEALLOCATE(W_LEFT,W_RIGH)
C
             END DO ! end IREVER
C
          END IF ! end IFTEMP
C
C=======================================================================
C        DEFINING THE TIME-REVERSED TRANSITION DENSITY MATRIX
C        IN CASE OF NO ROTATION
C=======================================================================
C
          IF (MREVER.EQ.0) THEN
              BIG_PP(:,:,1)=CONJG(BIG_PP(:,:,0))
          END IF
C
C=======================================================================
C                       BROKEN SIMPLEX
C=======================================================================
C
      ELSE
C
          BIG_PP(:,:,:)=C_ZERO
          BIG_PM(:,:,:)=C_ZERO
C
#if(USE_OPENMP==1)
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(STATIC)
!$OMP& SHARED(LUPPER,LDBASE,WALEFT,PHASPI,WARIGH,BIG_PP,BIG_PM,
!$OMP&        LTWCEN,IND2HL,IND2HR,LDBATW)
!$OMP& PRIVATE(IKET,IBRA,ISTATE,WARIGP,WARIGM,WALEFP,WALEFM)
          DO IKET=1,LDBATW(IND2HR(LTWCEN))
C
             DO ISTATE=1,LUPPER
C
                DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
                   WALEFP=WALEFT(IKET,ISTATE,0)
     *             *CONJG(PHASPI(IKET,0,0,IND2HR(LTWCEN)))
     *                   +WALEFT(IKET,ISTATE,1)
     *             *CONJG(PHASPI(IKET,0,1,IND2HR(LTWCEN)))
C
                   WALEFM=WALEFT(IKET,ISTATE,0)
     *             *CONJG(PHASPI(IKET,1,0,IND2HR(LTWCEN)))
     *                   +WALEFT(IKET,ISTATE,1)
     *             *CONJG(PHASPI(IKET,1,1,IND2HR(LTWCEN)))
C
                   WARIGP=WARIGH(IBRA,ISTATE,0)
     *             *CONJG(PHASPI(IBRA,0,0,IND2HL(LTWCEN)))
     *                   +WARIGH(IBRA,ISTATE,1)
     *             *CONJG(PHASPI(IBRA,0,1,IND2HL(LTWCEN)))
C
                   WARIGM=WARIGH(IBRA,ISTATE,0)
     *             *CONJG(PHASPI(IBRA,1,0,IND2HL(LTWCEN)))
     *                   +WARIGH(IBRA,ISTATE,1)
     *             *CONJG(PHASPI(IBRA,1,1,IND2HL(LTWCEN)))
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                                +WARIGP*CONJG(WALEFP)
C
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                                +WARIGM*CONJG(WALEFM)
C
                   BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                                +WARIGP*CONJG(WALEFM)
C
                   BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                                +WARIGM*CONJG(WALEFP)
C
                END DO
             END DO
C
          END DO
!$OMP END PARALLEL DO
#else
          DO ISTATE=1,LUPPER
C
             DO IKET=1,LDBATW(IND2HR(LTWCEN))
                DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
                   WARIGP=WARIGH(IBRA,ISTATE,0)*
     *             CONJG(PHASPI(IBRA,0,0,IND2HL(LTWCEN)))
     *                     +WARIGH(IBRA,ISTATE,1)*
     *             CONJG(PHASPI(IBRA,0,1,IND2HL(LTWCEN)))
C
                   WARIGM=WARIGH(IBRA,ISTATE,0)*
     *             CONJG(PHASPI(IBRA,1,0,IND2HL(LTWCEN)))
     *                     +WARIGH(IBRA,ISTATE,1)*
     *             CONJG(PHASPI(IBRA,1,1,IND2HL(LTWCEN)))
C
                   WALEFP=WALEFT(IKET,ISTATE,0)*
     *             CONJG(PHASPI(IKET,0,0,IND2HR(LTWCEN)))
     *                     +WALEFT(IKET,ISTATE,1)*
     *             CONJG(PHASPI(IKET,0,1,IND2HR(LTWCEN)))
C
                   WALEFM=WALEFT(IKET,ISTATE,0)*
     *             CONJG(PHASPI(IKET,1,0,IND2HR(LTWCEN)))
     *                     +WALEFT(IKET,ISTATE,1)*
     *             CONJG(PHASPI(IKET,1,1,IND2HR(LTWCEN)))
C
                   BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)
     *                                +WARIGP*CONJG(WALEFP)
C
                   BIG_PP(IBRA,IKET,1)=BIG_PP(IBRA,IKET,1)
     *                                +WARIGM*CONJG(WALEFM)
C
                   BIG_PM(IBRA,IKET,0)=BIG_PM(IBRA,IKET,0)
     *                                +WARIGP*CONJG(WALEFM)
C
                   BIG_PM(IBRA,IKET,1)=BIG_PM(IBRA,IKET,1)
     *                                +WARIGM*CONJG(WALEFP)
C
                END DO
             END DO
C
          END DO
#endif
C
      END IF
C
C=======================================================================
C         AXIALIZATION OF DENSITIES
C=======================================================================
C
      IF (IAXIAP.EQ.-1) CALL CYLDEN(NOSCIL,IF_THO)
C
C=======================================================================
C
      CALL CPUTIM('DENMAC',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PAIMAC(ICHARG,ISIMPY,WALEFT,WARIGH,IKERNE)
C=======================================================================
      USE KAP_PP
      USE KAP_PM
      USE KAP2PP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WALEFT,WARIGH
      COMPLEX
     *          PHASPI,C_ZERO,CAUXIL
      COMPLEX
     *          WALEFP,WALEFM,WARIGP,WARIGM
      DIMENSION
     *          WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN)
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /AXILIZ/ NOSCIL,IF_THO,IAXIAP
      COMMON
     *       /ASYPAI/ KAPASY
C
C=======================================================================
C
      CALL CPUTIM('PAIMAC',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(PAI_PP).AND.ISIMPY.NE.1) THEN
          ALLOCATE (PAI_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PAI_PP','PAIMAC')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(PAI_PM)) THEN
          ALLOCATE (PAI_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PAI_PM','PAIMAC')
      END IF
C=======================================================================
C     THIS SUBROUTINE CALCULATES THE "TRUE" PAIRING TENSOR, KAPPA=B^*A^T
C     SINCE IN THIS CODE, THE B^* AND A^* MATRICES  ARE  STORED  AS  THE
C     QUASIPARTICLE WAVE FUNCTIONS, THE MULTIPLICATIONS BELOW CORRESPOND
C     TO THE PRODUCTS KAPPA=B A^+.
C=======================================================================
C     ATTENTION: THIS ROUTINE REMOVES THE RUSSIAN CONVENTION.
C=======================================================================
C     ATTENTION: THE CONVENTION OF USING THE PAI_PP AND PAI_PM ARRAYS IS
C                DIFFERENT THAN THE ONE USED FOR THE BIG_PP AND  BIG_PM,
C                NAMELY, FOR THE CONSERVED SIMPLEX THE ARRAY  PAI_PM  IS
C                USED AND FOR NONCONSERVED SIMPLEX THE ARRAY  PAI_PP  IS
C                USED IN ADDITION.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      LUPPER=LDUPPE(ICHARG)
      LTIMUP=LDTIMU(ICHARG)
C
C=======================================================================
C     ATTENTION: OPERATIONS PERFORMED FOR THE LEFT WAVE FUNCTIONS, WHICH
C                CORRESPOND TO THE LOWER  HFB  COMPONENTS,  INCLUDE  THE
C                REMOVAL OF THE RUSSIAN CONVENTION INTRODUCED IN DENSHF.
C=======================================================================
C
      PAI_PM(:,:,:)=C_ZERO
C
      IF (ISIMPY.EQ.1) THEN
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                DO ISTATE=1,LTIMUP
C
                WARIGP=WARIGH(IBRA,ISTATE,0)*CONJG(PHASPI(IBRA,0,0,1))
     *                +WARIGH(IBRA,ISTATE,1)*CONJG(PHASPI(IBRA,0,1,1))
C
                WALEFM=WALEFT(IKET,LUPPER+ISTATE,1)*PHASPI(IKET,1,0,1)
     *                -WALEFT(IKET,LUPPER+ISTATE,0)*PHASPI(IKET,1,1,1)
C
                PAI_PM(IBRA,IKET,0)=PAI_PM(IBRA,IKET,0)
     *                             +WARIGP*CONJG(WALEFM)
C
                END DO
C
                IF (IKERNE.EQ.0.AND.KAPASY.NE.1) THEN
C
                   PAI_PM(IKET,IBRA,1)=-PAI_PM(IBRA,IKET,0)
C
                ELSE
C
                   DO ISTATE=1,LTIMUP
C
                      WALEFP=WALEFT(IBRA,ISTATE,0)
     *                                        *CONJG(PHASPI(IBRA,0,0,1))
     *                      +WALEFT(IBRA,ISTATE,1)
     *                                        *CONJG(PHASPI(IBRA,0,1,1))
C
                      WARIGM=WARIGH(IKET,LUPPER+ISTATE,1)
     *                                               *PHASPI(IKET,1,0,1)
     *                      -WARIGH(IKET,LUPPER+ISTATE,0)
     *                                               *PHASPI(IKET,1,1,1)
C
                      PAI_PM(IKET,IBRA,1)=PAI_PM(IKET,IBRA,1)
     *                                   -WALEFP*CONJG(WARIGM)
C
                   END DO
C
                END IF
C
             END DO
          END DO
C
C=======================================================================
C             HERE THE PAIRING TENSOR IS ANTISYMMETRIZED
C=======================================================================
C
          IF (KAPASY.EQ.1) THEN
C
              DO IBRA=1,LDBASE
                 DO IKET=1,LDBASE
C
                    CAUXIL=(PAI_PM(IBRA,IKET,0)-PAI_PM(IKET,IBRA,1))/2
C
C                   WRITE (*,*) IBRA,IKET,
C    *                          PAI_PM(IBRA,IKET,0),CAUXIL,
C    *                          PAI_PM(IBRA,IKET,0)-CAUXIL,
C    *                     ABS((PAI_PM(IBRA,IKET,0)-CAUXIL)/CAUXIL)
C
                    PAI_PM(IBRA,IKET,0)=+CAUXIL
                    PAI_PM(IKET,IBRA,1)=-CAUXIL
C
                 END DO
              END DO
C
          END IF
C
      ELSE
C
          PAI_PP(:,:,:)=C_ZERO
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
                DO ISTATE=1,LUPPER
C
                  WARIGP=WARIGH(IBRA,ISTATE,0)*CONJG(PHASPI(IBRA,0,0,1))
     *                  +WARIGH(IBRA,ISTATE,1)*CONJG(PHASPI(IBRA,0,1,1))
C
                  WARIGM=WARIGH(IBRA,ISTATE,0)*CONJG(PHASPI(IBRA,1,0,1))
     *                  +WARIGH(IBRA,ISTATE,1)*CONJG(PHASPI(IBRA,1,1,1))
C
                  WALEFP=WALEFT(IKET,LUPPER+ISTATE,1)*PHASPI(IKET,0,0,1)
     *                  -WALEFT(IKET,LUPPER+ISTATE,0)*PHASPI(IKET,0,1,1)
C
                  WALEFM=WALEFT(IKET,LUPPER+ISTATE,1)*PHASPI(IKET,1,0,1)
     *                  -WALEFT(IKET,LUPPER+ISTATE,0)*PHASPI(IKET,1,1,1)
C
                  PAI_PP(IBRA,IKET,0)=PAI_PP(IBRA,IKET,0)
     *                               +WARIGP*CONJG(WALEFP)
C
                  PAI_PP(IBRA,IKET,1)=PAI_PP(IBRA,IKET,1)
     *                               +WARIGM*CONJG(WALEFM)
C
                  PAI_PM(IBRA,IKET,0)=PAI_PM(IBRA,IKET,0)
     *                               +WARIGP*CONJG(WALEFM)
C
                  PAI_PM(IBRA,IKET,1)=PAI_PM(IBRA,IKET,1)
     *                               +WARIGM*CONJG(WALEFP)
C
                END DO
C
             END DO
          END DO
C
C=======================================================================
C             HERE THE PAIRING TENSOR IS ANTISYMMETRIZED
C=======================================================================
C
          IF (KAPASY.EQ.1) THEN
C
              DO IBRA=1,LDBASE
                 DO IKET=1,LDBASE
C
                    CAUXIL=(PAI_PM(IBRA,IKET,0)-PAI_PM(IKET,IBRA,1))/2
C
                    PAI_PM(IBRA,IKET,0)=+CAUXIL
                    PAI_PM(IKET,IBRA,1)=-CAUXIL
C
                    CAUXIL=(PAI_PP(IBRA,IKET,0)-PAI_PP(IKET,IBRA,0))/2
C
                    PAI_PP(IBRA,IKET,0)=+CAUXIL
                    PAI_PP(IKET,IBRA,0)=-CAUXIL
C
                    CAUXIL=(PAI_PP(IBRA,IKET,1)-PAI_PP(IKET,IBRA,1))/2
C
                    PAI_PP(IBRA,IKET,1)=+CAUXIL
                    PAI_PP(IKET,IBRA,1)=-CAUXIL
C
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C         AXIALIZATION OF THE PAIRING TENSOR
C=======================================================================
C
      IPAIAX = 0
      IF (IAXIAP.EQ.-1) CALL CYLPAI(NOSCIL,IF_THO,IPAIAX)
C
C=======================================================================
C
      CALL CPUTIM('PAIMAC',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LIP_IN(ISIMPY,ICHARG,LIPKIN,LIPKIP,EF2XIN,EF2XOU,
     *                                                     NUMITE)
C=======================================================================
      USE MAR_PP
      USE MAR_PM
      USE MLI_PP
      USE MLI_PM
      USE BROYIN
      USE BROYOU
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BROSIZ/ NSCALR,NVECTO,NTENSO,NMATRI
      COMMON
     *       /ISDLIP/ IS_DLI(0:NDISOS)
C=======================================================================
C      THIS SUBROUTINE FILLS OUT THE BROYDEN VECTOR WITH THE DATA
C      CORRESPONDING TO THE LIPKIN-NOGAMI PRESCRIPTION. THE SAID DATA
C      INCLUDE THE LAMBDA_2 FACTOR AND THE MATRIX ELEMENTS OF THE
C      DENSITY MATRIX (NEUTRONS AND PROTONS IF THE LN METHOD APPLIES
C      TO BOTH). CONTRARY TO LINEAR MIXING, IT IS NECESSARY IN THE
C      BROYDEN METHOD TO MIX THE DENSITIES IN ADDITION TO LAMBDA_2
C=======================================================================
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(DLI_PP)) THEN
          ALLOCATE (DLI_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DLI_PP','LIP_IN')
      END IF
      IF (.NOT.ALLOCATED(DLI_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (DLI_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DLI_PM','LIP_IN')
      END IF
C=======================================================================
C
C      Initialization of the density matrices at the first iteration
C
      IF (NUMITE.EQ.0) THEN
C
          DO IREVER=0,NDREVE
             DO J=1,LDBASE
                DO I=1,LDBASE
                   DLI_PP(I,J,IREVER,ICHARG)=RHO_PP(I,J,IREVER)
                END DO
             END DO
          END DO
C
          IF (ISIMPY.NE.1) THEN
              DO IREVER=0,NDREVE
                 DO J=1,LDBASE
                    DO I=1,LDBASE
                       DLI_PM(I,J,IREVER,ICHARG)=RHO_PM(I,J,IREVER)
                    END DO
                 END DO
              END DO
          END IF
C
      END IF
C
      IS_DLI(ICHARG)=1
C
      N_ISOS=NMATRI/2
C
C=======================================================================
C
C      Case where the Lipkin-Nogami method is applied to both types
C      of nucleon. This subroutine is called twice, for neutrons and
C      for protons, and the full Broyden vector is filled 'slice by
C      slice'. The breakdown of the vector is indicated below.
C
C   CONSERVED SIMPLEX
C                   Segment                        Content
C      2+1               ->   2+N_ISOS       : real part of rho_n
C      2+N_ISOS+1        ->   2+NMATRI       : real part of rho_p
C      2+NMATRI+1        ->   2+NMATRI+N_ISOS: imaginary part of rho_n
C      2+NMATRI+N_ISOS+1 ->   2+2*NMATRI     : imaginary part of rho_p
C
C   BROKEN SIMPLEX
C                     Segment                    Content
C 2+(2*NMATRI+1)           ->2+(2*NMATRI+1)+ N_ISOS : real part of rho_n
C 2+(2*NMATRI+1)+(N_ISOS+1)->2+ 3*NMATRI            : real part of rho_p
C 2+(3*NMATRI+1)           ->2+(3*NMATRI+1)+ N_ISOS : img. part of rho_n
C 2+(3*NMATRI+1)+(N_ISOS+1)->2+ 4*NMATRI            : img. part of rho_p
C
C=======================================================================
C
      IF (LIPKIN.EQ.1.AND.LIPKIP.EQ.1) THEN
C
          BRO_IN(1+ICHARG)=EF2XIN
          BRO_OU(1+ICHARG)=EF2XOU
C
          INDEXX=ICHARG*N_ISOS
C
          DO IREVER=0,NDREVE
C
             DO J=1,LDBASE
                DO I=1,LDBASE
C
                   INDEXX=INDEXX+1
C
                   BRO_IN(2+INDEXX)
     *              =REAL(DLI_PP(I,J,IREVER,ICHARG))
                   BRO_OU(2+INDEXX)
     *              =REAL(RHO_PP(I,J,IREVER))
C
                   BRO_IN(2+INDEXX+NMATRI)
     *              =AIMAG(DLI_PP(I,J,IREVER,ICHARG))
                   BRO_OU(2+INDEXX+NMATRI)
     *              =AIMAG(RHO_PP(I,J,IREVER))
C
                END DO
             END DO
C
          END DO
C
C=======================================================================
C          CASE OF NON-CONSERVED SIMPLEX
C=======================================================================
C
          IF (ISIMPY.NE.1) THEN
C
              INDEXX=2*NMATRI+ICHARG*N_ISOS
C
              DO IREVER=0,NDREVE
C
                 DO J=1,LDBASE
                    DO I=1,LDBASE
C
                       INDEXX=INDEXX+1
C
                       BRO_IN(2+INDEXX)=REAL(DLI_PM(I,J,IREVER,ICHARG))
                       BRO_OU(2+INDEXX)=REAL(RHO_PM(I,J,IREVER))
C
                       BRO_IN(2+INDEXX+NMATRI)
     *                             =AIMAG(DLI_PM(I,J,IREVER,ICHARG))
                       BRO_OU(2+INDEXX+NMATRI)
     *                             =AIMAG(RHO_PM(I,J,IREVER))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
C      Case where the Lipkin-Nogami method is applied to one type
C      of nucleons only. The Broyden vector is half-shorter, and its
C      breakdown is indicated below.
C
C   CONSERVED SIMPLEX
C                     Segment                    Content
C            1           ->   N_ISOS       : real part of rho_[n,p]
C        N_ISOS+1        -> 2*N_ISOS       : imaginary part of rho_[n,p]
C
C   BROKEN SIMPLEX
C                     Segment                    Content
C  (2*N_ISOS+1)           -> 3*N_ISOS      : real part of rho_[n,p]
C  (3*N_ISOS+1)           -> 4*N_ISOS      : imaginary part of rho_[n,p]
C
C=======================================================================
C
      IF ((LIPKIN.EQ.1.AND.LIPKIP.EQ.0.AND.ICHARG.EQ.0).OR.
     *    (LIPKIP.EQ.1.AND.LIPKIN.EQ.0.AND.ICHARG.EQ.1)) THEN
C
          BRO_IN(1)=EF2XIN
          BRO_OU(1)=EF2XOU
C
          INDEXX=0
C
          DO IREVER=0,NDREVE
C
             DO J=1,LDBASE
                DO I=1,LDBASE
C
                   INDEXX=INDEXX+1
C
                   BRO_IN(INDEXX+1)=REAL(DLI_PP(I,J,IREVER,ICHARG))
                   BRO_OU(INDEXX+1)=REAL(RHO_PP(I,J,IREVER))
C
                   BRO_IN(INDEXX+N_ISOS+1)
     *                             =AIMAG(DLI_PP(I,J,IREVER,ICHARG))
                   BRO_OU(INDEXX+N_ISOS+1)
     *                             =AIMAG(RHO_PP(I,J,IREVER))
C
                END DO
             END DO
C
          END DO
C
C=======================================================================
C          CASE OF NON-CONSERVED SIMPLEX
C=======================================================================
C
          IF (ISIMPY.NE.1) THEN
C
              INDEXX=2*N_ISOS
C
              DO IREVER=0,NDREVE
C
                 DO J=1,LDBASE
                    DO I=1,LDBASE
C
                       INDEXX=INDEXX+1
C
                       BRO_IN(INDEXX+1)=REAL(DLI_PM(I,J,IREVER,ICHARG))
                       BRO_OU(INDEXX+1)=REAL(RHO_PM(I,J,IREVER))
C
                       BRO_IN(INDEXX+N_ISOS+1)
     *                             =AIMAG(DLI_PM(I,J,IREVER,ICHARG))
                       BRO_OU(INDEXX+N_ISOS+1)
     *                             =AIMAG(RHO_PM(I,J,IREVER))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LIP_OU(ISIMPY,LIPKIN,LIPKIP,EFER2N,EFER2P)
C=======================================================================
      USE MLI_PP
      USE MLI_PM
      USE BROYIN
      USE BROYOU
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BROSIZ/ NSCALR,NVECTO,NTENSO,NMATRI
C=======================================================================
C      THIS SUBROUTINE RECONSTRUCTS THE DENSITY MATRIX AFTER IT HAS
C      BEEN UPDATED BY THE BROYDEN METHOD. IT MUST BE CALLED RIGHT
C      AFTER SUBROUTINE DOBROY. BOTH THE NEUTRON AND PROTON DENSITY
C      MATRICES ARE RECONSTRUCTED, UNLESS THE LIPKIN-NOGAMI METHOD
C      APPLIES TO ONLY ONE TYPE OF NUCLEON ONLY.
C=======================================================================
C      SEE SUBROUTINE LIP_IN FOR COMMENTS
C=======================================================================
C
      N_ISOS=NMATRI/2
C
      IF (LIPKIN.EQ.1.AND.LIPKIP.EQ.1) THEN
C
          EFER2N=BRO_IN(1)
          EFER2P=BRO_IN(2)
C
          INDEXX=0
C
          DO IREVER=0,NDREVE
C
             DO J=1,LDBASE
                DO I=1,LDBASE
C
                   INDEXX=INDEXX+1
C
                   DLI_PP(I,J,IREVER,0)
     *            =CMPLX(BRO_IN(2+INDEXX),
     *                   BRO_IN(2+INDEXX+NMATRI))
C
                   DLI_PP(I,J,IREVER,1)
     *            =CMPLX(BRO_IN(2+INDEXX+N_ISOS),
     *                   BRO_IN(2+INDEXX+NMATRI+N_ISOS))
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              INDEXX=2*NMATRI
C
              DO IREVER=0,NDREVE
C
                 DO J=1,LDBASE
                    DO I=1,LDBASE
C
                       INDEXX=INDEXX+1
C
                       DLI_PM(I,J,IREVER,0)
     *                =CMPLX(BRO_IN(2+INDEXX),
     *                       BRO_IN(2+INDEXX+NMATRI))
C
                       DLI_PM(I,J,IREVER,1)
     *                =CMPLX(BRO_IN(2+INDEXX+N_ISOS),
     *                       BRO_IN(2+INDEXX+NMATRI+N_ISOS))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C      SEE SUBROUTINE LIP_IN FOR COMMENTS
C=======================================================================
C
      IF (LIPKIN.EQ.1.AND.LIPKIP.EQ.0) THEN
C
          EFER2N=BRO_IN(1)
C
          INDEXX=0
C
          DO IREVER=0,NDREVE
C
             DO J=1,LDBASE
                DO I=1,LDBASE
C
                   INDEXX=INDEXX+1
C
                   DLI_PP(I,J,IREVER,0)
     *            =CMPLX(BRO_IN(INDEXX+1),BRO_IN(INDEXX+N_ISOS+1))
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              INDEXX=2*N_ISOS
C
              DO IREVER=0,NDREVE
C
                 DO J=1,LDBASE
                    DO I=1,LDBASE
C
                       INDEXX=INDEXX+1
C
                       DLI_PM(I,J,IREVER,0)
     *                =CMPLX(BRO_IN(INDEXX+1),BRO_IN(INDEXX+N_ISOS+1))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C      SEE SUBROUTINE LIP_IN FOR COMMENTS
C=======================================================================
C
      IF (LIPKIN.EQ.0.AND.LIPKIP.EQ.1) THEN
C
          EFER2P=BRO_IN(1)
C
          INDEXX=0
C
          DO IREVER=0,NDREVE
C
             DO J=1,LDBASE
                DO I=1,LDBASE
C
                   INDEXX=INDEXX+1
C
                   DLI_PP(I,J,IREVER,1)
     *            =CMPLX(BRO_IN(INDEXX+1),BRO_IN(INDEXX+N_ISOS+1))
C
                END DO
             END DO
C
          END DO
C
          IF (ISIMPY.NE.1) THEN
C
              INDEXX=2*N_ISOS
C
              DO IREVER=0,NDREVE
C
                 DO J=1,LDBASE
                    DO I=1,LDBASE
C
                       INDEXX=INDEXX+1
C
                       DLI_PM(I,J,IREVER,1)
     *                =CMPLX(BRO_IN(INDEXX+1),BRO_IN(INDEXX+N_ISOS+1))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAVDEN_OLD(ISIMPY,ICHARG)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE MAD_PP
      USE MAD_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C=======================================================================
C      THIS SUBROUTINE SAVES THE DENSITY MATRIX WITHOUT THE PN MIXING
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(DEN_PP)) THEN
          ALLOCATE (DEN_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DEN_PP','SAVDEN')
      END IF
C
      DEN_PP(:,:,:,ICHARG)=BIG_PP(:,:,:)
C
      IF (ISIMPY.NE.1) THEN
C
          IALLOC=0
          IF (.NOT.ALLOCATED(DEN_PM)) THEN
              ALLOCATE (DEN_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                 STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('DEN_PM','SAVDEN')
          END IF
C
          DEN_PM(:,:,:,ICHARG)=BIG_PM(:,:,:)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAVDEN(ISIMPY,ITPNMX)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE MAD_PP
      USE MAD_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C=======================================================================
C      THIS SUBROUTINE SAVES THE DENSITY MATRIX TAKING INTO ACCOUNT THE
C      POSSIBLE PN MIXING
C=======================================================================
C
      IF (.NOT.ALLOCATED(DEN_PP)) STOP 'DEN_PP NOT ALLOCATED IN SAVDEN'
C
      DEN_PP(:,:,:,ITPNMX)=BIG_PP(:,:,:)
C
      IF (ISIMPY.NE.1) THEN
C
          IF (.NOT.ALLOCATED(DEN_PM))STOP 'DEN_PM NOT ALLCTED IN SAVDEN'
C
          DEN_PM(:,:,:,ITPNMX)=BIG_PM(:,:,:)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE STO2ND(ISIMPY)
C=======================================================================
      USE KAP_PM
      USE KAP2PM
      USE KAP_PP
      USE KAP2PP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      IF (.NOT.ALLOCATED(PAI2PM)) THEN
          ALLOCATE (PAI2PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PAI2PM','STO2ND')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(PAI2PP).AND.ISIMPY.NE.1) THEN
          ALLOCATE (PAI2PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('PAI2PP','STO2ND')
      END IF
C=======================================================================
C      THIS SUBROUTINE COPIES THE PAIRING TENSORS
C=======================================================================
C
      IF (.NOT.ALLOCATED(PAI_PM)) STOP 'PAI_PM NOT ALLOCATED IN STO2ND'
C
      PAI2PM(:,:,:)=PAI_PM(:,:,:)
C
      IF (ISIMPY.NE.1) THEN
C
          IF (.NOT.ALLOCATED(PAI_PP))STOP 'PAI_PP NOT ALLCTED IN STO2ND'
C
          PAI2PP(:,:,:)=PAI_PP(:,:,:)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAVLIP(ISIMPY,ICHARG,SLOWLD,MIXDEN)
C=======================================================================
      USE MAR_PP
      USE MAR_PM
      USE MLI_PP
      USE MLI_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /ISDLIP/ IS_DLI(0:NDISOS)
C=======================================================================
C     THIS SUBROUTINE SAVES THE DENSITY MATRIX STORED IN THE RHO_ ARRAYS
C=======================================================================
C
      IF (MIXDEN.EQ.1.AND.IS_DLI(ICHARG).EQ.1) THEN
          XOLDLD=SLOWLD
      ELSE
          XOLDLD=0.0
      END IF
C
      XNEWLD=1.0-XOLDLD
C
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(DLI_PP)) THEN
          ALLOCATE (DLI_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DLI_PP','SAVLIP')
      END IF
C
      DLI_PP(:,:,:,ICHARG)=DLI_PP(:,:,:,ICHARG)*XOLDLD
     *                    +RHO_PP(:,:,:)       *XNEWLD
C
      IF (ISIMPY.NE.1) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(DLI_PM).AND.ISIMPY.NE.1) THEN
              ALLOCATE (DLI_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                 STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('DLI_PM','SAVLIP')
          END IF
C
          DLI_PM(:,:,:,ICHARG)=DLI_PM(:,:,:,ICHARG)*XOLDLD
     *                        +RHO_PM(:,:,:)       *XNEWLD
C
      END IF
C
      IS_DLI(ICHARG)=1
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAVLPM(ICHARG,ISIMPY,IPAIRI,SLOWLM,MIXDEN)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE MAD_PP
      USE MAD_PM
      USE KAP_PM
      USE KAP_PP
      USE MAP_PP
      USE MAP_PM
      USE KAP2PP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C=======================================================================
C      THIS SUBROUTINE MIXES AND SAVES DENSITY MATRIX AND PAIRING TENSOR
C=======================================================================
C
      IF (MIXDEN.EQ.1) THEN
          XOLDLM=SLOWLM
      ELSE
          XOLDLM=0.0
      END IF
C
      XNEWLM=1.0-XOLDLM
C
C=======================================================================
C
      IF (.NOT.ALLOCATED(DEN_PP)) STOP 'DEN_PP NOT ALLOCATED IN SAVLPM'
C
      DEN_PP(:,:,:,ICHARG)=BIG_PP(:,:,:)*XNEWLM
     *                    +DEN_PP(:,:,:,ICHARG)*XOLDLM
C
      IF (ISIMPY.NE.1) THEN
C
          IF (.NOT.ALLOCATED(DEN_PM))STOP 'DEN_PM NOT ALLCTED IN SAVLPM'
C
          DEN_PM(:,:,:,ICHARG)=BIG_PM(:,:,:)*XNEWLM
     *                        +DEN_PM(:,:,:,ICHARG)*XOLDLM
C
      END IF
C store pairing tensor
      IF(IPAIRI.GE.1)THEN
         IF (.NOT.ALLOCATED(CHI_PM)) THEN
             ALLOCATE (CHI_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
             IF (IALLOC.NE.0) CALL NOALLO('CHI_PM','SAVLPM')
         END IF
C
         CHI_PM(:,:,:,ICHARG)=PAI_PM(:,:,:)       *XNEWLM
     *                       +CHI_PM(:,:,:,ICHARG)*XOLDLM
C
         IF (ISIMPY.NE.1) THEN
C
             IALLOC=0
C
             IF (.NOT.ALLOCATED(CHI_PP)) THEN
                 ALLOCATE (CHI_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                 STAT=IALLOC)
                 IF (IALLOC.NE.0) CALL NOALLO('CHI_PP','SAVLPM')
             END IF
C
            CHI_PP(:,:,:,ICHARG)=PAI_PP(:,:,:)       *XNEWLM
     *                          +CHI_PP(:,:,:,ICHARG)*XOLDLM
C
         END IF
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAVPAI(ISIMPY,ITPNMX)
C=======================================================================
      USE KAP_PM
      USE KAP_PP
      USE MAP_PP
      USE MAP_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C=======================================================================
C      THIS SUBROUTINE SAVES THE PAIRING TENSOR TAKING INTO ACCOUNT THE
C      POSSIBLE PN MIXING
C=======================================================================
C
      IF (.NOT.ALLOCATED(CHI_PM)) STOP 'CHI_PM NOT ALLOCATED IN SAVPAI'
      IF (.NOT.ALLOCATED(PAI_PM)) STOP 'PAI_PM NOT ALLOCATED IN SAVPAI'
C
      CHI_PM(:,:,:,ITPNMX)=PAI_PM(:,:,:)
C
      IF (ISIMPY.NE.1) THEN
C
          IF (.NOT.ALLOCATED(CHI_PP)) STOP'CHI_PP NOT ALLCTED IN SAVPAI'
          IF (.NOT.ALLOCATED(PAI_PP)) STOP'PAI_PP NOT ALLCTED IN SAVPAI'
C
          CHI_PP(:,:,:,ITPNMX)=PAI_PP(:,:,:)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAVPPN(ISIMPY,ITPNMX,LDPNMX)
C=======================================================================
      USE KAP_PM
      USE KAP_PP
      USE MAP_PP
      USE MAP_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C=======================================================================
C      THIS SUBROUTINE SAVES THE PAIRING TENSOR WITH THE PN MIXING
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(CHI_PM)) THEN
          ALLOCATE (CHI_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:LDPNMX),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('CHI_PM','SAVPPN')
      END IF
C
      CHI_PM(:,:,:,ITPNMX)=PAI_PM(:,:,:)
C
      IF (ISIMPY.NE.1) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(CHI_PP)) THEN
              ALLOCATE (CHI_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:LDPNMX),
     *                                                 STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('CHI_PP','SAVPPN')
          END IF
C
         CHI_PP(:,:,:,ITPNMX)=PAI_PP(:,:,:)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAVFIL(ISIMPY,IPAHFB,ICHARG,REA2PP)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE PAIDEL
      USE MAF_PP
      USE MAF_PM
      USE MAPIDE
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      LOGICAL
     *          REA2PP
C=======================================================================
C     THIS SUBROUTINE SAVES THE MEAN FIELDS
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(FIL_PP)) THEN
          ALLOCATE (FIL_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                             STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FIL_PP','SAVFIL')
      END IF
C
      FIL_PP(:,:,:,ICHARG)=BIG_PP(:,:,:)
C
      IF (ISIMPY.NE.1) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(FIL_PM)) THEN
              ALLOCATE (FIL_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                 STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('FIL_PM','SAVFIL')
          END IF
C
          FIL_PM(:,:,:,ICHARG)=BIG_PM(:,:,:)
C
      END IF
C
      IF (IPAHFB.GE.1) THEN
C
          IALLOC=0
C
          IF (.NOT.ALLOCATED(FIPIDE)) THEN
              ALLOCATE (FIPIDE(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                 STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('FIPIDE','SAVFIL')
          END IF
C
          FIPIDE(:,:,:,ICHARG)=HAMIDE(:,:,:)
C
          IF (.NOT.ALLOCATED(FIP2DE).AND.REA2PP) THEN
              ALLOCATE (FIP2DE(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                 STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('FIP2DE','SAVFIL')
          END IF
C
          IF (REA2PP) FIP2DE(:,:,:,ICHARG)=HAM2DE(:,:,:)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GETFIL(ISIMPY,ICHARG,LTWCEN,ITWCEN)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE MAF_PP
      USE MAF_PM
      USE MAFTWC
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C=======================================================================
C     THIS SUBROUTINE COPIES THE MEAN FIELDS FROM THOSE READ FROM THE
C     FIELDS FILE
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(BIG_PP)) THEN
          ALLOCATE (BIG_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PP','GETFIL')
      END IF
C
      IF (ITWCEN.EQ.1) BIG_PP(:,:,:)=FIL_PP(:,:,:,ICHARG)
      IF (ITWCEN.EQ.2) BIG_PP(:,:,:)=FITWPP(:,:,:,LTWCEN,ICHARG)
C
      IF (ISIMPY.NE.1) THEN
C
           IALLOC=0
           IF (.NOT.ALLOCATED(BIG_PM)) THEN
               ALLOCATE (BIG_PM(1:NDBASE,1:NDBASE,0:NDREVE),
     *                                         STAT=IALLOC)
               IF (IALLOC.NE.0) CALL NOALLO('BIG_PM','GETFIL')
           END IF
           IF (ITWCEN.EQ.1) BIG_PM(:,:,:)=FIL_PM(:,:,:,ICHARG)
           IF (ITWCEN.EQ.2) BIG_PM(:,:,:)=FITWPM(:,:,:,LTWCEN,ICHARG)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GETDEN(ISIMPY,ICHARG)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE MAD_PP
      USE MAD_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C=======================================================================
C     THIS SUBROUTINE COPIES THE DENSITY STORED IN DEN_PP AND DEN_PM
C     INTO BUFFER ARRAYS BIG_PP AND BIG_PM
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(BIG_PP)) THEN
          ALLOCATE (BIG_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PP','GETDEN')
      END IF
C
      BIG_PP(:,:,:)=DEN_PP(:,:,:,ICHARG)
C
      IF (ISIMPY.NE.1) THEN
C
           IALLOC=0
           IF (.NOT.ALLOCATED(BIG_PM)) THEN
               ALLOCATE (BIG_PM(1:NDBASE,1:NDBASE,0:NDREVE),
     *                                         STAT=IALLOC)
               IF (IALLOC.NE.0) CALL NOALLO('BIG_PM','GETDEN')
           END IF
           BIG_PM(:,:,:)=DEN_PM(:,:,:,ICHARG)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GETPAI(ICHARG,REA2PP,LTWCEN,ITWCEN)
C=======================================================================
      USE PAIDEL
      USE MAPIDE
      USE MAFTWC
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      LOGICAL
     *          REA2PP
C=======================================================================
C     THIS SUBROUTINE COPIES THE PAIRING FIELDS FROM THOSE READ FROM THE
C     FIELDS FILE
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(HAMIDE)) THEN
          ALLOCATE (HAMIDE(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HAMIDE','GETPAI')
      END IF
C
      IF (ITWCEN.EQ.1) HAMIDE(:,:,:)=FIPIDE(:,:,:,ICHARG)
      IF (ITWCEN.EQ.2) HAMIDE(:,:,:)=FITWDE(:,:,:,LTWCEN,ICHARG)
C
      IF (.NOT.ALLOCATED(HAM2DE)) THEN
          ALLOCATE (HAM2DE(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HAM2DE','GETPAI')
      END IF
C
      IF (REA2PP) THEN
C
          IF (ITWCEN.EQ.2) STOP 'ITWCEN/REA2PP IN GETPAI'
C
          HAM2DE(:,:,:)=FIP2DE(:,:,:,ICHARG)
      ELSE
          IF (ITWCEN.EQ.1) HAM2DE(:,:,:)=FIPIDE(:,:,:,ICHARG)
          IF (ITWCEN.EQ.2) HAM2DE(:,:,:)=FITWDE(:,:,:,LTWCEN,ICHARG)
C
      END IF
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MIXFIL(ISIMPY,ICHARG,SLOWAL,ITWCEN,LTWCEN)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE MAF_PP
      USE MAF_PM
      USE MAFTWC
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C=======================================================================
C     THIS SUBROUTINE MIXES STORED MEAN FIELDS WITH THOSE CALCULATED
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          BIG_PP(:,:,:)=FIL_PP(:,:,:,ICHARG)*SLOWAL+
     *                  BIG_PP(:,:,:)*(1.0D0-SLOWAL)
C
          IF (ISIMPY.NE.1) THEN
C
              BIG_PM(:,:,:)=FIL_PM(:,:,:,ICHARG)*SLOWAL+
     *                      BIG_PM(:,:,:)*(1.0D0-SLOWAL)
C
          END IF
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          BIG_PP(:,:,:)=FITWPP(:,:,:,LTWCEN,ICHARG)*SLOWAL+
     *                  BIG_PP(:,:,:)*(1.0D0-SLOWAL)
          BIG_PM(:,:,:)=FITWPM(:,:,:,LTWCEN,ICHARG)*SLOWAL+
     *                  BIG_PM(:,:,:)*(1.0D0-SLOWAL)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MIXPAI(ICHARG,REA2PP,SLOWAL,ITWCEN,LTWCEN)
C=======================================================================
      USE PAIDEL
      USE MAPIDE
      USE MAFTWC
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      LOGICAL
     *          REA2PP
C
C=======================================================================
C     THIS SUBROUTINE MIXES STORED PAIRING FIELDS WITH THOSE CALCULATED
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          HAMIDE(:,:,:)=FIPIDE(:,:,:,ICHARG)*SLOWAL+
     *                  HAMIDE(:,:,:)*(1.0D0-SLOWAL)
C
          IF (REA2PP) THEN
C
              HAM2DE(:,:,:)=FIP2DE(:,:,:,ICHARG)*SLOWAL+
     *                      HAM2DE(:,:,:)*(1.0D0-SLOWAL)
C
          END IF
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          HAMIDE(:,:,:)=FITWDE(:,:,:,LTWCEN,ICHARG)*SLOWAL+
     *                  HAMIDE(:,:,:)*(1.0D0-SLOWAL)
C
          IF (REA2PP) STOP 'HAM2DE NOT READY IN MIXPAI FOR ITWCEN=2'
C
      END IF
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SPAVER(AVRVAL,OPIMRE,MREVER,
     *                  ICHARG,IMAREA,ISIPAR,ITIPAR,IHERMI)
C=======================================================================
      USE ALLWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          AVRVAL(1:2*NDSTAT)
      DIMENSION
     *          OPIMRE(1:NDBASE,1:NDBASE)
C
      COMPLEX
     *          RESULT,RESUL0,RESUL1
C=======================================================================
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('SPAVER',1)
C
C=======================================================================
C     THIS SUBROUTINE CALCULATES SINGLE-PARTICLE AVERAGE VALUES OF
C     AN OPERATOR WHICH IS:
C        1. REAL OR IMAGINARY IN THE SIMPLEX BASIS (IMAREA=+1/-1)
C        2. DIAGONAL OR OFF-DIAGONAL IN SIMPLEX (ISIPAR=+1/-1)
C        3. TIME-EVEN OR TIME-ODD (ITIPAR=+1/-1)
C        4. HERMITIAN OR ANTI-HERMITIAN (IHERMI=+1/-1)
C     INPUT ARRAY OPIMRE SHOULD CONTAIN
C        1. REAL OR IMAGINARY PARTS OF MATRIX ELEMENTS (IMAREA=+1/-1)
C        2. IN SIMPLEX PLUS-PLUS OR PLUS-MINUS BLOCK (ISIPAR=+1/-1)
C     RESULTING AVRVAL VECTOR THEN CONTAINS
C        1. REAL OR IMAGINARY PARTS OF AVERAGE VALUES (IHERMI=+1/-1)
C=======================================================================
C
      LSTATE=NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG)
C
      IF (ISIPAR.EQ.1) THEN
C
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(STATIC)
!$OMP& SHARED(LSTATE,LDBASE,OPIMRE,WAVOCC,IMAREA,ITIPAR,IHERMI,
!$OMP&                                                  AVRVAL)
!$OMP& PRIVATE(ISTATE,IKET,IBRA,RESULT,RESUL0,RESUL1)
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.11H) AND  (3.20K),  CALCULATION
C                    OF THE AVERAGES OF  SINGLE-PARTICLE  OPERATORS  FOR
C                    CONSERVED SIMPLEX WAS IMPLEMENTED INCORRECTLY. THIS
C                    BUG WAS CORRECTED IN VERSION (3.20L) ON 16/10/2023.
C=======================================================================
C
          DO ISTATE=1,LSTATE
C
             RESULT=CMPLX(0.0D0,0.0D0)
C
             DO IBRA=1,LDBASE
C
                RESUL0=CMPLX(0.0D0,0.0D0)
                RESUL1=CMPLX(0.0D0,0.0D0)
C
                DO IKET=1,LDBASE
                   RESUL0=RESUL0+OPIMRE(IBRA,IKET)*WAVOCC(IKET,ISTATE,0)
                   RESUL1=RESUL1+OPIMRE(IBRA,IKET)*WAVOCC(IKET,ISTATE,1)
                END DO
C
                RESULT=RESULT+
     *                 RESUL0*CONJG(WAVOCC(IBRA,ISTATE,0))+
     *                 RESUL1*CONJG(WAVOCC(IBRA,ISTATE,1))*IMAREA*ITIPAR
C
             END DO
C
             IF (IMAREA.EQ.-1) RESULT=RESULT*CMPLX(0.0D0,1.0D0)
C
             IF (IHERMI.EQ.1) THEN
                 AVRVAL(ISTATE)=REAL(RESULT)
             ELSE
                 AVRVAL(ISTATE)=AIMAG(RESULT)
             END IF
C
          END DO
!$OMP END PARALLEL DO
C
      ELSE
C
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(STATIC)
!$OMP& SHARED(LSTATE,LDBASE,OPIMRE,WAVOCC,IMAREA,ITIPAR,IHERMI,
!$OMP&                                                  AVRVAL)
!$OMP& PRIVATE(ISTATE,IKET,IBRA,RESULT,RESUL0)
          DO ISTATE=1,LSTATE
C
             RESULT=CMPLX(0.0D0,0.0D0)
C
             DO IBRA=1,LDBASE
C
                RESUL0=CMPLX(0.0D0,0.0D0)
C
                DO IKET=1,LDBASE
                   RESUL0=RESUL0+OPIMRE(IBRA,IKET)*WAVOCC(IKET,ISTATE,0)
                END DO
C
                RESULT=RESULT+RESUL0*CONJG(WAVOCC(IBRA,ISTATE,1))
C
             END DO
C
             IF (IMAREA.EQ.-1) RESULT=RESULT*CMPLX(0.0D0,1.0D0)
C
             IF (IHERMI.EQ.1) THEN
                 AVRVAL(ISTATE)=REAL(RESULT)
             ELSE
                 AVRVAL(ISTATE)=AIMAG(RESULT)
             END IF
C
             AVRVAL(ISTATE)=-2*IMAREA*ITIPAR*AVRVAL(ISTATE)
C
          END DO
!$OMP END PARALLEL DO
C
      END IF
C
      CALL CPUTIM('SPAVER',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PNAVER(AVRVAL,OPIMRE,MREVER,
     *                  IMAREA,ISIPAR,ITIPAR,IHERMI)
C=======================================================================
      USE PNMWAV
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          AVRVAL(1:4*NDSTAT)
      DIMENSION
     *          OPIMRE(1:NDBASE,1:NDBASE)
C
      COMPLEX
     *          RESULT
C=======================================================================
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('PNAVER',1)
C
C=======================================================================
C     THIS SUBROUTINE CALCULATES FOR THE PROTON-NEUTRON MIXED STATES THE
C     SINGLE-PARTICLE AVERAGE VALUES OF AN OPERATOR WHICH IS:
C        1. REAL OR IMAGINARY IN THE SIMPLEX BASIS (IMAREA=+1/-1)
C        2. DIAGONAL OR OFF-DIAGONAL IN SIMPLEX (ISIPAR=+1/-1)
C        3. TIME-EVEN OR TIME-ODD (ITIPAR=+1/-1)
C        4. HERMITIAN OR ANTI-HERMITIAN (IHERMI=+1/-1)
C        5. DIAGONAL IN THE ISOSPIN
C     INPUT ARRAY OPIMRE SHOULD CONTAIN
C        1. REAL OR IMAGINARY PARTS OF MATRIX ELEMENTS (IMAREA=+1/-1)
C        2. IN SIMPLEX PLUS-PLUS OR PLUS-MINUS BLOCK (ISIPAR=+1/-1)
C     RESULTING AVRVAL VECTOR THEN CONTAINS
C        1. REAL OR IMAGINARY PARTS OF AVERAGE VALUES (IHERMI=+1/-1)
C=======================================================================
C
      LSTATE=NUMBSP(0,0)+NUMBSP(0,1)+MREVER*(NUMBSP(1,0)+NUMBSP(1,1))
C
      IF (ISIPAR.EQ.1) THEN
C
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(STATIC)
!$OMP& SHARED(LSTATE,LDBASE,OPIMRE,PNMOCC,IMAREA,ITIPAR,IHERMI,
!$OMP&                                                  AVRVAL)
!$OMP& PRIVATE(ISTATE,IKET,IBRA,RESULT)
          DO ISTATE=1,LSTATE
C
             RESULT=CMPLX(0.0D0,0.0D0)
C
             DO IKET=1,LDBASE
                DO IBRA=1,LDBASE
                   RESULT=RESULT
     *           +OPIMRE(IBRA,IKET)*(CONJG(PNMOCC(       IBRA,ISTATE,0))
     *                                    *PNMOCC(       IKET,ISTATE,0)
     *                +IMAREA*ITIPAR*CONJG(PNMOCC(       IBRA,ISTATE,1))
     *                                    *PNMOCC(       IKET,ISTATE,1))
     *           +OPIMRE(IBRA,IKET)*(CONJG(PNMOCC(LDBASE+IBRA,ISTATE,0))
     *                                    *PNMOCC(LDBASE+IKET,ISTATE,0)
     *                +IMAREA*ITIPAR*CONJG(PNMOCC(LDBASE+IBRA,ISTATE,1))
     *                                    *PNMOCC(LDBASE+IKET,ISTATE,1))
                END DO
             END DO
C
             IF (IMAREA.EQ.-1) RESULT=RESULT*CMPLX(0.0D0,1.0D0)
C
             IF (IHERMI.EQ.1) THEN
                 AVRVAL(ISTATE)=REAL(RESULT)
             ELSE
                 AVRVAL(ISTATE)=AIMAG(RESULT)
             END IF
C
          END DO
!$OMP END PARALLEL DO
C
      ELSE
C
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(STATIC)
!$OMP& SHARED(LSTATE,LDBASE,OPIMRE,PNMOCC,IMAREA,ITIPAR,IHERMI,
!$OMP&                                                  AVRVAL)
!$OMP& PRIVATE(ISTATE,IKET,IBRA,RESULT)
          DO ISTATE=1,LSTATE
C
             RESULT=CMPLX(0.0D0,0.0D0)
C
             DO IKET=1,LDBASE
                DO IBRA=1,LDBASE
                   RESULT=RESULT
     *            +OPIMRE(IBRA,IKET)*CONJG(PNMOCC(       IBRA,ISTATE,1))
     *                                    *PNMOCC(       IKET,ISTATE,0)
     *            +OPIMRE(IBRA,IKET)*CONJG(PNMOCC(LDBASE+IBRA,ISTATE,1))
     *                                    *PNMOCC(LDBASE+IKET,ISTATE,0)
                END DO
             END DO
C
             IF (IMAREA.EQ.-1) RESULT=RESULT*CMPLX(0.0D0,1.0D0)
C
             IF (IHERMI.EQ.1) THEN
                 AVRVAL(ISTATE)=REAL(RESULT)
             ELSE
                 AVRVAL(ISTATE)=AIMAG(RESULT)
             END IF
C
             AVRVAL(ISTATE)=-2*IMAREA*ITIPAR*AVRVAL(ISTATE)
C
          END DO
!$OMP END PARALLEL DO
C
      END IF
C
      CALL CPUTIM('PNAVER',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVEQUA(AVRVAL,OPCOMP,EWAVEF)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          AUXILI,OPCOMP
      COMPLEX
     *          C_ZERO,C_UNIT
      COMPLEX
     *          ZDOTU
C
      DIMENSION
     *          AVRVAL(1:NDBASE)
      DIMENSION
     *          OPCOMP(1:NDBASE,1:NDBASE)
C=======================================================================
      ALLOCATABLE AUXILI(:,:)
C=======================================================================
      COMPLEX
     *          EWAVEF(1:NDBASE,1:NDBASE)
C=======================================================================
C
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('AVEQUA',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (AUXILI(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXILI','AVEQUA')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE SINGLE-PARTICLE AVERAGE VALUES
C       OF AN OPERATOR 'OPCOMP' (HERMITIAN & COMPLEX IN THE HO BASIS)
C       WITHIN THE SINGLE-PARTICLE STATES.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
C=======================================================================
C
      CALL ZGEMM('C','N',LDBASE,LDBASE,LDBASE,C_UNIT,EWAVEF,NDBASE,
     *                   OPCOMP,NDBASE,C_ZERO,AUXILI,NDBASE)
      DO ISTATE=1,LDBASE
C
         AVRVAL(ISTATE) = REAL(ZDOTU(LDBASE,AUXILI(ISTATE,1),NDBASE,
     *                                      EWAVEF(1,ISTATE),1))
C
      END DO
C
C=======================================================================
      DEALLOCATE (AUXILI)
C=======================================================================
C
      CALL CPUTIM('AVEQUA',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVEQUZ(AVRVAL,OPE_PP,OPE_PM,EWAVEF)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          AVRVAL(1:2*NDBASE)
      DIMENSION
     *          OPE_PP(1:NDBASE,1:NDBASE,0:NDREVE),
     *          OPE_PM(1:NDBASE,1:NDBASE,0:NDREVE)
C=======================================================================
      ALLOCATABLE AUXILI(:,:),OPERAT(:,:)
C=======================================================================
      COMPLEX
     *          EWAVEF(1:2*NDBASE,1:2*NDBASE)
C=======================================================================
      COMPLEX
     *          AUXILI,OPE_PP,OPE_PM,OPERAT
      COMPLEX
     *          C_ZERO,C_UNIT
      COMPLEX
     *          ZDOTU
C
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('AVEQUZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (AUXILI(1:2*NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXILI','AVEQUZ')
      ALLOCATE (OPERAT(1:2*NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXILI','AVEQUZ')
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE SINGLE-PARTICLE  AVERAGE  VALUES
C       OF AN OPERATOR IN THE NO-SYMMETRY  CASE  (HERMITIAN  &  COMPLEX
C       IN THE HO BASIS) WITHIN THE SINGLE-PARTICLE STATES. ITS  MATRIX
C       ELEMENTS IN THE "PP"+"PM" REPRESENTATION ARE STORED  IN  ARRAYS
C       "OPE_PP" AND "OPE_PM".
C=======================================================================
C
      DO J=1,LDBASE
         DO I=1,LDBASE
            OPERAT(I,       J       ) = OPE_PP(I,J,0)
            OPERAT(I+LDBASE,J       ) = OPE_PM(I,J,1)
            OPERAT(I,       J+LDBASE) = OPE_PM(I,J,0)
            OPERAT(I+LDBASE,J+LDBASE) = OPE_PP(I,J,1)
         END DO
      END DO
C
      CALL ZGEMM('C','N',2*LDBASE,2*LDBASE,2*LDBASE,C_UNIT,EWAVEF,
     *                   2*NDBASE,  OPERAT,2*NDBASE,C_ZERO,AUXILI,
     *                   2*NDBASE)
C
      DO ISTATE=1,2*LDBASE
C
         AVRVAL(ISTATE) = REAL(ZDOTU(2*LDBASE,AUXILI(ISTATE,1),
     *                               2*NDBASE,EWAVEF(1,ISTATE),1))
C
      END DO
C
C=======================================================================
      DEALLOCATE (AUXILI)
C=======================================================================
C
      CALL CPUTIM('AVEQUZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AVEMIZ(AVRVAL,OPE_PP,OPE_PM,EWAVEF)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          AVRVAL(1:4*NDBASE)
      DIMENSION
     *          OPE_PP(1:2*NDBASE,1:2*NDBASE,0:NDREVE),
     *          OPE_PM(1:2*NDBASE,1:2*NDBASE,0:NDREVE)
C=======================================================================
      ALLOCATABLE AUXILI(:,:),OPERAT(:,:)
C=======================================================================
      COMPLEX
     *          EWAVEF(1:4*NDBASE,1:4*NDBASE)
      COMPLEX
     *          AUXILI,OPE_PP,OPE_PM,OPERAT
      COMPLEX
     *          C_ZERO,C_UNIT
      COMPLEX
     *          ZDOTU
C
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('AVEMIZ',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (AUXILI(1:4*NDBASE,1:4*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXILI','AVEMIZ')
      ALLOCATE (OPERAT(1:4*NDBASE,1:4*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXILI','AVEMIZ')
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE SINGLE-PARTICLE  AVERAGE  VALUES
C       OF AN OPERATOR IN THE NO-SYMMETRY  CASE  (HERMITIAN  &  COMPLEX
C       IN THE HO BASIS) WITHIN THE SINGLE-PARTICLE STATES. ITS  MATRIX
C       ELEMENTS IN THE "PP"+"PM" REPRESENTATION ARE STORED  IN  ARRAYS
C       "OPE_PP" AND "OPE_PM".
C=======================================================================
C
      DO J=1,2*LDBASE
         DO I=1,2*LDBASE
            OPERAT(I,         J         ) = OPE_PP(I,J,0)
            OPERAT(I+2*LDBASE,J         ) = OPE_PM(I,J,1)
            OPERAT(I,         J+2*LDBASE) = OPE_PM(I,J,0)
            OPERAT(I+2*LDBASE,J+2*LDBASE) = OPE_PP(I,J,1)
         END DO
      END DO
C
      CALL ZGEMM('C','N',4*LDBASE,4*LDBASE,4*LDBASE,C_UNIT,EWAVEF,
     *                   4*NDBASE,  OPERAT,4*NDBASE,C_ZERO,AUXILI,
     *                   4*NDBASE)
C
      DO ISTATE=1,4*LDBASE
C
         AVRVAL(ISTATE) = REAL(ZDOTU(4*LDBASE,AUXILI(ISTATE,1),
     *                               4*NDBASE,EWAVEF(1,ISTATE),1))
C
      END DO
C
C=======================================================================
      DEALLOCATE (AUXILI)
C=======================================================================
C
      CALL CPUTIM('AVEMIZ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE EKINET(ENEKIN,DLINSQ,EKEKIN,DKINSQ,ITWCEN)
C=======================================================================
      USE MAT_PP
C=======================================================================
      USE hfodd_sizes
      USE hfodd_twocen
      USE TWCOBO
      USE BIGDEN
C=======================================================================
      COMPLEX
     *          RESULT,EKEKIN
      COMPLEX
     *          DKINSQ
C=======================================================================
      ALLOCATABLE HAUXPP(:,:)
C=======================================================================
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPP','EKINET')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE AVERAGE KINETIC ENERGY
C=======================================================================
C       TWO-CENTRE BASIS OPTION: IF A SHIFT IN THE Y-AXIS IS PRESENT
C       THE PM SIMPLEX BLOCKS CAN CONTAIN NON-ZERO ELEMENTS. THEN, THE
C       ENTIRE MATRIX IS NEEDED.
C       ATTENTION: TWC_INTKIN DOES NOT INCLUDE THE PHASE IPHAPP AS IN
C       ONE-CENTRE VERSION. THE PROPER STRUCTURE IS BUILT IN TWC_BIGSIM.
C       (SEE COMMENTS IN AVANGY)
C=======================================================================
C
      FACTOR=1.0D0
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INTKIN(HAUXPP,FACTOR,1)
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
C
                RESULT=RESULT+HAUXPP(IBRA,IKET)*(BIG_PP(IKET,IBRA,0)
     *                                         + BIG_PP(IKET,IBRA,1))
C
             END DO
          END DO
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IMAREA=1
          KARTEZ=0
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_INTKIN(HAUXPP,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPP,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
C
          RESULT=C_ZERO
C
          DO IBRA=1,2*LDBTOT
             DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
             END DO
          END DO
C
      END IF
C
      DLINSQ=REAL(RESULT)
      DKINSQ=RESULT
C
      ENEKIN=HBMRPA*DLINSQ
      EKEKIN=HBMRPA*DKINSQ
C
C=======================================================================
      DEALLOCATE (HAUXPP)
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C@@@ SHELL -SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
      SUBROUTINE KINSIZ(NUMCOU,BOUCOU,IKERNE,ISIMPY,ISIGNY,ISIQTY,
     *                                       ICHARG,KMULMO,ISHIFY)
C=======================================================================
      USE HCOULO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,CMPLPP,CMPLPM
      COMPLEX
     *          EWAVEF
      COMPLEX
     *          QMUT_N,QMUT_P,QMUT_T
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE FREGAS(:,:),CMPLPP(:,:),CMPLPM(:,:),EWAVEF(:,:)
C=======================================================================
C
      DIMENSION
     *          ESINGP(1:2*NDBASE)
C
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /QMUTTI/ QMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /KIN_SP/ SPGASP(1:2*NDBASE),SPGASN(1:2*NDBASE)
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /TSTQPR/ ISQPRO
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C      THE SUBROUTINE COMPUTES THE EIGENVALUES OF THE FREE GAS OF
C      NEUTRONS  OR  PROTONS (DEPENDING ON ICHARG) IN THE CASE OF
C      BROKEN SIMPLEX.  THE SIMPLEX  OFF-DIAGONAL  COMPONENT ONLY
C      APPEARS FOR PROTON AND IS CAUSED BY THE COULOMB POTENTIAL.
C      IN THIS CASE, THE EIGENVALUES ARE  NOT DEGENERATE ANYMORE,
C      AND THE SIZE OF THE VECTOR IS TWICE WHAT IT IS IN  KINSIG.
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (FREGAS(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FREGAS','KINSIZ')
      ALLOCATE (CMPLPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMPLPP','KINSIZ')
      ALLOCATE (CMPLPM(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMPLPM','KINSIZ')
      ALLOCATE (EWAVEF(1:2*NDBASE,1:2*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAVEF','KINSIZ')
      ALLOCATE (CELMTS(1:(2*NDBASE+1)*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','KINSIZ')
C=======================================================================
C
      DO J=1,LDBASE
         DO I=1,LDBASE
            CMPLPP(I,J)=CMPLX(0.0D0,0.0D0)
            CMPLPM(I,J)=CMPLX(0.0D0,0.0D0)
         END DO
      END DO
C
C=======================================================================
C      CALCULATING THE MATRIX ELEMENTS OF THE KINETIC ENERGY (FREE GAS)
C=======================================================================
C
      HBMAUX=20.7362D0
C
      CALL INTKIN(FREGAS,HBMAUX,1)
C
      CALL PUTREA(+1,FREGAS,CMPLPP)
C
C=======================================================================
C      CALCULATING THE COULOMB MATRIX ELEMENTS (AT CONVERGENCE)
C=======================================================================
C
      IF (ICHARG.EQ.1) THEN
C
C          Check if proton moments have been computed already; If not,
C          recalculate them based on the latest proton density
          IF (ISQPRO.EQ.0) THEN
C
              CALL GETDEN(ISIMPY,ICHARG)
C
              CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,QMUL_P,QMUT_P,
     *                                  COMULT,KMULMO,ISHIFY,1)
C
          END IF
C
          CALL COUMAT(NUMCOU,BOUCOU,ISIMPY,IKERNE)
C
          DO J=1,LDBASE
             DO I=1,LDBASE
                FREGAS(I,J)=REAL(HPPCOU(I,J))
             END DO
          END DO
          CALL PUTREA(+1,FREGAS,CMPLPP)
C
          DO J=1,LDBASE
             DO I=1,LDBASE
                FREGAS(I,J)=REAL(HPMCOU(I,J))
             END DO
          END DO
          CALL PUTREA(+1,FREGAS,CMPLPM)
C
      END IF
C
C=======================================================================
C      CONSTRUCTING AND DIAGONALIZING THIS MATRIX
C=======================================================================
C
      NCOUNT=0
C
      DO IKET=1,2*LDBASE
         DO IBRA=IKET,2*LDBASE
C
            NCOUNT=NCOUNT+1
C
            IF (IBRA.LE.LDBASE.AND.IKET.LE.LDBASE)
     *
     *          CELMTS(NCOUNT)=CMPLPP(IBRA,IKET)
C
            IF (IBRA.GT.LDBASE.AND.IKET.LE.LDBASE)
     *
     *          CELMTS(NCOUNT)=CMPLPM(IBRA-LDBASE,IKET)
C
            IF (IBRA.GT.LDBASE.AND.IKET.GT.LDBASE)
     *
     *          CELMTS(NCOUNT)=CMPLPP(IBRA-LDBASE,IKET-LDBASE)
C
         END DO
      END DO
C
      CALL DIAMAT(CELMTS,ESINGP,EWAVEF,2*LDBASE,2*NDBASE,
     *                          NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG))
C
C=======================================================================
C      STORING EIGENVALUES IN VECTORS PASSED TO WSHELL
C=======================================================================
C
      IF (ICHARG.EQ.0) THEN
          DO I=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
             SPGASN(I)=ESINGP(I)
          END DO
      ELSE
          DO I=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
             SPGASP(I)=ESINGP(I)
          END DO
      END IF
C
C=======================================================================
      DEALLOCATE (CELMTS,FREGAS,CMPLPP,CMPLPM,EWAVEF)
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE KINSIG(NUMCOU,BOUCOU,IKERNE,ISIMPY,ISIGNY,ISIQTY,
     *                  ICHARG,KMULMO,ISHIFY,MREVER)
C=======================================================================
      USE HCOULO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          CELMTS,CMPLPP
      COMPLEX
     *          EWAVEF
      COMPLEX
     *          QMUT_N,QMUT_P,QMUT_T
C=======================================================================
      ALLOCATABLE CELMTS(:)
      ALLOCATABLE FREGAS(:,:),CMPLPP(:,:),EWAVEF(:,:)
C=======================================================================
C
      DIMENSION
     *          ESINGP(1:NDBASE)
C
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /QMUTTI/ QMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /KIN_SP/ SPGASP(1:2*NDBASE),SPGASN(1:2*NDBASE)
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /TSTQPR/ ISQPRO
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C      THE  SUBROUTINE  COMPUTES THE EIGENVALUES OF THE FREE GAS OF
C      NEUTRONS  OR  PROTONS (DEPENDING ON  ICHARG ) IN THE CASE OF
C      CONSERVED SIMPLEX. SINCE NEITHER THE KINETIC ENERGY OPERATOR
C      NOR THE COULOMB POTENTIAL CONTAINS A TIME-REVERSAL  SYMMETRY
C      COMPONENT, ONLY  ONE  HALF  OF THE  TOTAL MATRIX NEEDS TO BE
C      COMPUTED (POSITIVE SIMPLEX BY CONVENTION).
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (FREGAS(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('FREGAS','KINSIG')
      ALLOCATE (CMPLPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CMPLPP','KINSIG')
      ALLOCATE (EWAVEF(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('EWAVEF','KINSIG')
      ALLOCATE (CELMTS(1:(2*NDBASE+1)*NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('CELMTS','KINSIG')
C=======================================================================
C
      DO J=1,LDBASE
         DO I=1,LDBASE
            CMPLPP(I,J)=CMPLX(0.0D0,0.0D0)
         END DO
      END DO
C
C=======================================================================
C      CALCULATING THE MATRIX ELEMENTS OF THE KINETIC ENERGY (FREE GAS)
C=======================================================================
C
      HBMAUX=20.7362D0
C
      CALL INTKIN(FREGAS,HBMAUX,1)
C
      CALL PUTREA(+1,FREGAS,CMPLPP)
C
C=======================================================================
C      CALCULATING THE COULOMB MATRIX ELEMENTS (AT CONVERGENCE)
C=======================================================================
C
      IF (ICHARG.EQ.1) THEN
C
C          Check if proton moments have been computed already; If not,
C          recalculate them based on the latest proton density
          IF (ISQPRO.EQ.0) THEN
C
              CALL GETDEN(ISIMPY,ICHARG)
C
              CALL MOMETS(ISIMPY,ISIGNY,ISIQTY,QMUL_P,QMUT_P,
     *                                  COMULT,KMULMO,ISHIFY,1)
C
          END IF
C
          CALL COUMAT(NUMCOU,BOUCOU,ISIMPY,IKERNE)
C
          DO J=1,LDBASE
             DO I=1,LDBASE
                FREGAS(I,J)=REAL(HPPCOU(I,J))
             END DO
          END DO
          CALL PUTREA(+1,FREGAS,CMPLPP)
C
      END IF
C
C=======================================================================
C      CONSTRUCTING AND DIAGONALIZING THIS MATRIX
C=======================================================================
C
      NCOUNT=0
C
      DO IKET=1,LDBASE
         DO IBRA=IKET,LDBASE
C
            NCOUNT=NCOUNT+1
C
            CELMTS(NCOUNT)=CMPLPP(IBRA,IKET)
C
         END DO
      END DO
C
      CALL DIAMAT(CELMTS,ESINGP,EWAVEF,LDBASE,NDBASE,
     *                          NUMBSP(0,ICHARG))
C
C=======================================================================
C      STORING EIGENVALUES IN VECTORS PASSED TO WSHELL
C=======================================================================
C
      IF (ICHARG.EQ.0) THEN
          DO I=1,NUMBSP(0,ICHARG)
             SPGASN(I)=ESINGP(I)
          END DO
      ELSE
          DO I=1,NUMBSP(0,ICHARG)
             SPGASP(I)=ESINGP(I)
          END DO
      END IF
C
      IF (MREVER.EQ.1) THEN
C
          IF (ICHARG.EQ.0) THEN
              DO I=1,NUMBSP(1,ICHARG)
                 SPGASN(I+MREVER*NUMBSP(0,ICHARG))=ESINGP(I)
              END DO
          ELSE
              DO I=1,NUMBSP(1,ICHARG)
                 SPGASP(I+MREVER*NUMBSP(0,ICHARG))=ESINGP(I)
              END DO
          END IF
C
      END IF
C
C=======================================================================
      DEALLOCATE (CELMTS,FREGAS,CMPLPP,EWAVEF)
C=======================================================================
C
      RETURN
      END
C
C@@@ SHELL -SHELL - SHELL - SHELL - SHELL - SHELL - SHELL - SHELL
C=======================================================================
C
      SUBROUTINE EPOTHO(ENE_HO)
C=======================================================================
      USE MAT_PP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          RESULT
C=======================================================================
      ALLOCATABLE HAUXPP(:,:)
C=======================================================================
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXPP(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPP','EPOTHO')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE POTENTIAL HO ENERGY
C=======================================================================
C
      ESCALE=0.0D0
C
       CALL INT_HO(HAUXPP,HBMASS,ESCALE,HBAROX(1),HBAROY(1),HBAROZ(1),1)
C
       RESULT=CMPLX(0.0D0,0.0D0)
C
       DO IBRA=1,LDBASE
         DO IKET=1,LDBASE
C
            RESULT=RESULT+HAUXPP(IBRA,IKET)*(BIG_PP(IKET,IBRA,0)
     *                                     + BIG_PP(IKET,IBRA,1))
C
         END DO
       END DO
C
       ENE_HO=REAL(RESULT)
C
C=======================================================================
      DEALLOCATE (HAUXPP)
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SPIMOM(ISIMPY,IROTAT,SPINTO,SPININ,ITWCEN)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE TWCOBO
      USE BIGDEN
C=======================================================================
      USE hfodd_sizes
      USE hfodd_twocen
C=======================================================================
      COMPLEX
     *          RESULT
C=======================================================================
      DIMENSION
     *          SPINTO(1:NDKART),SPININ(1:NDKART)
C=======================================================================
      ALLOCATABLE HAUXPM(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('SPIMOM',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXPM(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPM','SPIMOM')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE AVERAGE TOTAL     SPIN
C                              AND THE AVERAGE INTRINSIC SPIN
C=======================================================================
C       TWO-CENTRE BASIS OPTION: SEE COMMENTS IN AVANGY
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         SPINTO(KARTEZ)=0.0D0
         SPININ(KARTEZ)=0.0D0
C
      END DO
C
      IF (IROTAT.NE.1) GO TO 1
C
C=======================================================================
C
      FACTOR=1.0D0
C
      IF (ISIMPY.EQ.1) GO TO 2
C
C=======================================================================
C                             O R B I T A L   X-DIRECTION
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_LX(IPHAPM(0,0,0),HAUXPM,FACTOR)
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
C
                RESULT=RESULT + HAUXPM(IBRA,IKET) * BIG_PM(IKET,IBRA,0)
C
             END DO
          END DO
C
          SPIORB=2*AIMAG(RESULT)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IMAREA=-1
          KARTEZ=0
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_LX(HAUXPM,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPM,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,2*LDBTOT
             DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
             END DO
          END DO
C
          SPIORB=AIMAG(RESULT)
C
      END IF
C
C=======================================================================
C                           I N T R I N S I C   X-DIRECTION
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_SX(HAUXPM,FACTOR)
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
C
                RESULT=RESULT + HAUXPM(IBRA,IKET) * BIG_PM(IKET,IBRA,0)
C
             END DO
          END DO
C
          SPININ(1)=2*REAL(RESULT)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IMAREA=1
          KARTEZ=1
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_SX(HAUXPM,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPM,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,2*LDBTOT
             DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
             END DO
          END DO
C
          SPININ(1)=REAL(RESULT)
C
      END IF
C
      SPINTO(1)=SPININ(1)+SPIORB
C
C=======================================================================
C                             O R B I T A L   Z-DIRECTION
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_LZ(IPHAPM(0,0,0),HAUXPM,FACTOR)
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
C
                RESULT=RESULT + HAUXPM(IBRA,IKET) * BIG_PM(IKET,IBRA,0)
C
             END DO
          END DO
C
          SPIORB=2*AIMAG(RESULT)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IMAREA=-1
          KARTEZ=0
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_LZ(HAUXPM,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPM,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,2*LDBTOT
             DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
             END DO
          END DO
C
          SPIORB=AIMAG(RESULT)
C
      END IF
C
C=======================================================================
C                           I N T R I N S I C   Z-DIRECTION
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_SZ(HAUXPM,FACTOR)
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
C
                RESULT=RESULT + HAUXPM(IBRA,IKET) * BIG_PM(IKET,IBRA,0)
C
             END DO
          END DO
C
          SPININ(3)=2*AIMAG(RESULT)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IMAREA=-1
          KARTEZ=3
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_SZ(HAUXPM,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPM,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,2*LDBTOT
             DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
             END DO
          END DO
C
          SPININ(3)=AIMAG(RESULT)
C
      END IF
C
      SPINTO(3)=SPININ(3)+SPIORB
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C                             O R B I T A L   Y-DIRECTION
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_LY(IPHAPP(0,0,0),HAUXPM,FACTOR)
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
C
                RESULT=RESULT + HAUXPM(IBRA,IKET) * (BIG_PP(IKET,IBRA,0)
     *                                             +BIG_PP(IKET,IBRA,1))
C
             END DO
          END DO
C
          RESULT=RESULT*CMPLX(0.0D0,1.0D0)
C
          SPIORB=REAL(RESULT)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IMAREA=-1
          KARTEZ=0
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_LY(HAUXPM,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPM,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,2*LDBTOT
             DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
             END DO
          END DO
C
          RESULT=RESULT*CMPLX(0.0D0,1.0D0)
C
          SPIORB=REAL(RESULT)
C
      END IF
C
C=======================================================================
C                           I N T R I N S I C   Y-DIRECTION
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_SY(HAUXPM,FACTOR)
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
C
                RESULT=RESULT + HAUXPM(IBRA,IKET) * (BIG_PP(IKET,IBRA,0)
     *                                             -BIG_PP(IKET,IBRA,1))
C
             END DO
         END DO
C
          SPININ(2)=REAL(RESULT)
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          IMAREA=1
          KARTEZ=2
          DO LTWCEN=1,NDTWBL
C
             CALL TWC_SY(HAUXPM,FACTOR,LTWCEN)
             CALL TWC_BIGSIM(HAUXPM,LTWCEN,IMAREA,KARTEZ)
C
          END DO
C
          CALL TWC_BIGOBO
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,2*LDBTOT
             DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
             END DO
          END DO
C
          SPININ(2)=REAL(RESULT)
C
      END IF
C
      SPINTO(2)=SPININ(2)+SPIORB
C
C=======================================================================
C
    1 CONTINUE
C
C=======================================================================
      DEALLOCATE (HAUXPM)
C=======================================================================
C
      CALL CPUTIM('SPIMOM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SPIKER(ISIMPY,IROTAT,SPININ)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          RESULT,SPININ,UNIT_I
C=======================================================================
      DIMENSION
     *          SPININ(1:NDKART)
C=======================================================================
      ALLOCATABLE HAUXPM(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('SPIKER',1)
C
C=======================================================================
      ALLOCATE (HAUXPM(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXPM','SPIKER')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE INTRINSIC SPIN KERNELS FOR
C          THE GAMOW-TELLER TRANSITIONS (CALLED FROM BETAME)
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         SPININ(KARTEZ)=CMPLX(0.0D0,0.0D0)
C
      END DO
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      IF (IROTAT.NE.1) GO TO 1
C
C=======================================================================
C
      FACTOR=1.0D0
C
      IF (ISIMPY.EQ.1) GO TO 2
C
C=======================================================================
C                           I N T R I N S I C   X-DIRECTION
C=======================================================================
C
      CALL INT_SX(HAUXPM,FACTOR)
C
      RESULT=CMPLX(0.0D0,0.0D0)
C
      DO IBRA=1,LDBASE
         DO IKET=1,LDBASE
C
            RESULT=RESULT + HAUXPM(IBRA,IKET) * (BIG_PM(IKET,IBRA,0)
     *                                          +BIG_PM(IKET,IBRA,1))
C
         END DO
      END DO
C
      SPININ(1)=RESULT
C
C=======================================================================
C                           I N T R I N S I C   Z-DIRECTION
C=======================================================================
C
      CALL INT_SZ(HAUXPM,FACTOR)
C
      RESULT=CMPLX(0.0D0,0.0D0)
C
      DO IBRA=1,LDBASE
         DO IKET=1,LDBASE
C
            RESULT=RESULT + HAUXPM(IBRA,IKET) * (BIG_PM(IKET,IBRA,0)
     *                                          -BIG_PM(IKET,IBRA,1))
C
         END DO
      END DO
C
      SPININ(3)=-UNIT_I*RESULT
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C                           I N T R I N S I C   Y-DIRECTION
C=======================================================================
C
      CALL INT_SY(HAUXPM,FACTOR)
C
      RESULT=CMPLX(0.0D0,0.0D0)
C
      DO IBRA=1,LDBASE
         DO IKET=1,LDBASE
C
            RESULT=RESULT + HAUXPM(IBRA,IKET) * (BIG_PP(IKET,IBRA,0)
     *                                          -BIG_PP(IKET,IBRA,1))
C
         END DO
      END DO
C
      SPININ(2)=RESULT
C
C=======================================================================
C
    1 CONTINUE
C
C=======================================================================
      DEALLOCATE (HAUXPM)
C=======================================================================
C
      CALL CPUTIM('SPIKER',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ANGSHI(ALINLI,ANGUTO,ANGSTO)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          ALINLI(0:NDKART),ANGUTO(1:NDKART),ANGSTO(1:NDKART)
C
      COMMON
     *       /SHIFTR/ RSHIFT(1:NDKART)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE AVERAGE ORBITAL ANGULAR MOMENTUM
C       IN THE CENTER-OF-MASS REFERENCE FRAME
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         KARTEP=KARTEZ+1
         IF (KARTEP.GT.NDKART) KARTEP=KARTEP-NDKART
C
         KARTEM=KARTEZ+2
         IF (KARTEM.GT.NDKART) KARTEM=KARTEM-NDKART
C
         ANGSTO(KARTEZ)=ANGUTO(KARTEZ)-RSHIFT(KARTEP)*ALINLI(KARTEM)
     *                                +RSHIFT(KARTEM)*ALINLI(KARTEP)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ANGROT(ALPACT,BETACT,GAMACT,YSHI_N,YSHI_P,YSHI_T,
     *                                       YROT_N,YROT_P,YROT_T)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          YSHI_N(1:NDKART),YSHI_P(1:NDKART),YSHI_T(1:NDKART)
      DIMENSION
     *          YROT_N(1:NDKART),YROT_P(1:NDKART),YROT_T(1:NDKART)
      DIMENSION
     *          XSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *          XSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *          XSHI_T(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          XROT_N(0:NDMULT,-NDMULT:NDMULT),
     *          XROT_P(0:NDMULT,-NDMULT:NDMULT),
     *          XROT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE AVERAGE ORBITAL OR SPIN ANGULAR
C       MOMENTA IN THE INTRINSIC REFERENCE FRAME
C=======================================================================
C
      PI=4.0D0*ATAN(1.00D0)
C
C=======================================================================
C       CALCULATION OF SPHERICAL COMPONENTS.
C=======================================================================
C       VALUE FOR L=0 AND MULTIPLICATION BY "AUNITS" ARE SPURIOUS;
C       THEY ARE REQUIRED ONLY IN ORDER TO ENSURE A  COMPATIBILITY
C       WITH THE CALL TO "PAXMOM" BELOW.
C=======================================================================
C
      XSHI_N(0, 0)= 0.0
      XSHI_N(1, 1)=-YSHI_N(1)/SQRT(8*PI/3)*AUNITS(1,1)
      XSHI_N(1,-1)= YSHI_N(2)/SQRT(8*PI/3)*AUNITS(1,1)
      XSHI_N(1, 0)= YSHI_N(3)/SQRT(4*PI/3)*AUNITS(1,0)
C
      XSHI_P(0, 0)= 0.0
      XSHI_P(1, 1)=-YSHI_P(1)/SQRT(8*PI/3)*AUNITS(1,1)
      XSHI_P(1,-1)= YSHI_P(2)/SQRT(8*PI/3)*AUNITS(1,1)
      XSHI_P(1, 0)= YSHI_P(3)/SQRT(4*PI/3)*AUNITS(1,0)
C
      XSHI_T(0, 0)= 0.0
      XSHI_T(1, 1)=-YSHI_T(1)/SQRT(8*PI/3)*AUNITS(1,1)
      XSHI_T(1,-1)= YSHI_T(2)/SQRT(8*PI/3)*AUNITS(1,1)
      XSHI_T(1, 0)= YSHI_T(3)/SQRT(4*PI/3)*AUNITS(1,0)
C
C=======================================================================
C       ROTATION OF SPHERICAL COMPONENTS
C=======================================================================
C
      KSHIAN=1
      KROTAN=1
C
      CALL PAXMOM(KSHIAN,KROTAN,AUNITS,XSHI_N,XSHI_P,XSHI_T,
     *            ALPACT,BETACT,GAMACT,XROT_N,XROT_P,XROT_T)
C
C=======================================================================
C       CALCULATION OF CARTESIAN COMPONENTS
C=======================================================================
C
      YROT_N(1)=-SQRT(8*PI/3)*XROT_N(1, 1)/AUNITS(1,1)
      YROT_N(2)= SQRT(8*PI/3)*XROT_N(1,-1)/AUNITS(1,1)
      YROT_N(3)= SQRT(4*PI/3)*XROT_N(1, 0)/AUNITS(1,0)
C
      YROT_P(1)=-SQRT(8*PI/3)*XROT_P(1, 1)/AUNITS(1,1)
      YROT_P(2)= SQRT(8*PI/3)*XROT_P(1,-1)/AUNITS(1,1)
      YROT_P(3)= SQRT(4*PI/3)*XROT_P(1, 0)/AUNITS(1,0)
C
      YROT_T(1)=-SQRT(8*PI/3)*XROT_T(1, 1)/AUNITS(1,1)
      YROT_T(2)= SQRT(8*PI/3)*XROT_T(1,-1)/AUNITS(1,1)
      YROT_T(3)= SQRT(4*PI/3)*XROT_T(1, 0)/AUNITS(1,0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MOMETS(ISIMPY,ISIGNY,ISIQTY,QMOMUL,QMOMUT,
     *                         COFMUL,NMOMUL,ISHIFY,ITWCEN)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE TWCOBO
      USE BIGDEN
      USE BIGOVE
C=======================================================================
      USE hfodd_sizes
      USE hfodd_twocen
C=======================================================================
      COMPLEX
     *          RESULT,C_ZERO,QMOMUT
C=======================================================================
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          QMOMUT(0:NDMULT,-NDMULT:NDMULT)
C=======================================================================
      ALLOCATABLE ELEMUL(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('MOMETS',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (ELEMUL(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELEMUL','MOMETS')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES  AND RETURNS IN "QMOMUL" AND "QMOMUT"
C       THE AVERAGE VALUES OF THE ELECTROMAGNETIC MULTIPOLE MOMENTS
C
C                     R**LAMBDA*CONJG(Y(LAMBDA,MIU))
C
C       SEE J.D. JACKSON, CLASSICAL ELECTRODYNAMICS,  EQ. (4.3)
C=======================================================================
C       AVERAGE VALUES OF THE ELECTROMAGNETIC  MULTIPOLE  MOMENTS
C       ARE CALCULATED FROM AVERAGE VALUES OF POWERS OF POSITIONS,
C       THAT ARE TRANSMITTED IN THE  "COFMUL"   ARRAY.  THEREFORE,
C       THIS SUBROUTINE CAN CALCULATE THE MULTIPOLE MOMENTS  WITH
C       RESPECT TO A SHIFTED REFERENCE FRAME, PROVIDED  THAT  THE
C       POWERS OF SHIFTED POSITIONS ARE TRANSMITTED  IN  "COFMUL".
C=======================================================================
C       1) ELEMENTS OF THE QMOMUL  ARRAY FOR NON-NEGATIVE INDICES "MIU"
C          CONTAIN    REAL    PARTS OF  MULTIPOLE  MOMENTS  WITH  THESE
C          SAME VALUES OF THE MAGNETIC QUANTUM NUMBER "MIU".
C       2) ELEMENTS OF THE QMOMUL  ARRAY FOR   NEGATIVE   INDICES "MIU"
C          CONTAIN IMAGINARY  PARTS OF  MULTIPOLE  MOMENTS  WITH  THESE
C          SAME VALUES OF THE MAGNETIC QUANTUM NUMBER "MIU".
C       3) ELEMENTS OF THE QMOMUT  ARRAY FOR NON-NEGATIVE INDICES "MIU"
C          CONTAIN COMPLEX TRANSITION MATRIX ELEMENTS OF  -- R E A L --
C          PARTS OF MULTIPOLE OPERATORS WITH THESE SAME VALUES  OF  THE
C          MAGNETIC QUANTUM NUMBER "MIU".
C       4) ELEMENTS OF THE QMOMUT  ARRAY FOR   NEGATIVE   INDICES "MIU"
C          CONTAIN COMPLEX TRANSITION MATRIX ELEMENTS OF  - IMAGINARY -
C          PARTS OF MULTIPOLE OPERATORS WITH THESE SAME VALUES  OF  THE
C          MAGNETIC QUANTUM NUMBER "MIU".
C=======================================================================
C       FOR CONSERVED SIMPLEX (ISIMPY=1):
C       ONLY THE MIU>=0 MOMENTS ARE CALCULATED.
C=======================================================================
C       FOR CONSERVED SIGNATURE (ISIGNY=1):
C       1) THE MIU>=0 MOMENTS  ARE CALCULATED ONLY FOR EVEN MOMENTS.
C       2) THE MIU <0 MOMENTS  ARE CALCULATED ONLY FOR ODD  MOMENTS.
C=======================================================================
C       FOR CONSERVED PARITY (ISIQTY=1):
C       ONLY THE EVEN MOMENTS ARE CALCULATED.
C=======================================================================
C       SEE "MULCOU" FOR THE TABLE WITH ALL ISIMPY/ISIGNY COMBINATIONS
C=======================================================================
C       TWO-CENTRE BASIS OPTION: SEE COMMENTS IN AVANGY
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            QMOMUL(LAMBDA,MIU)=0.0D0
            QMOMUT(LAMBDA,MIU)=C_ZERO
C
         END DO
      END DO
C
C=======================================================================
C       ONE OR TWO-CENTRE BASIS CONDITION (NOT INTENDED)
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
C=======================================================================
C        HERE THE MIU>=0 MOMENTS ARE CALCULATED AND STORED IN THE
C        "QMOMUL" AND "QMOMUT" ARRAYS FOR NON-NEGATIVE VALUES OF "MIU"
C=======================================================================
C
      IMAREA=1
C
      DO LAMBDA=0,NMOMUL
         DO MIU=0,LAMBDA
C
            IF (MOD(LAMBDA,2).EQ.0.OR.ISIGNY.NE.1) THEN
C
                CALL INTMUL(IPHAPP(0,0,0),ELEMUL,COFMUL,
     *                                LAMBDA,MIU,IMAREA)
C
                RESULT=C_ZERO
C
                DO IBRA=1,LDBASE
                   DO IKET=1,LDBASE
C
                      RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                    * (BIG_PP(IKET,IBRA,0) + BIG_PP(IKET,IBRA,1))
C
                   END DO
                END DO
C
                QMOMUL(LAMBDA,MIU)=REAL(RESULT)
                QMOMUT(LAMBDA,MIU)=     RESULT
C
C=======================================================================
C        IF THERE IS A NON-ZERO Y-SHIFT OF THE CENTER OF MASS FROM THE
C        LABORATORY REFERENCE FRAME, THE REAL  PARTS  OF  THE  SHIFTED
C        MOMENT OPERATORS ARE NO MORE INVARIANT WITH  RESPECT  TO  THE
C        SIMPLEX. FOR THIS REASON, REAL MATRIX ELEMENTS APPEAR ALSO IN
C        THE SIMPLEX-OFF-DIAGONAL BLOCK. IN THE FOLLOWING FRAGMENT  OF
C        THE CODE, CONTRIBUTIONS FROM THESE ELEMENTS  ARE  TAKEN  INTO
C        ACCOUNT. THIS PART IS EXECUTED  ONLY  IF  THE  CENTER-OF-MASS
C        MOMENTS ARE CALCULATED FOR A NON-ZERO Y-SHIFT (ISHIFY=1).
C=======================================================================
C
                IF (ISHIFY.EQ.1.AND.ISIMPY.NE.1) THEN
C
                    CALL INTMUL(IPHAPM(0,0,0),ELEMUL,COFMUL,
     *                                    LAMBDA,MIU,IMAREA)
C
                    RESULT=C_ZERO
C
                    DO IBRA=1,LDBASE
                       DO IKET=1,LDBASE
C
                          RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                                  * BIG_PM(IKET,IBRA,0)
C
                       END DO
                    END DO
C
                    QMOMUL(LAMBDA,MIU)=QMOMUL(LAMBDA,MIU)-2*REAL(RESULT)
C
                END IF
C
            ELSE
C
                QMOMUL(LAMBDA,MIU)=0.0D0
                QMOMUT(LAMBDA,MIU)=C_ZERO
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        HERE THE MIU<0 MOMENTS ARE CALCULATED AND STORED IN THE
C        "QMOMUL" AND "QMOMUT" ARRAYS FOR NEGATIVE VALUES OF "MIU"
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.NMOMUL.GE.1) THEN
C
          IMAREA=-1
C
          DO LAMBDA=1,NMOMUL
             DO MIU=-LAMBDA,-1
C
                IF ((MOD(LAMBDA,2).EQ.1.OR.ISIGNY.NE.1).AND.
     *              (MOD(LAMBDA,2).EQ.0.OR.ISIQTY.NE.1)) THEN
C
                    CALL INTMUL(IPHAPM(0,0,0),ELEMUL,COFMUL,
     *                                    LAMBDA,MIU,IMAREA)
C
                    RESULT=C_ZERO
C
                    DO IBRA=1,LDBASE
                       DO IKET=1,LDBASE
C
                          RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                                  *(BIG_PM(IKET,IBRA,1)
     *                                   -BIG_PM(IKET,IBRA,0))
C
                       END DO
                    END DO
C
                    QMOMUL(LAMBDA,MIU)=REAL(RESULT)
                    QMOMUT(LAMBDA,MIU)=     RESULT
C
C=======================================================================
C        SEE COMMENT FOR REAL PART ABOVE, CHANGING REAL INTO IMAGINARY,
C        INVARIANT INTO ANTI-INVARIANT, AND OFF-DIAGONAL INTO DIAGONAL.
C=======================================================================
C
                    IF (ISHIFY.EQ.1.AND.ISIMPY.NE.1) THEN
C
                        CALL INTMUL(IPHAPP(0,0,0),ELEMUL,COFMUL,
     *                                        LAMBDA,MIU,IMAREA)
C
                        RESULT=C_ZERO
C
                        DO IBRA=1,LDBASE
                           DO IKET=1,LDBASE
C
                              RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                            * (BIG_PP(IKET,IBRA,0)
     *                            +  BIG_PP(IKET,IBRA,1))
C
                           END DO
                        END DO
C
                        QMOMUL(LAMBDA,MIU)=
     *                  QMOMUL(LAMBDA,MIU)+REAL(RESULT)
C
                    END IF
C
                ELSE
C
                    QMOMUL(LAMBDA,MIU)=0.0D0
                    QMOMUT(LAMBDA,MIU)=C_ZERO
C
                END IF
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
C=======================================================================
C
      DO LAMBDA=0,NMOMUL
         DO MIU=-LAMBDA,LAMBDA
C
            IF (MIU.LT.0) IMAREA=-1
            IF (MIU.GE.0) IMAREA= 1
C
            DO LTWCEN=1,NDTWBL
C
               KARTEZ=0
               CALL TWC_INTMUL(ELEMUL,LAMBDA,MIU,IMAREA,LTWCEN)
               CALL TWC_BIGSIM(ELEMUL,LTWCEN,IMAREA,KARTEZ)
C
            END DO
C
            CALL TWC_BIGOBO
C
            RESULT=C_ZERO
C
            DO IBRA=1,2*LDBTOT
               DO IKET=1,2*LDBTOT
                  RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
               END DO
            END DO
C
            QMOMUL(LAMBDA,MIU)=REAL(RESULT)
            QMOMUT(LAMBDA,MIU)=     RESULT
C
         END DO
      END DO
C
C=======================================================================
C
      END IF
C
C=======================================================================
      DEALLOCATE (ELEMUL)
C=======================================================================
C
      CALL CPUTIM('MOMETS',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MOMSIF(ISIMPY,ISIGNY,ISIQTY,QMOMUL,QMOMUT,
     *                                       COFMUL,NMOSIF)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          RESULT,C_ZERO,QMOMUT
C=======================================================================
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          QMOMUT(0:NDMULT,-NDMULT:NDMULT)
C=======================================================================
      ALLOCATABLE ELEMUL(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('MOMSIF',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (ELEMUL(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELEMUL','MOMSIF')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES  AND RETURNS IN "QMOMUL"
C       THE AVERAGE VALUES OF THE SURFACE MULTIPOLE MOMENTS
C                 R**(LAMBDA+2)*CONJG(Y(LAMBDA,MIU))
C
C       SEE THE APPROPRIATE REFERENCE TO BE QUOTED  HERE  LATER.
C=======================================================================
C       THE STRUCTURE OF THIS SUBROUTINE IS EXACTLY THE SAME  AS
C       THE STRUCTURE OF SUBROUTINE "MOMETS"; SEE COMMENTS THERE
C       FOR MORE DETAILS.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            QMOMUL(LAMBDA,MIU)=0.0D0
            QMOMUT(LAMBDA,MIU)=C_ZERO
C
         END DO
      END DO
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.49T) AND  (3.12A),  CALCULATION
C                    OF THE TRANSITION MATRIX ELEMENTS  OF  THE  SURFACE
C                    MOMENTS FOR LAMBDA=0 WAS  IMPLEMENTED  INCORRECTLY,
C                    BECAUSE SUBROUTINE MOMSIF WAS NOT SET TO  CALCULATE
C                    THEM. THIS  BUG  WAS  CORRECTED IN VERSION  (3.12D)
C                    ON 24/04/2022.
C=======================================================================
C
C=======================================================================
C        HERE THE MIU>=0 MOMENTS ARE CALCULATED AND STORED IN THE
C        "QMOMUL" AND "QMOMUT" ARRAYS FOR NON-NEGATIVE VALUES OF "MIU"
C=======================================================================
C
      IMAREA=1
C
      DO LAMBDA=0,NMOSIF
         DO MIU=0,LAMBDA
C
            IF (MOD(LAMBDA,2).EQ.0.OR.ISIGNY.NE.1) THEN
C
                CALL INTSIF(IPHAPP(0,0,0),ELEMUL,COFMUL,
     *                                LAMBDA,MIU,IMAREA)
C
                RESULT=CMPLX(0.0D0,0.0D0)
C
                DO IBRA=1,LDBASE
                   DO IKET=1,LDBASE
C
                      RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                    * (BIG_PP(IKET,IBRA,0) + BIG_PP(IKET,IBRA,1))
C
                   END DO
                END DO
C
                QMOMUL(LAMBDA,MIU)=REAL(RESULT)
                QMOMUT(LAMBDA,MIU)=     RESULT
C
            ELSE
C
                QMOMUL(LAMBDA,MIU)=0.0D0
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        HERE THE MIU<0 MOMENTS ARE CALCULATED AND STORED IN THE
C        "QMOMUL" AND "QMOMUT" ARRAYS FOR NEGATIVE VALUES OF "MIU"
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.NMOSIF.GE.1) THEN
C
          IMAREA=-1
C
          DO LAMBDA=1,NMOSIF
             DO MIU=-LAMBDA,-1
C
                IF ((MOD(LAMBDA,2).EQ.1.OR.ISIGNY.NE.1).AND.
     *              (MOD(LAMBDA,2).EQ.0.OR.ISIQTY.NE.1)) THEN
C
                    CALL INTSIF(IPHAPM(0,0,0),ELEMUL,COFMUL,
     *                                    LAMBDA,MIU,IMAREA)
C
                    RESULT=CMPLX(0.0D0,0.0D0)
C
                    DO IBRA=1,LDBASE
                       DO IKET=1,LDBASE
C
                          RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                                  *(BIG_PM(IKET,IBRA,1)
     *                                   -BIG_PM(IKET,IBRA,0))
C
                       END DO
                    END DO
C
                    QMOMUL(LAMBDA,MIU)=REAL(RESULT)
                    QMOMUT(LAMBDA,MIU)=     RESULT
C
                ELSE
C
                    QMOMUL(LAMBDA,MIU)=0.0D0
                    QMOMUT(LAMBDA,MIU)=C_ZERO
C
                END IF
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
      DEALLOCATE (ELEMUL)
C=======================================================================
C
      CALL CPUTIM('MOMSIF',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MOMSCH(QMOSIF,QMOSIT,NMOSIF,QMOMUL,QMOMUT,NMOMUL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          QMOMUT,QMOSIT
C
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT),
     *          QMOSIF(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          QMOMUT(0:NDMULT,-NDMULT:NDMULT),
     *          QMOSIT(0:NDMULT,-NDMULT:NDMULT)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES  AND RETURNS IN "QMOSIF" AND "QMOSIT"
C       THE AVERAGE VALUES OF THE SCHIFF MULTIPOLE MOMENTS
C
C                [R**(LAMBDA+2)*CONJG(Q(LAMBDA,MIU))
C       -5/3<R**2>R**(LAMBDA)  *CONJG(Q(LAMBDA,MIU))]/10
C
C       WHERE Q(LAMBDA,MIU) ARE SPHERICAL HARMONICS WITH THE CPC158-TAB5
C       UNITS INCLUDED, SEE SUBROUTINE DEFUNI.
C
C       THE ORIGINAL SCHIFF MOMENTS CORRESPOND TO LAMBDA=1, SEE PHYSICAL
C       REVIEW C 68, 025501. THE OTHER VALUES ARE CALCULATED AND PRINTED
C       ONLY FOR COMPATIBILITY WITH THE SURFACE MOMENTS.
C
C            ATTENTION! BETWEEN VERSIONS 2.19N AND 2.80M, THE FACTOR  OF
C                       1/10 WAS NOT INCLUDED  IN  THE  SCHIFF  MOMENTS.
C                       ALTHOUGH THIS WAS NOT REALLY A BUG BUT RATHER  A
C                       DEFNITION THAT WAS SUPPOSED TO BE CONFORMED WITH
C                       THE SURFACE MOMENTS,  IT  WAS  CAUSING  CONSTANT
C                       CONFUSION, AND THUS  ON  01/07/2017  IN  VERSION
C                       2.80N THE FACTOR OF 1/10 WAS PUT BACK  INTO  THE
C                       CALCULATED SCHIFF MOMENTS.
C=======================================================================
C       THE SURFACE AND MULTIPOLE MOMENTS ARE SUPPOSED TO BE EARLIER
C       CALCULATED
C=======================================================================
C
      IF (NMOMUL.LT.NMOSIF) STOP 'TOO FEW MULTIPOLE MOMENTS IN MOMSCH'
C
C=======================================================================
C
      RADSQU=REAL(QMOSIT(0,0))/REAL(QMOMUT(0,0))
C
      DO LAMBDA=0,NMOSIF
         DO MIU=-LAMBDA,LAMBDA
C
                QMOSIF(LAMBDA,MIU)=(QMOSIF(LAMBDA,MIU)
     *          -5.0D0/3.0D0*RADSQU*QMOMUL(LAMBDA,MIU))/10.0D0
                QMOSIT(LAMBDA,MIU)=(QMOSIT(LAMBDA,MIU)
     *          -5.0D0/3.0D0*RADSQU*QMOMUT(LAMBDA,MIU))/10.0D0
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MOMPLM(ISIMPY,ISIGNY,ISIQTY,QMOMUL,COFMUL,NMOSIF)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          RESULT
C=======================================================================
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT)
C=======================================================================
      ALLOCATABLE ELEMUL(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('MOMPLM',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (ELEMUL(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELEMUL','MOMPLM')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES  AND  RETURNS  IN  "QMOMUL"
C       THE AVERAGE VALUES OF THE PENSURFACE MULTIPOLE MOMENTS
C                R**(LAMBDA+4)*CONJG(Y(LAMBDA,MIU))
C=======================================================================
C       THE STRUCTURE OF THIS SUBROUTINE IS EXACTLY THE SAME  AS
C       THE STRUCTURE OF SUBROUTINES "MOMETS" AND "MOMSIF";  SEE
C       COMMENTS THERE FOR MORE DETAILS.
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            QMOMUL(LAMBDA,MIU)=0.0D0
C
         END DO
      END DO
C
C=======================================================================
C        HERE THE REAL PARTS OF MOMENTS ARE CALCULATED AND STORED
C        IN THE "QMOMUL"  ARRAY FOR NON-NEGATIVE VALUES OF "MIU".
C=======================================================================
C
      IMAREA=1
C
      DO LAMBDA=0,NMOSIF
         DO MIU=0,LAMBDA
C
            IF (MOD(LAMBDA,2).EQ.0.OR.ISIGNY.NE.1) THEN
C
                CALL INTPLM(IPHAPP(0,0,0),ELEMUL,COFMUL,
     *                                LAMBDA,MIU,IMAREA)
C
                RESULT=CMPLX(0.0D0,0.0D0)
C
                DO IBRA=1,LDBASE
                   DO IKET=1,LDBASE
C
                      RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                    * (BIG_PP(IKET,IBRA,0) + BIG_PP(IKET,IBRA,1))
C
                   END DO
                END DO
C
                QMOMUL(LAMBDA,MIU)=REAL(RESULT)
C
            ELSE
C
                QMOMUL(LAMBDA,MIU)=0.0D0
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        HERE THE IMAGINARY PARTS OF MOMENTS ARE CALCULATED AND STORED
C        IN THE "QMOMUL"  ARRAY FOR NEGATIVE VALUES OF "MIU".
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.NMOSIF.GE.1) THEN
C
          IMAREA=-1
C
          DO LAMBDA=1,NMOSIF
             DO MIU=-LAMBDA,-1
C
                IF ((MOD(LAMBDA,2).EQ.1.OR.ISIGNY.NE.1).AND.
     *              (MOD(LAMBDA,2).EQ.0.OR.ISIQTY.NE.1)) THEN
C
                    CALL INTPLM(IPHAPM(0,0,0),ELEMUL,COFMUL,
     *                                    LAMBDA,MIU,IMAREA)
C
                    RESULT=CMPLX(0.0D0,0.0D0)
C
                    DO IBRA=1,LDBASE
                       DO IKET=1,LDBASE
C
                          RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                                  * BIG_PM(IKET,IBRA,0)
C
                       END DO
                    END DO
C
                    QMOMUL(LAMBDA,MIU)=-2*REAL(RESULT)
C
                ELSE
C
                    QMOMUL(LAMBDA,MIU)=0.0D0
C
                END IF
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
      DEALLOCATE (ELEMUL)
C=======================================================================
C
      CALL CPUTIM('MOMPLM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MOMVMU(ISIMPY,QMOMUL,COFMUL,NMOSIF)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          RESULT
C=======================================================================
      DIMENSION
     *          COFMUL(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT,1:NDKART)
C=======================================================================
      ALLOCATABLE ELEMUL(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('MOMVMU',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (ELEMUL(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELEMUL','MOMVMU')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES  AND RETURNS IN "QMOMUL" THE
C       AVERAGE VALUES OF THE   V E C T O R   MULTIPOLE MOMENTS
C               R**(LAMBDA)*CONJG(Y(LAMBDA,MIU))*(X,Y,Z)
C
C       SEE THE APPROPRIATE REFERENCE TO BE QUOTED  HERE  LATER.
C=======================================================================
C       THE STRUCTURE OF THIS SUBROUTINE IS EXACTLY THE SAME  AS
C       THE STRUCTURE OF SUBROUTINE "MOMETS"; SEE COMMENTS THERE
C       FOR MORE DETAILS.
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
            DO KARTEZ=1,NDKART
C
               QMOMUL(LAMBDA,MIU,KARTEZ)=0.0D0
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        HERE THE REAL PARTS OF MOMENTS ARE CALCULATED AND STORED
C        IN THE "QMOMUL"  ARRAY FOR NON-NEGATIVE VALUES OF "MIU".
C=======================================================================
C        HERE THE "X" AND "Z" COMPONENTS (SIMPLEX-EVEN) ARE CONSIDERED
C=======================================================================
C
      IMAREA=1
C
      DO LAMBDA=0,NMOSIF
         DO MIU=0,LAMBDA
            DO KARTEZ=1,NDKART
C
               IF (KARTEZ.NE.2) THEN
C
                   CALL INTVMU(IPHAPP(0,0,0),ELEMUL,COFMUL,
     *                            LAMBDA,MIU,KARTEZ,IMAREA)
C
                   RESULT=CMPLX(0.0D0,0.0D0)
C
                   DO IBRA=1,LDBASE
                      DO IKET=1,LDBASE
C
                         RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                       * (BIG_PP(IKET,IBRA,0)+BIG_PP(IKET,IBRA,1))
C
                      END DO
                   END DO
C
                   QMOMUL(LAMBDA,MIU,KARTEZ)=REAL(RESULT)
C
               END IF
C
C=======================================================================
C        HERE THE "Y" COMPONENT (SIMPLEX-ODD) IS CONSIDERED
C=======================================================================
C        THE REAL PARTS OF THE  "Y"  COMPONENTS OF THE  VECTOR  MOMENT
C        OPERATORS ARE ANTI-INVARIANT WITH RESPECT TO THE SIMPLEX. FOR
C        THIS REASON, REAL MATRIX ELEMENTS APPEAR ALSO IN THE SIMPLEX-
C        OFF-DIAGONAL BLOCK. IN THE FOLLOWING FRAGMENT  OF  THE  CODE,
C        CONTRIBUTIONS FROM THESE ELEMENTS  ARE  TAKEN  INTO  ACCOUNT.
C        THIS PART IS EXECUTED ONLY IF THE SIMPLEX SYMMETRY IS BROKEN.
C=======================================================================
C
               IF (KARTEZ.EQ.2) THEN
C
                   IF (ISIMPY.NE.1) THEN
C
                       CALL INTVMU(IPHAPM(0,0,0),ELEMUL,COFMUL,
     *                                LAMBDA,MIU,KARTEZ,IMAREA)
C
                       RESULT=CMPLX(0.0D0,0.0D0)
C
                       DO IBRA=1,LDBASE
                          DO IKET=1,LDBASE
C
                             RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                                     * BIG_PM(IKET,IBRA,0)
C
                          END DO
                       END DO
C
                       QMOMUL(LAMBDA,MIU,KARTEZ)=-2*REAL(RESULT)
C
                   ELSE
C
                       QMOMUL(LAMBDA,MIU,KARTEZ)=0.0D0
C
                   END IF
C
               END IF
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        HERE THE IMAGINARY PARTS OF MOMENTS ARE CALCULATED AND STORED
C        IN THE "QMOMUL"  ARRAY FOR NEGATIVE VALUES OF "MIU".
C=======================================================================
C        HERE THE "X" AND "Z" COMPONENTS (SIMPLEX-ODD) ARE CONSIDERED
C=======================================================================
C
      IMAREA=-1
C
      DO LAMBDA=1,NMOSIF
         DO MIU=-LAMBDA,-1
            DO KARTEZ=1,NDKART
C
               IF (KARTEZ.NE.2) THEN
C
                   IF (ISIMPY.NE.1) THEN
C
                       CALL INTVMU(IPHAPM(0,0,0),ELEMUL,COFMUL,
     *                                LAMBDA,MIU,KARTEZ,IMAREA)
C
                       RESULT=CMPLX(0.0D0,0.0D0)
C
                       DO IBRA=1,LDBASE
                          DO IKET=1,LDBASE
C
                             RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                                     * BIG_PM(IKET,IBRA,0)
C
                          END DO
                       END DO
C
                       QMOMUL(LAMBDA,MIU,KARTEZ)=-2*REAL(RESULT)
C
                   ELSE
C
                       QMOMUL(LAMBDA,MIU,KARTEZ)=0.0D0
C
                   END IF
C
               END IF
C
C=======================================================================
C        HERE THE "Y" COMPONENT (SIMPLEX-EVEN) IS CONSIDERED
C=======================================================================
C        SEE COMMENT FOR REAL PART ABOVE, CHANGING REAL INTO IMAGINARY,
C        INVARIANT INTO ANTI-INVARIANT, AND OFF-DIAGONAL INTO DIAGONAL.
C=======================================================================
C
               IF (KARTEZ.EQ.2) THEN
C
                   CALL INTVMU(IPHAPP(0,0,0),ELEMUL,COFMUL,
     *                            LAMBDA,MIU,KARTEZ,IMAREA)
C
                   RESULT=CMPLX(0.0D0,0.0D0)
C
                   DO IBRA=1,LDBASE
                      DO IKET=1,LDBASE
C
                         RESULT=RESULT + ELEMUL(IBRA,IKET)
     *
     *                       * (BIG_PP(IKET,IBRA,0)
     *                       +  BIG_PP(IKET,IBRA,1))
C
                      END DO
                   END DO
C
                   QMOMUL(LAMBDA,MIU,KARTEZ)=+REAL(RESULT)
C
               END IF
C
            END DO
         END DO
      END DO
C
C=======================================================================
      DEALLOCATE (ELEMUL)
C=======================================================================
C
      CALL CPUTIM('MOMVMU',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MAGMOM(ISIMPY,IROTAT,ICHARG,AMOMUL,AMOMUT,NMOMAG,
     *                                                           NMAORD)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      COMPLEX
     *          ELESPI,RESULT,SMOMUL,AMOMUT,C_ZERO,UNIT_I
C=======================================================================
      ALLOCATABLE ELESPI(:,:)
      ALLOCATABLE ELEORB(:,:)
C=======================================================================
      DIMENSION
     *          AMOMUL(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      DIMENSION
     *          AMOMUT(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      DIMENSION
     *          SMOMUL(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
C
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /GEFACT/ GESPIN(0:NDISOS),GEORBI(0:NDISOS)
C=======================================================================
C
      CALL CPUTIM('MAGMOM',1)
C
C=======================================================================
      IF (NMOMAG.GT.NDMULT) STOP ' INCREASE NDMULT IN MAGMOM'
C
      IF (NMAORD.GT.NDMORD) STOP ' INCREASE NDMORD IN MAGMOM'
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (ELESPI(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELESPI','MAGMOM')
      ALLOCATE (ELEORB(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELEORB','MAGMOM')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES AND RETURNS IN "AMOMUL" AND "AMOMUT"
C       THE AVERAGE VALUES OF THE MAGNETIC MULTIPOLE MOMENTS
C          GRAD[R**LAMBDA*CONJG(Y(LAMBDA,MIU))]*
C          *(GESPIN*S+(2/(LAMBDA+1))*GEORBI*L)
C       THIS FORMULA DIFFERS FROM EQ.(B.24) IN RING & SCHUCK
C       BY THE COMPLEX CONJUGATE OF THE SPHERICAL HARMONICS
C       THE RESULT IS EXPRESSED IN NUCLEAR MAGNETONS
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C       ZEROING THE ORBITAL MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            AMOMUL(LAMBDA,MIU,:)=0.0D0
            AMOMUT(LAMBDA,MIU,:)=C_ZERO
C
         END DO
      END DO
C
C=======================================================================
C       ZEROING THE SPIN MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            SMOMUL(LAMBDA,MIU,:)=C_ZERO
C
         END DO
      END DO
C
      IF (IROTAT.NE.1) GO TO 2
C
C=======================================================================
C       CALCULATING MOMENTS OF THE REAL PARTS
C=======================================================================
C
      IF (ISIMPY.NE.1) THEN
C
          IMAREA=1
C
          DO LAMBDA=0,NMOMAG
             DO MIU=0,LAMBDA
C
                DO NUMORD=0,NMAORD
C
                   CALL INTSPI(ELESPI,LAMBDA,MIU,IMAREA,NUMORD)
C
                   RESULT=CMPLX(0.0D0,0.0D0)
C
                   DO IBRA=1,LDBASE
                      DO IKET=1,LDBASE
C
                         RESULT=RESULT+ELESPI(IBRA,IKET)
     *                                *BIG_PM(IKET,IBRA,1)
     *                          +CONJG(ELESPI(IBRA,IKET))
     *                                *BIG_PM(IKET,IBRA,0)
C
                      END DO
                   END DO
C
c     write (*,*) 'SMOMUL',-100,LAMBDA,MIU,NUMORD,RESULT
                   SMOMUL(LAMBDA,MIU,NUMORD)=RESULT*GESPIN(ICHARG)
C
                END DO
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C       CALCULATING MOMENTS OF THE IMAGINARY PARTS
C=======================================================================
C
      IF (NMOMAG.GE.1) THEN
C
          IMAREA=-1
C
          DO LAMBDA=1,NMOMAG
             DO MIU=-LAMBDA,-1
C
                DO NUMORD=0,NMAORD
C
                   CALL INTSPI(ELESPI,LAMBDA,MIU,IMAREA,NUMORD)
C
                   RESULT=CMPLX(0.0D0,0.0D0)
C
                   DO IBRA=1,LDBASE
                      DO IKET=1,LDBASE
C
                         RESULT=RESULT+ELESPI(IBRA,IKET)
     *                                *BIG_PP(IKET,IBRA,0)
     *                          +CONJG(ELESPI(IBRA,IKET))
     *                                *BIG_PP(IKET,IBRA,1)
C
                      END DO
                   END DO
C
c     write (*,*) 'SMOMUL',-101,LAMBDA,MIU,NUMORD,-UNIT_I*RESULT
                   SMOMUL(LAMBDA,MIU,NUMORD)=-UNIT_I*
     *                                       RESULT*GESPIN(ICHARG)
C
                END DO
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C       CALCULATING MOMENTS OF THE REAL PARTS OF THE ORBITAL ANGULAR
C       MOMENTUM
C=======================================================================
C
      IF (ISIMPY.NE.1.AND.ICHARG.EQ.1) THEN
C
          IMAREA=1
C
          DO LAMBDA=0,NMOMAG
             DO MIU=0,LAMBDA
C
                DO NUMORD=0,NMAORD
C
                   CALL INTORB(ELEORB,LAMBDA,MIU,IMAREA,NUMORD)
C
                   RESULT=CMPLX(0.0D0,0.0D0)
C
                   DO IBRA=1,LDBASE
                      DO IKET=1,LDBASE
C
                         RESULT=RESULT+ELEORB(IBRA,IKET)
     *                               *(BIG_PM(IKET,IBRA,1)
     *                                -BIG_PM(IKET,IBRA,0))
C
                      END DO
                   END DO
C
                   AMOMUL(LAMBDA,MIU,NUMORD)=-AIMAG(RESULT)*
     *                                       GEORBI(ICHARG)
                   AMOMUT(LAMBDA,MIU,NUMORD)=UNIT_I*RESULT *
     *                                       GEORBI(ICHARG)
C
                END DO
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C       CALCULATING MOMENTS OF THE IMAGINARY PARTS OF THE ORBITAL
C       ANGULAR MOMENTUM
C=======================================================================
C
      IF (NMOMAG.GE.1.AND.ICHARG.EQ.1) THEN
C
          IMAREA=-1
C
          DO LAMBDA=1,NMOMAG
             DO MIU=-LAMBDA,-1
C
                DO NUMORD=0,NMAORD
C
                   CALL INTORB(ELEORB,LAMBDA,MIU,IMAREA,NUMORD)
C
                   RESULT=CMPLX(0.0D0,0.0D0)
C
                   DO IBRA=1,LDBASE
                      DO IKET=1,LDBASE
C
                         RESULT=RESULT+ELEORB(IBRA,IKET)
     *                               *(BIG_PP(IKET,IBRA,0)
     *                                +BIG_PP(IKET,IBRA,1))
C
                      END DO
                   END DO
C
                   AMOMUL(LAMBDA,MIU,NUMORD)=  AIMAG(RESULT)*
     *                                       GEORBI(ICHARG)
                   AMOMUT(LAMBDA,MIU,NUMORD)=-UNIT_I*RESULT *
     *                                       GEORBI(ICHARG)
C
                END DO
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C        ADDING ORBITAL AND SPIN PARTS OF MAGNETIC MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NMOMAG
         DO MIU=-LAMBDA,LAMBDA
C
            DO NUMORD=0,NMAORD
C
               AMOMUL(LAMBDA,MIU,NUMORD)=AMOMUL(LAMBDA,MIU,NUMORD)+
     *                              REAL(SMOMUL(LAMBDA,MIU,NUMORD))
               AMOMUT(LAMBDA,MIU,NUMORD)=AMOMUT(LAMBDA,MIU,NUMORD)+
     *                                   SMOMUL(LAMBDA,MIU,NUMORD)
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
      DEALLOCATE (ELESPI,ELEORB)
C=======================================================================
C
      CALL CPUTIM('MAGMOM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ASMMOM(ISIMPY,IROTAT,WMOMUL,WMOMUT,NMOASM,NASORD)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      COMPLEX
     *          ELEASM,RESULT,WMOMUT,SMOMUL,SPHMUL,C_ZERO,UNIT_I
C=======================================================================
      ALLOCATABLE ELEASM(:,:,:)
C=======================================================================
      DIMENSION
     *          WMOMUL(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      DIMENSION
     *          WMOMUT(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      DIMENSION
     *          SMOMUL(0:NDMULT,-NDMULT:NDMULT,0:NDKART,0:NDMORD)
      DIMENSION
     *          SPHMUL(-1:1)
      DIMENSION
     *          RESULT(0:NDKART)
      DIMENSION
     *          ITIREV(0:NDKART)
C
C=======================================================================
      COMMON
     *       /ASMUNI/ BUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /DIMENS/ LDBASE
C=======================================================================
C
      CALL CPUTIM('ASMMOM',1)
C
C=======================================================================
      IF (NMOASM+1.GT.NDMULT) STOP 'INCREASE NDMULT IN ASMMOM'
C
      IF (NASORD.GT.NDMORD) STOP ' INCREASE NDMORD IN ASMMOM'
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (ELEASM(1:NDBASE,1:NDBASE,0:NDKART),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ELEASM','ASMMOM')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES AND RETURNS IN "WMOMUL" AND "WMOMUT"
C       THE AVERAGE VALUES OF THE SPIN-ASYMMETRY MOMENTS
C       R**(NUMORD+LAMBDA+1)*
C                         [CONJG(Y(LAMBDA+1,.)*S(.)]_(LAMBDA,MIU)
C       WHERE THE SQUARE BRACKETS DENOTE THE ANGULAR MOMENTUM  COUPLING,
C       SEE NOTES 9-107.
C
C       THE RESULT IS EXPRESSED IN HBAR*FM**(NUMORD+LAMBDA+1)
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      DSQRT2=SQRT(2.0D0)
C
C=======================================================================
C       ZEROING THE SPIN-ASYMMETRY MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            WMOMUL(LAMBDA,MIU,:)  =0.0D0
            WMOMUT(LAMBDA,MIU,:)  =C_ZERO
            SMOMUL(LAMBDA,MIU,:,:)=C_ZERO
C
         END DO
      END DO
C
C=======================================================================
C
      IF (IROTAT.NE.1) GO TO 2893
      IF (NMOASM.LT.1) GO TO 2893
      IF (NASORD.LT.0) GO TO 2893
C
C=======================================================================
C       CALCULATING THE DIAGONAL SIMPLEX TERMS, THAT IS, THOSE OF:
C       0. REAL      PARTS OF THE MULTIPOLE MOMENTS MULTIPLIED BY SPIN_0
C       1. IMAGINARY PARTS OF THE MULTIPOLE MOMENTS MULTIPLIED BY SPIN_X
C       2. REAL      PARTS OF THE MULTIPOLE MOMENTS MULTIPLIED BY SPIN_Y
C       3. IMAGINARY PARTS OF THE MULTIPOLE MOMENTS MULTIPLIED BY SPIN_Z
C=======================================================================
C
      ISIDIA=1
C
C=======================================================================
C       SINCE THE SPIN OPERATORS ARE TIME EVEN (ODD) FOR KARTEZ=0  (1-3)
C       AND THE REAL (IMAGINARY) PARTS OF THE MULTIPOLE MOMENTS ARE TIME
C       EVEN (ODD), IN THE DIAGONAL TERMS,  THE  COMBINED  TIME-REVERSAL
C       PROPERTIES OF DIFFERENT KARTEZ TERMS ARE AS FOLLOWS:
C=======================================================================
C
      ITIREV(0)=+1
      ITIREV(1)=+1
      ITIREV(2)=-1
      ITIREV(3)=+1
C321G
C321G ITIREV(0)=+1
C321G ITIREV(1)=-1
C321G ITIREV(2)=-1
C321G ITIREV(3)=-1
C
C=======================================================================
C
C321G DO LAMBDB=0,0
      DO LAMBDB=2,NMOASM+1
         DO MIB=-LAMBDB,LAMBDB
C
            DO NUMORD=0,NASORD
C
               CALL INTASM(ELEASM,LAMBDB,MIB,ISIDIA,NUMORD)
C
               RESULT(:)=CMPLX(0.0D0,0.0D0)
C
               DO IBRA=1,LDBASE
                  DO IKET=1,LDBASE
                     DO KARTEZ=0,NDKART
C
                        RESULT(KARTEZ)=RESULT(KARTEZ)
     *                                +ELEASM(IBRA,IKET,KARTEZ)
     *                                *BIG_PP(IKET,IBRA,0)
     *           +ITIREV(KARTEZ)*CONJG(ELEASM(IBRA,IKET,KARTEZ))
     *                                *BIG_PP(IKET,IBRA,1)
C
                     END DO
                  END DO
               END DO
C
C321G      write (*,*) 'SMOMUL',ISIDIA,LAMBDB,MIB,NUMORD,RESULT
               SMOMUL(LAMBDB,MIB,:,NUMORD)=RESULT(:)
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      IF (ISIMPY.EQ.1) GO TO 2894
C
C=======================================================================
C       CALCULATING THE OFF-DIAGONAL SIMPLEX TERMS, THAT IS, THOSE OF:
C       0. IMAGINARY PARTS OF THE MULTIPOLE MOMENTS MULTIPLIED BY SPIN_0
C       1. REAL      PARTS OF THE MULTIPOLE MOMENTS MULTIPLIED BY SPIN_X
C       2. IMAGINARY PARTS OF THE MULTIPOLE MOMENTS MULTIPLIED BY SPIN_Y
C       3. REAL      PARTS OF THE MULTIPOLE MOMENTS MULTIPLIED BY SPIN_Z
C=======================================================================
C
      ISIDIA=0
C
C=======================================================================
C       SINCE THE SPIN OPERATORS ARE TIME EVEN (ODD) FOR KARTEZ=0  (1-3)
C       AND THE REAL (IMAGINARY) PARTS OF THE MULTIPOLE MOMENTS ARE TIME
C       EVEN (ODD), IN THE OFFDIAGONAL TERMS, THE COMBINED TIME-REVERSAL
C       PROPERTIES OF DIFFERENT KARTEZ TERMS ARE AS FOLLOWS:
C=======================================================================
C
      ITIREV(0)=-1
      ITIREV(1)=-1
      ITIREV(2)=+1
      ITIREV(3)=-1
C321G
C321G ITIREV(0)=+1
C321G ITIREV(1)=-1
C321G ITIREV(2)=-1
C321G ITIREV(3)=-1
C
C=======================================================================
C
C321G DO LAMBDB=0,0
      DO LAMBDB=2,NMOASM+1
         DO MIB=-LAMBDB,LAMBDB
C
            DO NUMORD=0,NASORD
C
               CALL INTASM(ELEASM,LAMBDB,MIB,ISIDIA,NUMORD)
C
               RESULT(:)=CMPLX(0.0D0,0.0D0)
C
               DO IBRA=1,LDBASE
                  DO IKET=1,LDBASE
                     DO KARTEZ=0,NDKART
C
                        RESULT(KARTEZ)=RESULT(KARTEZ)
     *                                +ELEASM(IBRA,IKET,KARTEZ)
     *                                *BIG_PM(IKET,IBRA,1)
     *           -ITIREV(KARTEZ)*CONJG(ELEASM(IBRA,IKET,KARTEZ))
     *                                *BIG_PM(IKET,IBRA,0)
C
                     END DO
                  END DO
               END DO
C
C321G      write (*,*) 'SMOMUL',ISIDIA,LAMBDB,MIB,NUMORD,RESULT
               SMOMUL(LAMBDB,MIB,:,NUMORD)=
     *         SMOMUL(LAMBDB,MIB,:,NUMORD)+RESULT(:)
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
 2894 CONTINUE
C
C=======================================================================
C       COUPLING THE SPACE AND SPIN PARTS TO THE FINAL MULTIPOLARITY
C=======================================================================
C
C321G DO LAMBDB=0,0
      DO LAMBDB=2,NMOASM+1
         DO MIB=-LAMBDB,+LAMBDB
C
            DO NUMORD=0,NASORD
C
C321G      write(*,*)'SMOMUL',9,LAMBDB,MIB,NUMORD,SMOMUL(LAMBDB,MIB,:,NUMORD)
C321G          SPHMUL(+1)=-(SMOMUL(LAMBDB,MIB,1,NUMORD)+
               SPHMUL(+1)=-(SMOMUL(LAMBDB,MIB,1,NUMORD)-
     *                      SMOMUL(LAMBDB,MIB,2,NUMORD)*UNIT_I)/DSQRT2
C321G          SPHMUL(-1)= (SMOMUL(LAMBDB,MIB,1,NUMORD)-
               SPHMUL(-1)= (SMOMUL(LAMBDB,MIB,1,NUMORD)+
     *                      SMOMUL(LAMBDB,MIB,2,NUMORD)*UNIT_I)/DSQRT2
               SPHMUL( 0)=  SMOMUL(LAMBDB,MIB,3,NUMORD)
C321G      write (*,*) 'SPHMUL',100,LAMBDB,MIB,NUMORD,SPHMUL
C
C321G          LAMBDA=LAMBDB+1
               LAMBDA=LAMBDB-1
C
               DO MIU=-LAMBDA,+LAMBDA
C
                  KIU=MIU-MIB
C
                  IF (IABS(KIU).LE.1)
     *
     *                WMOMUT(LAMBDA,MIU,NUMORD)=
     *                WMOMUT(LAMBDA,MIU,NUMORD)+SPHMUL(KIU)*
     *                CGCOEF(2*LAMBDB,2*MIB,2,2*KIU,2*LAMBDA,2*MIU)
C
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C        FOLLOWS MULTIPLICATION BY THE UNITS DEFINED ONCE FOR ALL IN THE
C        SUBROUTINE "DEFUNI". THE UNITS "BUNITS" DEFINED FOR  MIU=0  ARE
C        USED FOR ALL VALUES OF "MIU". THIS STANDARD IS  DIFFERENT  FROM
C        THAT USED FOR THE MULTIPOLE MOMENTS, BECAUSE THE  RESULTS  WILL
C        BE USED IN THE PROPER ANGULAR-MOMENTUM COUPLING.
C=======================================================================
C
      DO LAMBDA=1,NMOASM
         DO MIU=-LAMBDA,+LAMBDA
C
            WMOMUT(LAMBDA,MIU,:)=WMOMUT(LAMBDA,MIU,:)*BUNITS(LAMBDA,0)
C321G      write (*,*) 'WMOMUT',LAMBDA,MIU,WMOMUT(LAMBDA,MIU,0)
C
         END DO
      END DO
C
C=======================================================================
C       RECALCULATING THE REAL PARTS OF THE MIU>=0  COMPONENTS  AND  THE
C       IMAGINARY PARTS OF THE MIU<0 COMPONENTS.
C       ATTENTION! THIS MAKES SENSE ONLY FOR  DIAGONAL  MATRIX  ELEMENTS
C                  AND SHOULD BE IGNORED FOR KERNELS.
C=======================================================================
C
      DO LAMBDA=1,NMOASM
         DO MIU=-LAMBDA,+LAMBDA
C
            IF (MIU.GE.0)      WMOMUL(LAMBDA,MIU,:)=
     *                    REAL(WMOMUT(LAMBDA,MIU,:))
            IF (MIU.LT.0)      WMOMUL(LAMBDA,MIU,:)=
     *                   AIMAG(WMOMUT(LAMBDA,MIU,:))
C
C321G      write (*,*) 'WMOMUL',LAMBDA,MIU,WMOMUL(LAMBDA,MIU,0)
         END DO
      END DO
C
C=======================================================================
C
 2893 CONTINUE
C
C=======================================================================
      DEALLOCATE (ELEASM)
C=======================================================================
C
      CALL CPUTIM('ASMMOM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      BLOCK DATA SET_RADIAL_FORMFACTORS
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3,NDTORD=10)
C=======================================================================
      COMMON
     *       /MATORD/ NUTORD(0:NDMORD),
     *                MUTORD(1:NDTORD,0:NDMORD),
     *                IUTORD(1:NDTORD,0:NDMORD,1:NDKART)
C
C=======================================================================
C       SETTING UP ARRAYS DEFINING THE TERMS OF THE RADIAL FORMFACTORS:
C       ORDER 0: 1
C       ORDER 1: X^2 + Y^2 + Z^2
C       ORDER 2: X^4 + Y^4 + Z^4 + 2*X^2*Y^2 + 2*Y^2*Z^2 + 2*Z^2*X^2
C       ORDER 3: X^6 + Y^6 + Z^6 + 3*X^4*Y^2 + 3*Y^4*Z^2 + 3*Z^4*X^2
C                                + 3*X^2*Y^4 + 3*Y^2*Z^4 + 3*Z^2*X^4
C                                + 6**X^2*Y^2*Z^2
C=======================================================================
C
C       THE NUMBER OF TERMS AT A GIVEN ORDER
C
      DATA   (NUTORD(MUMORD),MUMORD=0,NDMORD) /1,3,6,10/
C
C       COEFFICIENTS OF TERMS AT A GIVEN ORDER
C
      DATA  ((MUTORD(LUTORD,MUMORD),LUTORD=1,NDTORD),
     *                              MUMORD=0,NDMORD)
     *                                             /1,0,0,0,0,0,0,0,0,0,
     *                                              1,1,1,0,0,0,0,0,0,0,
     *                                              1,1,1,2,2,2,0,0,0,0,
     *                                              1,1,1,3,3,3,3,3,3,6/
C
C       POWERS OF TERMS AT A GIVEN ORDER FOR A GIVEN VARIABLE
C
      DATA (((IUTORD(LUTORD,MUMORD,KARTEZ),LUTORD=1,NDTORD),
     *                                     MUMORD=0,NDMORD),
     *                                     KARTEZ=1,NDKART)
C       POWERS OF X
     *                                             /0,0,0,0,0,0,0,0,0,0,
     *                                              2,0,0,0,0,0,0,0,0,0,
     *                                              4,0,0,2,0,2,0,0,0,0,
     *                                              6,0,0,4,0,2,2,0,4,2,
C       POWERS OF Y
     *                                              0,0,0,0,0,0,0,0,0,0,
     *                                              0,2,0,0,0,0,0,0,0,0,
     *                                              0,4,0,2,2,0,0,0,0,0,
     *                                              0,6,0,2,4,0,4,2,0,2,
C       POWERS OF Z
     *                                              0,0,0,0,0,0,0,0,0,0,
     *                                              0,0,2,0,0,0,0,0,0,0,
     *                                              0,0,4,0,2,2,0,0,0,0,
     *                                              0,0,6,0,2,4,0,4,2,2/
C
      END BLOCK DATA SET_RADIAL_FORMFACTORS
C
C=======================================================================
C
      SUBROUTINE INTSPI(ELESPI,LAMBDA,MIU,IMAREA,NUMORD)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3,NDTORD=10)
C=======================================================================
      COMPLEX
     *          C_ZERO,ELESPI
C
      DIMENSION
     *          ELESPI(1:NDBASE,1:NDBASE)
      COMMON
     *       /MATORD/ NUTORD(0:NDMORD),
     *                MUTORD(1:NDTORD,0:NDMORD),
     *                IUTORD(1:NDTORD,0:NDMORD,1:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /POWNMU/ NMUPOW
C
C=======================================================================
C
      CALL CPUTIM('INTSPI',1)
C
C=======================================================================
C      THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF  THE SPIN  PART  OF
C      THE MAGNETIC MOMENT OPERATOR MULTIPLIED BY A RADIAL FORMFACTOR OF
C      THE ORDER 2*NUMORD
C
C      SEE PHYSICAL REVIEW C 62 (2000) 014310,  EQ. (46B)
C
C      IMAREA = 1 (-1) REQUESTS CALCULATION OF THE REAL (IMAGINARY) PART
C=======================================================================
C
      IF (NUMORD.GT.NDMORD) STOP ' INCREASE NDMORD IN INTSPI'
C
      IF (NDMORD.NE.3) STOP ' UPDATE DATA FOR .UTORD IN INTSPI'
C
      IF (LAMBDA+2*NUMORD.GT.NMUPOW) STOP ' INCREASE NMUPOW IN INTSPI'
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      ELESPI(:,:)=C_ZERO
C
      NIU=IABS(MIU)
C
      IF (MIU.GE.0) THEN
          JPHASE=IMAREA
      ELSE
          JPHASE=(-1)**MIU
      END IF
C
C=======================================================================
C       MATRIX ELEMENTS OF THE REAL SPIN PART
C=======================================================================
C
      IF (IMAREA.EQ.1) THEN
C
          DO NUTERM=1,NREYLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   DO LUTORD=1,NUTORD(NUMORD)
C
C                     SPIN_X * GRAD_X TERM
C
                      IF(KREYLM(LAMBDA,NIU,NUTERM,1).GT.0)
     *
     *                ELESPI(IBRA,IKET) = ELESPI(IBRA,IKET)
     *              + KREYLM(LAMBDA,NIU,NUTERM,0)
     *              * KREYLM(LAMBDA,NIU,NUTERM,1)
     *              * MUTORD(LUTORD,NUMORD)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                              IUTORD(LUTORD,NUMORD,1)-1,
     *                                     NX_BRA,NX_KET,1)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                              IUTORD(LUTORD,NUMORD,2),
     *                                     NY_BRA,NY_KET,2)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                              IUTORD(LUTORD,NUMORD,3),
     *                                     NZ_BRA,NZ_KET,3)
     *              * IPHAPM(NY_BRA,NY_KET,1)
     *              * CMPLX(1.0D0,0.0D0)
C
C                     SPIN_Y * GRAD_Y TERM
C
                      IF(KREYLM(LAMBDA,NIU,NUTERM,2).GT.0)
     *
     *                ELESPI(IBRA,IKET) = ELESPI(IBRA,IKET)
     *              + KREYLM(LAMBDA,NIU,NUTERM,0)
     *              * KREYLM(LAMBDA,NIU,NUTERM,2)
     *              * MUTORD(LUTORD,NUMORD)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                              IUTORD(LUTORD,NUMORD,1),
     *                                     NX_BRA,NX_KET,1)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                              IUTORD(LUTORD,NUMORD,2)-1,
     *                                     NY_BRA,NY_KET,2)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                              IUTORD(LUTORD,NUMORD,3),
     *                                     NZ_BRA,NZ_KET,3)
     *              * IPHAPM(NY_BRA,NY_KET,2)
     *              * CMPLX(1.0D0,0.0D0)
C
C                     SPIN_Z * GRAD_Z TERM
C
                      IF(KREYLM(LAMBDA,NIU,NUTERM,3).GT.0)
     *
     *                ELESPI(IBRA,IKET) = ELESPI(IBRA,IKET)
     *              + KREYLM(LAMBDA,NIU,NUTERM,0)
     *              * KREYLM(LAMBDA,NIU,NUTERM,3)
     *              * MUTORD(LUTORD,NUMORD)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                              IUTORD(LUTORD,NUMORD,1),
     *                                     NX_BRA,NX_KET,1)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                              IUTORD(LUTORD,NUMORD,2),
     *                                     NY_BRA,NY_KET,2)
     *              * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                              IUTORD(LUTORD,NUMORD,3)-1,
     *                                     NZ_BRA,NZ_KET,3)
     *              * IPHAPM(NY_BRA,NY_KET,3)
     *              * CMPLX(0.0D0,1.0D0)
C
                   END DO
C
                END DO
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C       MATRIX ELEMENTS OF THE IMAGINARY SPIN PART
C=======================================================================
C
      IF (IMAREA.EQ.-1) THEN
C
          DO NUTERM=1,NIMYLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   DO LUTORD=1,NUTORD(NUMORD)
C
C                     SPIN_X * GRAD_X TERM
C
                      IF(KIMYLM(LAMBDA,NIU,NUTERM,1).GT.0)
     *
     *                ELESPI(IBRA,IKET) = ELESPI(IBRA,IKET)
     *              + KIMYLM(LAMBDA,NIU,NUTERM,0)
     *              * KIMYLM(LAMBDA,NIU,NUTERM,1)
     *              * MUTORD(LUTORD,NUMORD)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                              IUTORD(LUTORD,NUMORD,1)-1,
     *                                     NX_BRA,NX_KET,1)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                              IUTORD(LUTORD,NUMORD,2),
     *                                     NY_BRA,NY_KET,2)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                              IUTORD(LUTORD,NUMORD,3),
     *                                     NZ_BRA,NZ_KET,3)
     *              * IPHAPP(NY_BRA,NY_KET,1)
     *              * CMPLX(0.0D0,1.0D0)
C
C                     SPIN_Y * GRAD_Y TERM
C
                      IF(KIMYLM(LAMBDA,NIU,NUTERM,2).GT.0)
     *
     *                ELESPI(IBRA,IKET) = ELESPI(IBRA,IKET)
     *              + KIMYLM(LAMBDA,NIU,NUTERM,0)
     *              * KIMYLM(LAMBDA,NIU,NUTERM,2)
     *              * MUTORD(LUTORD,NUMORD)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                              IUTORD(LUTORD,NUMORD,1),
     *                                     NX_BRA,NX_KET,1)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                              IUTORD(LUTORD,NUMORD,2)-1,
     *                                     NY_BRA,NY_KET,2)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                              IUTORD(LUTORD,NUMORD,3),
     *                                     NZ_BRA,NZ_KET,3)
     *              * IPHAPP(NY_BRA,NY_KET,2)
     *              * CMPLX(0.0D0,1.0D0)
C
C                     SPIN_Z * GRAD_Z TERM
C
                      IF(KIMYLM(LAMBDA,NIU,NUTERM,3).GT.0)
     *
     *                ELESPI(IBRA,IKET) = ELESPI(IBRA,IKET)
     *              + KIMYLM(LAMBDA,NIU,NUTERM,0)
     *              * KIMYLM(LAMBDA,NIU,NUTERM,3)
     *              * MUTORD(LUTORD,NUMORD)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                              IUTORD(LUTORD,NUMORD,1),
     *                                     NX_BRA,NX_KET,1)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                              IUTORD(LUTORD,NUMORD,2),
     *                                     NY_BRA,NY_KET,2)
     *              * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                              IUTORD(LUTORD,NUMORD,3)-1,
     *                                     NZ_BRA,NZ_KET,3)
     *              * IPHAPP(NY_BRA,NY_KET,3)
     *              * CMPLX(-1.0D0,0.0D0)
C
                   END DO
C
                END DO
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C       NORMALIZATION FACTOR AND PHASE
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            ELESPI(IBRA,IKET)=ELESPI(IBRA,IKET)
     *                       *COEYLM(LAMBDA,NIU)*JPHASE*0.5D0
C
         END DO
      END DO
C
C=======================================================================
C        FOLLOWS MULTIPLICATION BY THE UNITS DEFINED ONCE FOR ALL IN THE
C        SUBROUTINE "DEFUNI".  THE  SAME  UNITS ARE IMPLIED FOR POSITIVE
C        AND NEGATIVE VALUES OF "MIU".
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            ELESPI(IBRA,IKET)=ELESPI(IBRA,IKET)*AUNITS(LAMBDA,NIU)
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTSPI',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTORB(ELEORB,LAMBDA,MIU,IMAREA,NUMORD)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3,NDTORD=10)
C=======================================================================
C
      DIMENSION
     *          ELEORB(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /MATORD/ NUTORD(0:NDMORD),
     *                MUTORD(1:NDTORD,0:NDMORD),
     *                IUTORD(1:NDTORD,0:NDMORD,1:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEMAG/ COGRAD(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /POWNMU/ NMUPOW
C
C=======================================================================
C
      CALL CPUTIM('INTORB',1)
C
C=======================================================================
C      THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF THE ORBITAL PART OF
C      THE MAGNETIC MOMENT OPERATOR MULTIPLIED BY A RADIAL FORMFACTOR OF
C      THE ORDER 2*NUMORD
C
C      SEE PHYSICAL REVIEW C 62 (2000) 014310,  EQ. (46B)
C
C      IMAREA = 1 (-1) REQUESTS CALCULATION OF THE REAL (IMAGINARY) PART
C=======================================================================
C
      IF (NUMORD.GT.NDMORD) STOP ' INCREASE NDMORD IN INTORB'
C
      IF (NDMORD.NE.3) STOP ' UPDATE DATA FOR .UTORD IN INTORB'
C
      IF (LAMBDA+2*NUMORD+1.GT.NMUPOW) STOP ' INCREASE NMUPOW IN INTORB'
C
C=======================================================================
C
      ELEORB(:,:)=0.0D0
C
      NIU=IABS(MIU)
C
      IF (MIU.GE.0) THEN
          JPHASE=IMAREA
      ELSE
          JPHASE=(-1)**MIU
      END IF
C
C=======================================================================
C       MATRIX ELEMENTS OF THE REAL ORBITAL PART
C=======================================================================
C
      IF (IMAREA.EQ.1) THEN
C
          DO NUTERM=1,NREYLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   DO LUTORD=1,NUTORD(NUMORD)
C
                      IF (KREYLM(LAMBDA,NIU,NUTERM,1).GT.0) THEN
C
C                        (Y * GRAD Z) * GRAD_X TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  + KREYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KREYLM(LAMBDA,NIU,NUTERM,1)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1)-1,
     *                                         NX_BRA,NX_KET,1)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2)+1,
     *                                         NY_BRA,NY_KET,2)
     *                  * COGRAD(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3),
     *                                         NZ_BRA,NZ_KET,3)
C
C                        (Z * GRAD Y) * GRAD_X TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  - KREYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KREYLM(LAMBDA,NIU,NUTERM,1)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1)-1,
     *                                         NX_BRA,NX_KET,1)
     *                  * COGRAD(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2),
     *                                         NY_BRA,NY_KET,2)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3)+1,
     *                                         NZ_BRA,NZ_KET,3)
C
                      END IF
C
                      IF (KREYLM(LAMBDA,NIU,NUTERM,2).GT.0) THEN
C
C                        (Z * GRAD X) * GRAD_Y TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  + KREYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KREYLM(LAMBDA,NIU,NUTERM,2)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COGRAD(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1),
     *                                         NX_BRA,NX_KET,1)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2)-1,
     *                                         NY_BRA,NY_KET,2)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3)+1,
     *                                         NZ_BRA,NZ_KET,3)
C
C                        (X * GRAD Z) * GRAD_Y TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  - KREYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KREYLM(LAMBDA,NIU,NUTERM,2)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1)+1,
     *                                         NX_BRA,NX_KET,1)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2)-1,
     *                                         NY_BRA,NY_KET,2)
     *                  * COGRAD(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3),
     *                                         NZ_BRA,NZ_KET,3)
C
                      END IF
C
                      IF (KREYLM(LAMBDA,NIU,NUTERM,3).GT.0) THEN
C
C                        (X * GRAD Y) * GRAD_Z TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  + KREYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KREYLM(LAMBDA,NIU,NUTERM,3)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1)+1,
     *                                         NX_BRA,NX_KET,1)
     *                  * COGRAD(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2),
     *                                         NY_BRA,NY_KET,2)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3)-1,
     *                                         NZ_BRA,NZ_KET,3)
C
C                        (Y * GRAD X) * GRAD_Z TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  - KREYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KREYLM(LAMBDA,NIU,NUTERM,3)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COGRAD(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1),
     *                                         NX_BRA,NX_KET,1)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2)+1,
     *                                         NY_BRA,NY_KET,2)
     *                  * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3)-1,
     *                                         NZ_BRA,NZ_KET,3)
C
                      END IF
C
                   END DO
C
                END DO
             END DO
C
          END DO
C
C=======================================================================
C       NORMALIZATION AND PHASE FOR THE REAL ORBITAL PART
C=======================================================================
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                ELEORB(IBRA,IKET)=ELEORB(IBRA,IKET)*(-1.0D0)
     *                          *COEYLM(LAMBDA,NIU)*JPHASE
     *                          *IPHAPM(NYVECT(IBRA,1),NYVECT(IKET,1),0)
     *                          *2.0D0/(LAMBDA+1)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C       MATRIX ELEMENTS OF THE IMAGINARY ORBITAL PART
C=======================================================================
C
      IF (IMAREA.EQ.-1) THEN
C
          DO NUTERM=1,NIMYLM(LAMBDA,NIU)
C
             DO IKET=1,LDBASE
C
                NX_KET=NXVECT(IKET,1)
                NY_KET=NYVECT(IKET,1)
                NZ_KET=NZVECT(IKET,1)
C
                DO IBRA=1,LDBASE
C
                   NX_BRA=NXVECT(IBRA,1)
                   NY_BRA=NYVECT(IBRA,1)
                   NZ_BRA=NZVECT(IBRA,1)
C
                   DO LUTORD=1,NUTORD(NUMORD)
C
                      IF (KIMYLM(LAMBDA,NIU,NUTERM,1).GT.0) THEN
C
C                        (Y * GRAD Z) * GRAD_X TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  + KIMYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KIMYLM(LAMBDA,NIU,NUTERM,1)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1)-1,
     *                                         NX_BRA,NX_KET,1)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2)+1,
     *                                         NY_BRA,NY_KET,2)
     *                  * COGRAD(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3),
     *                                         NZ_BRA,NZ_KET,3)
C
C                        (Z * GRAD Y) * GRAD_X TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  - KIMYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KIMYLM(LAMBDA,NIU,NUTERM,1)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1)-1,
     *                                         NX_BRA,NX_KET,1)
     *                  * COGRAD(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2),
     *                                         NY_BRA,NY_KET,2)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3)+1,
     *                                         NZ_BRA,NZ_KET,3)
C
                      END IF
C
                      IF (KIMYLM(LAMBDA,NIU,NUTERM,2).GT.0) THEN
C
C                        (Z * GRAD X) * GRAD_Y TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  + KIMYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KIMYLM(LAMBDA,NIU,NUTERM,2)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COGRAD(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1),
     *                                         NX_BRA,NX_KET,1)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2)-1,
     *                                         NY_BRA,NY_KET,2)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3)+1,
     *                                         NZ_BRA,NZ_KET,3)
C
C                        (X * GRAD Z) * GRAD_Y TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  - KIMYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KIMYLM(LAMBDA,NIU,NUTERM,2)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1)+1,
     *                                         NX_BRA,NX_KET,1)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2)-1,
     *                                         NY_BRA,NY_KET,2)
     *                  * COGRAD(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3),
     *                                         NZ_BRA,NZ_KET,3)
C
                      END IF
C
                      IF (KIMYLM(LAMBDA,NIU,NUTERM,3).GT.0) THEN
C
C                        (X * GRAD Y) * GRAD_Z TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  + KIMYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KIMYLM(LAMBDA,NIU,NUTERM,3)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1)+1,
     *                                         NX_BRA,NX_KET,1)
     *                  * COGRAD(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2),
     *                                         NY_BRA,NY_KET,2)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3)-1,
     *                                         NZ_BRA,NZ_KET,3)
C
C                        (Y * GRAD X) * GRAD_Z TERM
C
                          ELEORB(IBRA,IKET) = ELEORB(IBRA,IKET)
     *                  - KIMYLM(LAMBDA,NIU,NUTERM,0)
     *                  * KIMYLM(LAMBDA,NIU,NUTERM,3)
     *                  * MUTORD(LUTORD,NUMORD)
     *                  * COGRAD(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                                  IUTORD(LUTORD,NUMORD,1),
     *                                         NX_BRA,NX_KET,1)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                                  IUTORD(LUTORD,NUMORD,2)+1,
     *                                         NY_BRA,NY_KET,2)
     *                  * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                                  IUTORD(LUTORD,NUMORD,3)-1,
     *                                         NZ_BRA,NZ_KET,3)
C
                      END IF
C
                   END DO
C
                END DO
             END DO
C
          END DO
C
C=======================================================================
C       NORMALIZATION AND PHASE FOR THE IMAGINARY ORBITAL PART
C=======================================================================
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                ELEORB(IBRA,IKET)=ELEORB(IBRA,IKET)
     *                          *COEYLM(LAMBDA,NIU)*JPHASE
     *                          *IPHAPP(NYVECT(IBRA,1),NYVECT(IKET,1),0)
     *                          *2.0D0/(LAMBDA+1)
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C        FOLLOWS MULTIPLICATION BY THE UNITS DEFINED ONCE FOR ALL IN THE
C        SUBROUTINE "DEFUNI".  THE  SAME  UNITS ARE IMPLIED FOR POSITIVE
C        AND NEGATIVE VALUES OF "MIU".
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            ELEORB(IBRA,IKET)=ELEORB(IBRA,IKET)*AUNITS(LAMBDA,NIU)
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTORB',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTASM(ELEASM,LAMBDA,MIU,ISIDIA,NUMORD)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3,NDTORD=10)
C=======================================================================
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          ELEASM,TERASM
      COMPLEX
     *          PHACOM
C
      DIMENSION
     *          ELEASM(1:NDBASE,1:NDBASE,0:NDKART)
      COMMON
     *       /MATORD/ NUTORD(0:NDMORD),
     *                MUTORD(1:NDTORD,0:NDMORD),
     *                IUTORD(1:NDTORD,0:NDMORD,1:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /POWNMU/ NMUPOW
C
C=======================================================================
C
      CALL CPUTIM('INTASM',1)
C
C=======================================================================
C      THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF THE  SPIN-ASYMMETRY
C      MOMENTS MULTIPLIED BY RADIAL FORMFACTORS  OF  THE  ORDER 2*NUMORD
C
C      ISIDIA = 1,0 REFER TO THE CALCULATION OF THE SIMPLEX-DIAGONAL AND
C                   SIMPLEX-OFF-DIAGONAL TERMS, RESPECTIVELY.
C      MIND THAT: >REAL      PARTS OF MULTIPOLE MOMENTS ARE SIMPLEX EVEN
C                 >IMAGINARY PARTS OF MULTIPOLE MOMENTS ARE SIMPLEX ODD
C                 >SPIN_0 OPERATOR IS SIMPLEX EVEN
C                 >SPIN_X OPERATOR IS SIMPLEX ODD
C                 >SPIN_Y OPERATOR IS SIMPLEX EVEN
C                 >SPIN_Z OPERATOR IS SIMPLEX ODD
C=======================================================================
C      ATTENTION: "LAMBDA" REFERS TO THE  MULTIPOLARITY  OF  THE  MOMENT
C                 THAT IS COUPLED WITH SPIN AND  N O T  TO THE  THAT  OF
C                 FINAL SPIN-ASYMMETRY MOMENT, WHICH IS SMALLER BY  ONE.
C=======================================================================
C
      IF (NUMORD.GT.NDMORD) STOP ' INCREASE NDMORD IN INTASM'
C
      IF (NDMORD.NE.3) STOP ' UPDATE DATA FOR .UTORD IN INTASM'
C
      IF (LAMBDA+2*NUMORD.GT.NMUPOW) STOP ' INCREASE NMUPOW IN INTASM'
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      ELEASM(:,:,:)=C_ZERO
C
      NIU=IABS(MIU)
C
C=======================================================================
C       MATRIX ELEMENTS OF THE REAL PART
C=======================================================================
C
      IF (MIU.GE.0) THEN
          JPHASE=1
      ELSE
          JPHASE=(-1)**MIU
      END IF
C
      DO NUTERM=1,NREYLM(LAMBDA,NIU)
C
         DO IKET=1,LDBASE
C
            NX_KET=NXVECT(IKET,1)
            NY_KET=NYVECT(IKET,1)
            NZ_KET=NZVECT(IKET,1)
C
            DO IBRA=1,LDBASE
C
               NX_BRA=NXVECT(IBRA,1)
               NY_BRA=NYVECT(IBRA,1)
               NZ_BRA=NZVECT(IBRA,1)
C
               DO LUTORD=1,NUTORD(NUMORD)
                  DO KARTEZ=0,NDKART
C
                     TERASM=
     *                 KREYLM(LAMBDA,NIU,NUTERM,0)
     *               * MUTORD(LUTORD,NUMORD)
     *               * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   1)+
     *                               IUTORD(LUTORD,NUMORD,1),
     *                                      NX_BRA,NX_KET,1)
     *               * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   2)+
     *                               IUTORD(LUTORD,NUMORD,2),
     *                                      NY_BRA,NY_KET,2)
     *               * COMULT(KREYLM(LAMBDA,NIU,NUTERM,   3)+
     *                               IUTORD(LUTORD,NUMORD,3),
     *                                      NZ_BRA,NZ_KET,3)
C
                     IF (ISIDIA.EQ.1) THEN
C
                         IF (KARTEZ.EQ.0.OR.KARTEZ.EQ.2) THEN
                             TERASM=TERASM*IPHAPP(NY_BRA,NY_KET,KARTEZ)
     *                                    *PHACOM(KARTEZ)
                         ELSE
                             TERASM=C_ZERO
                         END IF
C
                     ELSE
C
                         IF (KARTEZ.EQ.1.OR.KARTEZ.EQ.3) THEN
                             TERASM=TERASM*IPHAPM(NY_BRA,NY_KET,KARTEZ)
     *                                    *PHACOM(KARTEZ)
                         ELSE
                             TERASM=C_ZERO
                         END IF
C
                     END IF
C
                     ELEASM(IBRA,IKET,KARTEZ)=
     *               ELEASM(IBRA,IKET,KARTEZ)+TERASM*JPHASE
C
                  END DO
               END DO
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C       MATRIX ELEMENTS OF THE IMAGINARY PART MULTIPLIED BY "I"
C=======================================================================
C
      IF (MIU.GE.0) THEN
          JPHASE=1
C321G     JPHASE=0
      ELSE
          JPHASE=-(-1)**MIU
C321G     JPHASE=(-1)**MIU
      END IF
C
      DO NUTERM=1,NIMYLM(LAMBDA,NIU)
C
         DO IKET=1,LDBASE
C
            NX_KET=NXVECT(IKET,1)
            NY_KET=NYVECT(IKET,1)
            NZ_KET=NZVECT(IKET,1)
C
            DO IBRA=1,LDBASE
C
               NX_BRA=NXVECT(IBRA,1)
               NY_BRA=NYVECT(IBRA,1)
               NZ_BRA=NZVECT(IBRA,1)
C
               DO LUTORD=1,NUTORD(NUMORD)
                  DO KARTEZ=0,NDKART
C
                     TERASM=
     *                 KIMYLM(LAMBDA,NIU,NUTERM,0)
     *               * MUTORD(LUTORD,NUMORD)
     *               * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   1)+
     *                               IUTORD(LUTORD,NUMORD,1),
     *                                      NX_BRA,NX_KET,1)
     *               * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   2)+
     *                               IUTORD(LUTORD,NUMORD,2),
     *                                      NY_BRA,NY_KET,2)
     *               * COMULT(KIMYLM(LAMBDA,NIU,NUTERM,   3)+
     *                               IUTORD(LUTORD,NUMORD,3),
     *                                      NZ_BRA,NZ_KET,3)
C
                     IF (ISIDIA.EQ.1) THEN
C
                         IF (KARTEZ.EQ.1.OR.KARTEZ.EQ.3) THEN
                             TERASM=TERASM*IPHAPP(NY_BRA,NY_KET,KARTEZ)
     *                                    *PHACOM(KARTEZ)
                         ELSE
                             TERASM=C_ZERO
                         END IF
C
                     ELSE
C
                         IF (KARTEZ.EQ.0.OR.KARTEZ.EQ.2) THEN
                             TERASM=TERASM*IPHAPM(NY_BRA,NY_KET,KARTEZ)
     *                                    *PHACOM(KARTEZ)
                         ELSE
                             TERASM=C_ZERO
                         END IF
C
                     END IF
C
                     ELEASM(IBRA,IKET,KARTEZ)=
     *               ELEASM(IBRA,IKET,KARTEZ)+TERASM*JPHASE*UNIT_I
C
                  END DO
               END DO
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C       NORMALIZATION FACTOR AND THE SPIN FACTOR OF 1/2 THAT  TRANSFORMS
C       THE RESULTS FROM THE PAULI MATRICES TO SPIN.
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            DO KARTEZ=0,NDKART
C
               ELEASM(IBRA,IKET,KARTEZ)=ELEASM(IBRA,IKET,KARTEZ)
     *                                 *COEYLM(LAMBDA,NIU)*0.5D0
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        FOLLOWS MULTIPLICATION BY THE UNITS DEFINED ONCE FOR ALL IN THE
C        SUBROUTINE "DEFUNI". THE UNITS DEFINED FOR MIU=0 ARE  USED  FOR
C        ALL VALUES OF "MIU". THIS STANDARD  IS  D I F F E R E N T  THAN
C        THAT USED FOR THE MULTIPOLE MOMENTS, BECAUSE THE  RESULTS  WILL
C        BE USED IN THE PROPER ANGULAR-MOMENTUM COUPLING.
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.19F) AND (3.20N) MULTIPLICATION
C                    BY UNITS WAS HERE SWITCHED OFF. IT WAS  REINSTALLED
C                    IN VERSION (3.20O) ON 22/10/2023.
C=======================================================================
C         ATTENTION: IN ADDITION, IN VERSION (3.20U) ON  29/10/2023  THE
C                    UNITS WERE REMOVED AGAIN AND THE BUNITS WERE  ADDED
C                    IN THE CALLING SUBROUTINE "ASMMOM".
C=======================================================================
C
C     DO IKET=1,LDBASE
C        DO IBRA=1,LDBASE
C           DO KARTEZ=1,NDKART
C
C              ELEASM(IBRA,IKET,KARTEZ)=ELEASM(IBRA,IKET,KARTEZ)
C    *                                 *QUNITS(LAMBDA,0)
C
C           END DO
C        END DO
C     END DO
C
C=======================================================================
C
      CALL CPUTIM('INTASM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE COMASS(ISIMPY,ISIGNY,ISIQTY,QMOMUL,KMULMO,ISHIFT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /SHIFTR/ RSHIFT(1:NDKART)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE CENTER-OF-MASS COORDINATES
C        IN FERMIS.
C=======================================================================
C
      ISHIFT=0
C
      RSHIFT(1)=0.0D0
      RSHIFT(2)=0.0D0
      RSHIFT(3)=0.0D0
C
      IF ((ISIMPY.NE.1.OR.ISIGNY.NE.1).AND.ISIQTY.NE.1.AND.
     *     ABS(QMOMUL(0,0)).GT.1.D-10) THEN
C
          ISHIFT=1
C
          IF (KMULMO.LT.1) STOP 'KMULMO<1 IN COMASS'
C
          IF (ISIMPY.NE.1) THEN
C
              RSHIFT(2)=-QMOMUL(1,-1)*10/QMOMUL(0,0)
C
          END IF
C
          IF (ISIGNY.NE.1) THEN
C
              RSHIFT(1)= QMOMUL(1, 1)*10/QMOMUL(0,0)
              RSHIFT(3)= QMOMUL(1, 0)*10/QMOMUL(0,0)
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SHICOE(KMULAC,KSHIAC,ISHIFT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          TEMPOR(0:NDMULT,0:NDMULT,1:NDKART)
C
      COMMON
     *       /NEWBIN/ IBINOM(0:NDMULT,0:NDMULT)
      COMMON
     *       /INTGAU/ GAUINT(0:2*NDMULT),
     *                GAUMUL(0:NDMULT)
      COMMON
     *       /MOMTRA/ TRAMOM(0:NDMULT,-NDMULT:NDMULT,
     *                       0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /DATYLM/ COEYLM(0:NDMULT,0:NDMULT),
     *
     *                NREYLM(0:NDMULT,0:NDMULT),
     *                KREYLM(0:NDMULT,0:NDMULT,1:NDTERM,0:NDKART),
     *
     *                NIMYLM(0:NDMULT,1:NDMULT),
     *                KIMYLM(0:NDMULT,1:NDMULT,1:NDTERM,0:NDKART)
      COMMON
     *       /SHIFTR/ RSHIFT(1:NDKART)
C
C=======================================================================
C
      CALL CPUTIM('SHICOE',1)
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES  THE  TRANSFORMATION  COEFFICIENTS
C                              T_LM^{L'M'}
C        FOR THE MULTIPOLE  MOMENTS  TO  BE  EXPRESSED  IN  THE  SHIFTED
C        REFERENCE FRAME:
C
C        SOLID_LM(R-R0)=SUM_{L'=O,L;M'=-L',L'}T_LM^{L'M'}SOLID_{L'M'}(R)
C
C        WHERE SOLID_LM ARE THE SOLID HARMONICS (AS DEFINED IN "DEFYLM")
C        NOTE THAT  THESE  SOLID  HARMONICS   D O   N O T   CONTAIN  THE
C        UNITS DEFINED IN "DEFUNI". THESE UNITS HAVE  TO  BE  EXPLICITLY
C        SUPPLIED WHEN TRANSFORMING THE MULTIPOLE  OR  SURFACE  MOMENTS.
C=======================================================================
C
      IF (KSHIAC.GT.KMULAC) STOP 'KSHIAC>KMULAC IN SHICOE'
C
C=======================================================================
C         ZEROING "TRAMOM"
C=======================================================================
C
      DO LAMBD1=0,NDMULT
         DO MIU1=-LAMBD1,LAMBD1
C
            DO LAMBD2=0,NDMULT
               DO MIU2=-LAMBD2,LAMBD2
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=0.0D0
C
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         DEFINING "TRAMOM" IN THE CASE OF NO SHIFT (ISHIFT=0)
C=======================================================================
C
      IF (ISHIFT.EQ.0) THEN
C
          DO LAMBD1=0,KSHIAC
             DO MIU1=-LAMBD1,LAMBD1
C
                TRAMOM(LAMBD1,MIU1,LAMBD1,MIU1)=1.0D0
C
             END DO
          END DO
C
          GO TO 2
C
      END IF
C
C=======================================================================
C         CALCULATING AUXILIARY  ARRAY "TEMPOR" THAT DEPENDS ON THE
C         VECTOR RSHIFT DEFINING THE SHIFTED REFERENCE FRAME.  THIS
C         IS DONE ONLY TO SPEED UP THE CALCULATIONS OF SUMS  BELOW.
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         DO LAMBD1=0,KSHIAC
C
            DO LAMBD2=0,KSHIAC
C
               TEMPOR(LAMBD1,LAMBD2,KARTEZ)=0.0D0
C
               DO LAMBDA=0,LAMBD1
C
                  RESAUX=IBINOM(LAMBD1,LAMBDA)*GAUINT(LAMBD2+LAMBDA)
                  IF (LAMBD1-LAMBDA.NE.0)
     *            RESAUX=RESAUX*(-RSHIFT(KARTEZ))**(LAMBD1-LAMBDA)
C
                  TEMPOR(LAMBD1,LAMBD2,KARTEZ)=
     *            TEMPOR(LAMBD1,LAMBD2,KARTEZ)+RESAUX
C
               END DO
C
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
C         CALCULATING ELEMENTS OF "TRAMOM" FOR NON-NEGATIVE MAGNETIC
C         INDICES (MIU1>=0 AND MIU2>=0).
C=======================================================================
C
      DO LAMBD1=0,KSHIAC
         DO MIU1=0,LAMBD1
C
            DO LAMBD2=0,LAMBD1
               DO MIU2=0,LAMBD2
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=0.0D0
C
                  DO NUTER1=1,NREYLM(LAMBD1,MIU1)
                     DO NUTER2=1,NREYLM(LAMBD2,MIU2)
C
                        TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)+
     *                  KREYLM(LAMBD1,MIU1,NUTER1,0)*
     *                  KREYLM(LAMBD2,MIU2,NUTER2,0)*
     *                  TEMPOR(KREYLM(LAMBD1,MIU1,NUTER1,1),
     *                         KREYLM(LAMBD2,MIU2,NUTER2,1),1)*
     *                  TEMPOR(KREYLM(LAMBD1,MIU1,NUTER1,2),
     *                         KREYLM(LAMBD2,MIU2,NUTER2,2),2)*
     *                  TEMPOR(KREYLM(LAMBD1,MIU1,NUTER1,3),
     *                         KREYLM(LAMBD2,MIU2,NUTER2,3),3)
C
                     END DO
                  END DO
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *            TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)*
     *            COEYLM(LAMBD1,MIU1)*COEYLM(LAMBD2,MIU2)/
     *            GAUMUL(LAMBD2)
C
                  IF (MIU2.NE.0) TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *                           TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)*2.0D0
C
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         CALCULATING ELEMENTS OF "TRAMOM" FOR MIXED-SIGN MAGNETIC
C         INDICES (MIU1>=0 AND MIU2<0).
C=======================================================================
C
      DO LAMBD1=1,KSHIAC
         DO MIU1=0,LAMBD1
C
            DO LAMBD2=1,LAMBD1
               DO MIU2=-LAMBD2,-1
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=0.0D0
C
                  DO NUTER1=1,NREYLM(LAMBD1,MIU1)
                     DO NUTER2=1,NIMYLM(LAMBD2,-MIU2)
C
                        TRAMOM(LAMBD1, MIU1,LAMBD2,MIU2)=
     *                  TRAMOM(LAMBD1, MIU1,LAMBD2,MIU2)+
     *                  KREYLM(LAMBD1, MIU1,NUTER1,0)*
     *                  KIMYLM(LAMBD2,-MIU2,NUTER2,0)*
     *                  TEMPOR(KREYLM(LAMBD1, MIU1,NUTER1,1),
     *                         KIMYLM(LAMBD2,-MIU2,NUTER2,1),1)*
     *                  TEMPOR(KREYLM(LAMBD1, MIU1,NUTER1,2),
     *                         KIMYLM(LAMBD2,-MIU2,NUTER2,2),2)*
     *                  TEMPOR(KREYLM(LAMBD1, MIU1,NUTER1,3),
     *                         KIMYLM(LAMBD2,-MIU2,NUTER2,3),3)
C
                     END DO
                  END DO
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *            TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)*
     *            COEYLM(LAMBD1,MIU1)*COEYLM(LAMBD2,-MIU2)/
     *            GAUMUL(LAMBD2)
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *            TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)*2.0D0*(-1)**MIU2
C
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         CALCULATING ELEMENTS OF "TRAMOM" FOR MIXED-SIGN MAGNETIC
C         INDICES (MIU1<0 AND MIU2>=0).
C=======================================================================
C
      DO LAMBD1=1,KSHIAC
         DO MIU1=-LAMBD1,-1
C
            DO LAMBD2=0,LAMBD1
               DO MIU2=0,LAMBD2
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=0.0D0
C
                  DO NUTER1=1,NIMYLM(LAMBD1,-MIU1)
                     DO NUTER2=1,NREYLM(LAMBD2,MIU2)
C
                        TRAMOM(LAMBD1, MIU1,LAMBD2,MIU2)=
     *                  TRAMOM(LAMBD1, MIU1,LAMBD2,MIU2)+
     *                  KIMYLM(LAMBD1,-MIU1,NUTER1,0)*
     *                  KREYLM(LAMBD2, MIU2,NUTER2,0)*
     *                  TEMPOR(KIMYLM(LAMBD1,-MIU1,NUTER1,1),
     *                         KREYLM(LAMBD2, MIU2,NUTER2,1),1)*
     *                  TEMPOR(KIMYLM(LAMBD1,-MIU1,NUTER1,2),
     *                         KREYLM(LAMBD2, MIU2,NUTER2,2),2)*
     *                  TEMPOR(KIMYLM(LAMBD1,-MIU1,NUTER1,3),
     *                         KREYLM(LAMBD2, MIU2,NUTER2,3),3)
C
                     END DO
                  END DO
C
                  TRAMOM(LAMBD1, MIU1,LAMBD2,MIU2)=
     *            TRAMOM(LAMBD1, MIU1,LAMBD2,MIU2)*
     *            COEYLM(LAMBD1,-MIU1)*COEYLM(LAMBD2,MIU2)/
     *            GAUMUL(LAMBD2)
C
                  IF (MIU2.NE.0) TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *                           TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)*2.0D0
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *            TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)*(-1)**MIU1
C
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         CALCULATING ELEMENTS OF "TRAMOM" FOR NEGATIVE MAGNETIC
C         INDICES (MIU1<0 AND MIU2<0).
C=======================================================================
C
      DO LAMBD1=1,KSHIAC
         DO MIU1=-LAMBD1,-1
C
            DO LAMBD2=1,LAMBD1
               DO MIU2=-LAMBD2,-1
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=0.0D0
C
                  DO NUTER1=1,NIMYLM(LAMBD1,-MIU1)
                     DO NUTER2=1,NIMYLM(LAMBD2,-MIU2)
C
                        TRAMOM(LAMBD1, MIU1,LAMBD2,MIU2)=
     *                  TRAMOM(LAMBD1, MIU1,LAMBD2,MIU2)+
     *                  KIMYLM(LAMBD1,-MIU1,NUTER1,0)*
     *                  KIMYLM(LAMBD2,-MIU2,NUTER2,0)*
     *                  TEMPOR(KIMYLM(LAMBD1,-MIU1,NUTER1,1),
     *                         KIMYLM(LAMBD2,-MIU2,NUTER2,1),1)*
     *                  TEMPOR(KIMYLM(LAMBD1,-MIU1,NUTER1,2),
     *                         KIMYLM(LAMBD2,-MIU2,NUTER2,2),2)*
     *                  TEMPOR(KIMYLM(LAMBD1,-MIU1,NUTER1,3),
     *                         KIMYLM(LAMBD2,-MIU2,NUTER2,3),3)
C
                     END DO
                  END DO
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *            TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)*
     *            COEYLM(LAMBD1,-MIU1)*COEYLM(LAMBD2,-MIU2)/
     *            GAUMUL(LAMBD2)
C
                  TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)=
     *            TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)*2.D0*(-1)**(MIU1+MIU2)
C
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('SHICOE',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SHIMOM(KMULMO,KSHIMO,ISHIFT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          QAUX_N(0:NDMULT,-NDMULT:NDMULT),
     *          QAUX_P(0:NDMULT,-NDMULT:NDMULT),
     *          QAUX_T(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /MOMTRA/ TRAMOM(0:NDMULT,-NDMULT:NDMULT,
     *                       0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QSHIFT/ QSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C
      CALL CPUTIM('SHIMOM',1)
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MULTIPOLE  MOMENTS  IN  THE
C         SHIFTED REFERENCE FRAME
C=======================================================================
C         IT IS ASSUMED THAT THE  ARRAY "TRAMOM" HAS BEEN PREVIOUSLY
C         CALCULATED BY THE SUBROUTINE "SHICOE" UP TO "KSHIMO"
C=======================================================================
C
      IF (KSHIMO.GT.KMULMO) STOP 'KSHIMO>KMULMO IN SHIMOM'
C
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            QSHI_N(LAMBDA,MIU)=0.0D0
            QSHI_P(LAMBDA,MIU)=0.0D0
            QSHI_T(LAMBDA,MIU)=0.0D0
C
         END DO
      END DO
C
      IF (ISHIFT.EQ.0) THEN
C
          DO LAMBDA=0,KSHIMO
             DO MIU=-LAMBDA,LAMBDA
C
                QSHI_N(LAMBDA,MIU)=QMUL_N(LAMBDA,MIU)
                QSHI_P(LAMBDA,MIU)=QMUL_P(LAMBDA,MIU)
                QSHI_T(LAMBDA,MIU)=QMUL_T(LAMBDA,MIU)
C
             END DO
          END DO
C
      END IF
C
      IF (ISHIFT.EQ.0.OR.KSHIMO.EQ.0) GO TO 2
C
C=======================================================================
C         REMOVING THE UNITS FROM THE ORIGINAL MULTIPOLE MOMENTS
C=======================================================================
C
      DO LAMBDA=0,KSHIMO
         DO MIU=-LAMBDA,LAMBDA
C
            NIU=IABS(MIU)
C
            QAUX_N(LAMBDA,MIU)=QMUL_N(LAMBDA,MIU)/QUNITS(LAMBDA,NIU)
            QAUX_P(LAMBDA,MIU)=QMUL_P(LAMBDA,MIU)/QUNITS(LAMBDA,NIU)
            QAUX_T(LAMBDA,MIU)=QMUL_T(LAMBDA,MIU)/QUNITS(LAMBDA,NIU)
C
         END DO
      END DO
C
C=======================================================================
C         TRANSFORMING THE ORIGINAL MULTIPOLE MOMENTS INTO THE SHIFTED
C         MULTIPOLE MOMENTS.
C=======================================================================
C
      DO LAMBD1=0,KSHIMO
         DO MIU1=-LAMBD1,LAMBD1
C
            QSHI_N(LAMBD1,MIU1)=0.0D0
            QSHI_P(LAMBD1,MIU1)=0.0D0
            QSHI_T(LAMBD1,MIU1)=0.0D0
C
            DO LAMBD2=0,LAMBD1
               DO MIU2=-LAMBD2,LAMBD2
C
                  QSHI_N(LAMBD1,MIU1)=QSHI_N(LAMBD1,MIU1)
     *                               +TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)
     *                               *QAUX_N(LAMBD2,MIU2)
C
                  QSHI_P(LAMBD1,MIU1)=QSHI_P(LAMBD1,MIU1)
     *                               +TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)
     *                               *QAUX_P(LAMBD2,MIU2)
C
                  QSHI_T(LAMBD1,MIU1)=QSHI_T(LAMBD1,MIU1)
     *                               +TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)
     *                               *QAUX_T(LAMBD2,MIU2)
C
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         ADDING THE UNITS TO THE TRANSFORMED MULTIPOLE MOMENTS
C=======================================================================
C
      DO LAMBDA=0,KSHIMO
         DO MIU=-LAMBDA,LAMBDA
C
            NIU=IABS(MIU)
C
            QSHI_N(LAMBDA,MIU)=QSHI_N(LAMBDA,MIU)*QUNITS(LAMBDA,NIU)
            QSHI_P(LAMBDA,MIU)=QSHI_P(LAMBDA,MIU)*QUNITS(LAMBDA,NIU)
            QSHI_T(LAMBDA,MIU)=QSHI_T(LAMBDA,MIU)*QUNITS(LAMBDA,NIU)
C
         END DO
      END DO
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('SHIMOM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SHISIF(KMULSI,KSHISI,ISHIFT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          QAUX_N(0:NDMULT,-NDMULT:NDMULT),
     *          QAUX_P(0:NDMULT,-NDMULT:NDMULT),
     *          QAUX_T(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          SAUX_N(0:NDMULT,-NDMULT:NDMULT),
     *          SAUX_P(0:NDMULT,-NDMULT:NDMULT),
     *          SAUX_T(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          VAUX_N(0:NDMULT,-NDMULT:NDMULT,1:NDKART),
     *          VAUX_P(0:NDMULT,-NDMULT:NDMULT,1:NDKART),
     *          VAUX_T(0:NDMULT,-NDMULT:NDMULT,1:NDKART)
C
      COMMON
     *       /MOMTRA/ TRAMOM(0:NDMULT,-NDMULT:NDMULT,
     *                       0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /SMULTI/ SMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                SMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /VMULTI/ VMUL_N(0:NDMULT,-NDMULT:NDMULT,1:NDKART),
     *                VMUL_P(0:NDMULT,-NDMULT:NDMULT,1:NDKART),
     *                VMUL_T(0:NDMULT,-NDMULT:NDMULT,1:NDKART)
      COMMON
     *       /SSHIFT/ SSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                SSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                SSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /SIFUNI/ SUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /VMUUNI/ VUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /SHIFTR/ RSHIFT(1:NDKART)
C
C=======================================================================
C
      CALL CPUTIM('SHISIF',1)
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE SURFACE MOMENTS IN THE SHIFTED
C         REFERENCE FRAME
C=======================================================================
C         IT IS ASSUMED THAT THE  ARRAY "TRAMOM" HAS  BEEN  PREVIOUSLY
C         CALCULATED BY THE SUBROUTINE "SHICOE" UP TO "KSHISI"
C=======================================================================
C
      IF (KSHISI.GT.KMULSI) STOP 'KSHISI>KMULSI IN SHISIF'
C
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            SSHI_N(LAMBDA,MIU)=0.0D0
            SSHI_P(LAMBDA,MIU)=0.0D0
            SSHI_T(LAMBDA,MIU)=0.0D0
C
         END DO
      END DO
C
      IF (ISHIFT.EQ.0) THEN
C
          DO LAMBDA=0,KMULSI
             DO MIU=-LAMBDA,LAMBDA
C
                SSHI_N(LAMBDA,MIU)=SMUL_N(LAMBDA,MIU)
                SSHI_P(LAMBDA,MIU)=SMUL_P(LAMBDA,MIU)
                SSHI_T(LAMBDA,MIU)=SMUL_T(LAMBDA,MIU)
C
             END DO
          END DO
C
      END IF
C
      IF (ISHIFT.EQ.0.OR.KMULSI.EQ.0) GO TO 2
C
C=======================================================================
C         REMOVING UNITS FROM THE ORIGINAL MULTIPOLE, SURFACE, AND
C         VECTOR MOMENTS
C=======================================================================
C
      DO LAMBDA=0,KMULSI
         DO MIU=-LAMBDA,LAMBDA
C
            NIU=IABS(MIU)
C
            QAUX_N(LAMBDA,MIU  )=QMUL_N(LAMBDA,MIU  )/QUNITS(LAMBDA,NIU)
            QAUX_P(LAMBDA,MIU  )=QMUL_P(LAMBDA,MIU  )/QUNITS(LAMBDA,NIU)
            QAUX_T(LAMBDA,MIU  )=QMUL_T(LAMBDA,MIU  )/QUNITS(LAMBDA,NIU)
C
            SAUX_N(LAMBDA,MIU  )=SMUL_N(LAMBDA,MIU  )/SUNITS(LAMBDA,NIU)
            SAUX_P(LAMBDA,MIU  )=SMUL_P(LAMBDA,MIU  )/SUNITS(LAMBDA,NIU)
            SAUX_T(LAMBDA,MIU  )=SMUL_T(LAMBDA,MIU  )/SUNITS(LAMBDA,NIU)
C
            VAUX_N(LAMBDA,MIU,1)=VMUL_N(LAMBDA,MIU,1)/VUNITS(LAMBDA,NIU)
            VAUX_P(LAMBDA,MIU,1)=VMUL_P(LAMBDA,MIU,1)/VUNITS(LAMBDA,NIU)
            VAUX_T(LAMBDA,MIU,1)=VMUL_T(LAMBDA,MIU,1)/VUNITS(LAMBDA,NIU)
C
            VAUX_N(LAMBDA,MIU,2)=VMUL_N(LAMBDA,MIU,2)/VUNITS(LAMBDA,NIU)
            VAUX_P(LAMBDA,MIU,2)=VMUL_P(LAMBDA,MIU,2)/VUNITS(LAMBDA,NIU)
            VAUX_T(LAMBDA,MIU,2)=VMUL_T(LAMBDA,MIU,2)/VUNITS(LAMBDA,NIU)
C
            VAUX_N(LAMBDA,MIU,3)=VMUL_N(LAMBDA,MIU,3)/VUNITS(LAMBDA,NIU)
            VAUX_P(LAMBDA,MIU,3)=VMUL_P(LAMBDA,MIU,3)/VUNITS(LAMBDA,NIU)
            VAUX_T(LAMBDA,MIU,3)=VMUL_T(LAMBDA,MIU,3)/VUNITS(LAMBDA,NIU)
C
         END DO
      END DO
C
C=======================================================================
C         TRANSFORMING THE ORIGINAL SURFACE MOMENTS INTO THE SHIFTED
C         SURFACE MOMENTS.
C=======================================================================
C
      TSHIFT=RSHIFT(1)**2+RSHIFT(2)**2+RSHIFT(3)**2
C
      DO LAMBD1=0,KMULSI
         DO MIU1=-LAMBD1,LAMBD1
C
            SSHI_N(LAMBD1,MIU1)=0.0D0
            SSHI_P(LAMBD1,MIU1)=0.0D0
            SSHI_T(LAMBD1,MIU1)=0.0D0
C
            DO LAMBD2=0,LAMBD1
               DO MIU2=-LAMBD2,LAMBD2
C
                  SSHI_N(LAMBD1,MIU1)=SSHI_N(LAMBD1,MIU1)
     *                              +(SAUX_N(LAMBD2,MIU2)
     *                             -2*VAUX_N(LAMBD2,MIU2,1)*RSHIFT(1)
     *                             -2*VAUX_N(LAMBD2,MIU2,2)*RSHIFT(2)
     *                             -2*VAUX_N(LAMBD2,MIU2,3)*RSHIFT(3)
     *                               +QAUX_N(LAMBD2,MIU2  )*TSHIFT  )
     *                               *TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)
C
                  SSHI_P(LAMBD1,MIU1)=SSHI_P(LAMBD1,MIU1)
     *                              +(SAUX_P(LAMBD2,MIU2)
     *                             -2*VAUX_P(LAMBD2,MIU2,1)*RSHIFT(1)
     *                             -2*VAUX_P(LAMBD2,MIU2,2)*RSHIFT(2)
     *                             -2*VAUX_P(LAMBD2,MIU2,3)*RSHIFT(3)
     *                               +QAUX_P(LAMBD2,MIU2  )*TSHIFT  )
     *                               *TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)
C
                  SSHI_T(LAMBD1,MIU1)=SSHI_T(LAMBD1,MIU1)
     *                              +(SAUX_T(LAMBD2,MIU2)
     *                             -2*VAUX_T(LAMBD2,MIU2,1)*RSHIFT(1)
     *                             -2*VAUX_T(LAMBD2,MIU2,2)*RSHIFT(2)
     *                             -2*VAUX_T(LAMBD2,MIU2,3)*RSHIFT(3)
     *                               +QAUX_T(LAMBD2,MIU2  )*TSHIFT  )
     *                               *TRAMOM(LAMBD1,MIU1,LAMBD2,MIU2)
C
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         ADDING THE UNITS TO THE SHIFTED SURFACE MOMENTS
C=======================================================================
C
      DO LAMBDA=0,KMULSI
         DO MIU=-LAMBDA,LAMBDA
C
            NIU=IABS(MIU)
C
            SSHI_N(LAMBDA,MIU)=SSHI_N(LAMBDA,MIU)*SUNITS(LAMBDA,NIU)
            SSHI_P(LAMBDA,MIU)=SSHI_P(LAMBDA,MIU)*SUNITS(LAMBDA,NIU)
            SSHI_T(LAMBDA,MIU)=SSHI_T(LAMBDA,MIU)*SUNITS(LAMBDA,NIU)
C
         END DO
      END DO
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('SHISIF',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SHIMAG(KMULMA,KSHIMA,ISHIFT,NOSHIM)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      COMMON
     *       /AMULTI/ AMUL_N(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_P(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                AMUL_T(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      COMMON
     *       /ASHIFT/ ASHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                ASHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                ASHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ASHIXX/ ASHIXN(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                ASHIXP(0:NDMULT,-NDMULT:NDMULT,0:NDMORD),
     *                ASHIXT(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
C
C=======================================================================
C
      CALL CPUTIM('SHIMAG',1)
C
C=======================================================================
C         THIS SUBROUTINE SHOULD CALCULATE THE MAGNETIC MOMENTS IN THE
C         SHIFTED REFERENCE FRAME. FOR THE MOMENT THIS PROBLEM IS NOT
C         SOLVED AND THE SHIFTED MOMENTS ARE ASSUMED EQUAL TO THE
C         NON-SHIFTED ONES. THIS IS GOVERNED BY SWITCH "NOSHIM".
C=======================================================================
C
      IF (KSHIMA.GT.KMULMA) STOP 'KSHIMA>KMULMA IN SHIMAG'
C
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            ASHI_N(LAMBDA,MIU)=0.0D0
            ASHI_P(LAMBDA,MIU)=0.0D0
            ASHI_T(LAMBDA,MIU)=0.0D0
C
            ASHIXN(LAMBDA,MIU,:)=0.0D0
            ASHIXP(LAMBDA,MIU,:)=0.0D0
            ASHIXT(LAMBDA,MIU,:)=0.0D0
C
         END DO
      END DO
C
      IF (ISHIFT.EQ.0.OR.NOSHIM.EQ.1) THEN
C
          DO LAMBDA=0,KSHIMA
             DO MIU=-LAMBDA,LAMBDA
C
                ASHI_N(LAMBDA,MIU  )=AMUL_N(LAMBDA,MIU,0)
                ASHI_P(LAMBDA,MIU  )=AMUL_P(LAMBDA,MIU,0)
                ASHI_T(LAMBDA,MIU  )=AMUL_T(LAMBDA,MIU,0)
C
                ASHIXN(LAMBDA,MIU,0)=AMUL_N(LAMBDA,MIU,0)
                ASHIXP(LAMBDA,MIU,0)=AMUL_P(LAMBDA,MIU,0)
                ASHIXT(LAMBDA,MIU,0)=AMUL_T(LAMBDA,MIU,0)
C
             END DO
          END DO
C
      END IF
C
      IF (ISHIFT.EQ.0.OR.KMULMA.EQ.0.OR.NOSHIM.EQ.1) GO TO 2
C
C=======================================================================
C
      STOP 'UNEXPECTED CONDITION IN SHIMAG'
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('SHIMAG',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE EULROT(KSHIMO,KROTMO)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          QUAAUX(-2:2)
      DIMENSION
     *          QUAMOM(1:NDKART,1:NDKART),
     *          ROTMAT(1:NDKART,1:NDKART),
     *          VECTOR(1:NDKART,1:NDKART)
      DIMENSION
     *          SPEQUA(1:NDKART)
      DIMENSION
     *          CELMTS(1:((NDKART+1)*NDKART)/2)
C
      COMPLEX
     *          CELMTS,VECTOR
C
      COMMON
     *       /QSHIFT/ QSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *                QSHI_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /EANGLE/ ALPEUL,BETEUL,GAMEUL
C
C=======================================================================
C        THIS ROUTINE FINDS THE EULER ANGLES OF THE PRINCIPAL-AXES-FRAME
C        BY USING THE DIAGONALIZATION OF THE CARTESIAN QUADRUPOLE MOMENT
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
      SQRT_6=SQRT(6.0D0)
C
      ALPEUL=0.0D0
      BETEUL=0.0D0
      GAMEUL=0.0D0
C
C=======================================================================
C
      IF (KROTMO.EQ.0) GO TO 2
      IF (KSHIMO.LT.2) STOP 'KSHIMO<2 IN EULROT'
C
      DO MIU=-2,2
         QUAAUX(MIU)=QSHI_T(2,MIU)/QUNITS(2,IABS(MIU))
      END DO
C
C=======================================================================
C        CONSTRUCTING THE CARTESIAN MATRIX OF THE QUADRUPOLE MOMENT
C        SEE VARSHALOVICH EQ. 2.6.1(8)
C=======================================================================
C
      QUAMOM(1,1)= QUAAUX( 2)-QUAAUX(0)/SQRT_6
      QUAMOM(1,2)=-QUAAUX(-2)
      QUAMOM(1,3)=-QUAAUX( 1)
C
      QUAMOM(2,2)=-QUAAUX( 2)-QUAAUX(0)/SQRT_6
      QUAMOM(2,3)=-QUAAUX(-1)
C
      QUAMOM(3,3)= QUAAUX( 0)*2/SQRT_6
C
C=======================================================================
C        CONSTRUCTING THE CARTESIAN MATRIX OF THE COMPLEX CONJUGATE OF
C        THE QUADRUPOLE MOMENT, WHICH TRANSFORMS UNDER ROTATIONS AS  A
C        COVARIANT TENSOR,  SEE VARSHALOVICH EQ. 5.5.1(1), BECAUSE OUR
C        QUADRUPOLE MOMENT CORRESPONDS TO A COMPLEX CONJUGATE  OF  THE
C        SPHERICAL HARMONICS, SEE COMMNTS IN SUBROUTINES "MOMETS"  AND
C        "PAXMOM".
C=======================================================================
C        ATTENTION: THIS TRANSFROMATION WAS MISSING IN VERSIONS UP  TO
C                   2.15B, AND THIS BUG HAS BEEN CORRECTED IN  VERSION
C                   2.15C ON 18/03/05.
C=======================================================================
C
      QUAMOM(1,2)=-QUAMOM(1,2)
      QUAMOM(2,3)=-QUAMOM(2,3)
C
C=======================================================================
C        SYMMETRIZING THE CARTESIAN MATRIX OF THE QUADRUPOLE MOMENT
C=======================================================================
C
      QUAMOM(2,1)=QUAMOM(1,2)
C
      QUAMOM(3,1)=QUAMOM(1,3)
      QUAMOM(3,2)=QUAMOM(2,3)
C
C=======================================================================
C        CALLING THE DIAGONALIZATION ROUTINE.  ARRAYS  "CELMTS"  AND
C        "VECTOR" MUST BE DECLARED COMPLEX, EVEN THOUGH THEY CONTAIN
C        REAL NUMBERS.
C=======================================================================
C
      NCOUNT=0
C
      DO KARKET=1,NDKART
         DO KARBRA=KARKET,NDKART
C
            NCOUNT=NCOUNT+1
C
            CELMTS(NCOUNT)=QUAMOM(KARBRA,KARKET)
C
         END DO
      END DO
C
      LDKART=NDKART
C
      CALL DIAMAT(CELMTS,SPEQUA,VECTOR,LDKART,NDKART,LDKART)
C
C=======================================================================
C        CALCULATING THE ROTATION MATRIX THAT IS EQUAL TO THE MATRIX  OF
C        THE EIGENVECTORS, SEE NOTES 7.54B. NOTE  THAT  THE EIGENVECTORS
C        NOS. 1 AND 2 (X AND Y) HAVE TO BE EXCHANGED  IN ORDER TO OBTAIN
C        THE EULER ANGLES FOR THE INTRINSIC SYSTEM IN THE  FIRST  SECTOR
C        OF THE BOHR_GAMMA ANGLES, 0<=BOHR_GAMMA<=60, I.E.,
C        <Q_YY>.LE.<Q_XX>.LE.<Q_ZZ>    OR     <Y**2>.LE.<X**2>.LE.<Z**2>
C=======================================================================
C
      DO KARBRA=1,NDKART
C
         ROTMAT(KARBRA,2)=REAL(VECTOR(KARBRA,1))
         ROTMAT(KARBRA,1)=REAL(VECTOR(KARBRA,2))
         ROTMAT(KARBRA,3)=REAL(VECTOR(KARBRA,3))
C
      END DO
C
C=======================================================================
C        CHANGING THE PHASES OF COLS NO. 2 AND 3 OF THE ROTATION  MATRIX
C        (I.E., THE PHASES OF EIGENVECTORS OF QUADRUPOLE MOMENT) IN SUCH
C        A WAY THAT THE ELEMENTS IN THE LAST ROW ARE NON-NEGATIVE.  THIS
C        CORRESPONDS TO SELECTING THE EULER ANGLES:
C        0<=BETA<=PI/2 AND 0<=GAMMA<=PI
C=======================================================================
C
      DO KARKET=2,NDKART
C
         IF (ROTMAT(3,KARKET).LT.0) THEN
C
             FACTOR=-1
         ELSE
             FACTOR= 1
C
         END IF
C
         DO KARBRA=1,NDKART
C
            ROTMAT(KARBRA,KARKET)=FACTOR*ROTMAT(KARBRA,KARKET)
C
         END DO
C
      END DO
C
C=======================================================================
C        CHANGING THE PHASE OF COLUMN NO. 1 OF THE  ROTATION  MATRIX  IN
C        SUCH A WAY THAT THE MATRIX HAS A POSITIVE DETERMINANT
C=======================================================================
C
      DETMAT=ROTMAT(1,1)*ROTMAT(2,2)*ROTMAT(3,3)
     *      +ROTMAT(1,2)*ROTMAT(2,3)*ROTMAT(3,1)
     *      +ROTMAT(1,3)*ROTMAT(2,1)*ROTMAT(3,2)
     *      -ROTMAT(1,1)*ROTMAT(2,3)*ROTMAT(3,2)
     *      -ROTMAT(1,2)*ROTMAT(2,1)*ROTMAT(3,3)
     *      -ROTMAT(1,3)*ROTMAT(2,2)*ROTMAT(3,1)
C
      IF (DETMAT.LT.0) THEN
C
          FACTOR=-1
      ELSE
          FACTOR= 1
C
      END IF
C
      KARKET=1
C
      DO KARBRA=1,NDKART
C
         ROTMAT(KARBRA,KARKET)=FACTOR*ROTMAT(KARBRA,KARKET)
C
      END DO
C
C=======================================================================
C        CALCULATING THE EULER ANGLES FROM THE ELEMENTS OF THE  ROTATION
C        MATRIX, SEE VARSHALOVICH EQ. 1.4.6(54) AND NOTES 7.54B.
C=======================================================================
C        IN ORDER TO INCREASE PRECISION, BELOW ALWAYS THE SMALLER MATRIX
C        ELEMENTS ARE USED TO DETERMINE ANGLES. THIS IS SO BECAUSE  WHEN
C        THE ABSOLUTE VALUE OF COS(ANGL) IS SMALLER THEN SIN(ANGL)  THAN
C        THE ACOS GIVES A MORE PRECISE ANGL THAN ASIN, AND VICE VERSA.
C=======================================================================
C
C=======================================================================
C        DETERMINING BETEUL
C=======================================================================
C
      ROTHEL=SQRT(ROTMAT(1,3)**2+ROTMAT(2,3)**2)
C
      IF (ABS(ROTMAT(3,3)).LT.ROTHEL) THEN
C
          COSBET=ROTMAT(3,3)
C
          IF (COSBET.GT. 1.0D0) STOP ' TOO LARGE COSBET IN EULROT'
          IF (COSBET.LT. 0.0D0) STOP ' TOO SMALL COSBET IN EULROT'
C
          BETEUL=ACOS(COSBET)
C
          SINBET=SIN(BETEUL)
C
      ELSE
C
          SINBET=ROTHEL
C
          IF (SINBET.GT. 1.0D0) STOP ' TOO LARGE SINBET IN EULROT'
          IF (SINBET.LT. 0.0D0) STOP ' TOO SMALL SINBET IN EULROT'
C
          BETEUL=ASIN(SINBET)
C
      END IF
C
      SINLIM=1.0D-8
C
      IF (SINBET.LT.SINLIM) THEN
C
C=======================================================================
C        HERE WE DEAL WITH THE SITUATION OF VANISHING ANGLE  BETA.  THEN
C        ONLY THE SUM ALPHA+GAMMA CAN BE DETERMINED, AND WE  CAN  CHOOSE
C        GAMMA=0. VALUES OF SINBET SMALLER THAN SINLIM ARE CONSIDERD  TO
C        BE EQUAL TO ZERO, BECAUSE WHAT WE NEED THEN IS AN APPROXIMATION
C        OF COS(EULBET) BY 1, WHICH IS VERY GOOD UP TO SINLIM**2.
C=======================================================================
C
          GAMEUL=0.0D0
C
C=======================================================================
C        DETERMINING ALPEUL
C=======================================================================
C
          IF (ABS(ROTMAT(1,1)).LT.ABS(ROTMAT(2,1))) THEN
C
              COSALP= ROTMAT(1,1)
C
              IF (COSALP.GT. 1.0D0) STOP ' TOO LARGE COSALP IN EULROT'
              IF (COSALP.LT.-1.0D0) STOP ' TOO SMALL COSALP IN EULROT'
C
              ALPEUL=ACOS(COSALP)
C
              IF (ROTMAT(2,1).LT.0.0D0) ALPEUL=2*PI-ALPEUL
C
          ELSE
C
              SINALP= ROTMAT(2,1)
C
              IF (SINALP.GT. 1.0D0) STOP ' TOO LARGE SINALP IN EULROT'
              IF (SINALP.LT.-1.0D0) STOP ' TOO SMALL SINALP IN EULROT'
C
              ALPEUL=ASIN(SINALP)
C
              IF (ROTMAT(1,1).LT.0.0D0) ALPEUL=PI-ALPEUL
C
          END IF
C
      ELSE
C
C=======================================================================
C        HERE WE DEAL WITH THE SITUATION OF NON-ZERO ANGLE BETA.
C=======================================================================
C
C=======================================================================
C        DETERMINING ALPEUL
C=======================================================================
C
          IF (ABS(ROTMAT(1,3)).LT.ABS(ROTMAT(2,3))) THEN
C
              COSALP= ROTMAT(1,3)/SINBET
C
              IF (COSALP.GT. 1.0D0) STOP ' TOO LARGE COSALP IN EULROT'
              IF (COSALP.LT.-1.0D0) STOP ' TOO SMALL COSALP IN EULROT'
C
              ALPEUL=ACOS(COSALP)
C
              IF (ROTMAT(2,3).LT.0.0D0) ALPEUL=2*PI-ALPEUL
C
          ELSE
C
              SINALP= ROTMAT(2,3)/SINBET
C
              IF (SINALP.GT. 1.0D0) STOP ' TOO LARGE SINALP IN EULROT'
              IF (SINALP.LT.-1.0D0) STOP ' TOO SMALL SINALP IN EULROT'
C
              ALPEUL=ASIN(SINALP)
C
              IF (ROTMAT(1,3).LT.0.0D0) ALPEUL=PI-ALPEUL
C
          END IF
C
C=======================================================================
C        DETERMINING GAMEUL
C=======================================================================
C
          IF (ABS(ROTMAT(3,1)).LT.ABS(ROTMAT(3,2))) THEN
C
              COSGAM=-ROTMAT(3,1)/SINBET
C
              IF (COSGAM.GT. 1.0D0) STOP ' TOO LARGE COSGAM IN EULROT'
              IF (COSGAM.LT.-1.0D0) STOP ' TOO SMALL COSGAM IN EULROT'
C
              GAMEUL=ACOS(COSGAM)
C
          ELSE
C
              SINGAM= ROTMAT(3,2)/SINBET
C
              IF (SINGAM.GT. 1.0D0) STOP ' TOO LARGE SINGAM IN EULROT'
              IF (SINGAM.LT. 0.0D0) STOP ' TOO SMALL SINGAM IN EULROT'
C
              GAMEUL=ASIN(SINGAM)
C
              IF (ROTMAT(3,1).GT.0.0D0) GAMEUL=PI-GAMEUL
C
          END IF
C
      END IF
C
C=======================================================================
C
  2   CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PAXMOM(KSHIMO,KROTMO,XUNITS,XSHI_N,XSHI_P,XSHI_T,
     *                  ALPACT,BETACT,GAMACT,XROT_N,XROT_P,XROT_T)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          XSHI_N(0:NDMULT,-NDMULT:NDMULT),
     *          XSHI_P(0:NDMULT,-NDMULT:NDMULT),
     *          XSHI_T(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          XROT_N(0:NDMULT,-NDMULT:NDMULT),
     *          XROT_P(0:NDMULT,-NDMULT:NDMULT),
     *          XROT_T(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          XUNITS(0:NDMULT,0:NDMULT)
      DIMENSION
     *          XAUX_N(0:NDMULT,-NDMULT:NDMULT),
     *          XAUX_P(0:NDMULT,-NDMULT:NDMULT),
     *          XAUX_T(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          WIGNED(-NDMULT:NDMULT,-NDMULT-1:NDMULT+1)
C
C=======================================================================
C
      CALL CPUTIM('PAXMOM',1)
C
C=======================================================================
C     THIS ROUTINE CALCULATES MULTIPOLE MOMENTS IN A  FRAME  ROTATED  BY
C     THE EULER ANGLES  ALPACT,  BETACT,  AND  GAMACT,  SEE VARSHALOVICH
C     EQ. 5.5.1(1), I.E.,
C        QROT_LM = \SUM_N CONJG[D^L_NM(ALPACT,BETACT,GAMACT)] QSHI_LN
C     NOTE THAT THE SUMMATION RUNS OVER THE FIRST MAGNETIC INDEX OF  THE
C     WIGNER FUNCTION D^L_NM. SINCE THE FIRST INDEX IS  ASSOCIATED  WITH
C     THE FIRST ARGUMENT OF THE WIGNER FUNCTION, THE FIRST  ROTATION  IS
C     BY  ALPACT, THE SECOND BY  BETACT, AND THE THIRD BY  GAMACT.  NOTE
C     ALSO THAT THE WIGNER FUNCTION IS DEFINED WITH MINUS SIGNS  IN  THE
C     EXPONENTS OF THE ROTATION OPERATORS, EQS.  4.3(1)  AND  1.4.5(31).
C     NOTE ALSO THAT THE COMPLEX CONJUGATE WIGNER FUNCTION IS USED. THIS
C     TAKES INTO ACCOUNT THE FACT THAT OUR MULTIPOLE MOMENTS  CORRESPOND
C     TO COMPLEX CONJUGATE SPHERICAL HARMONICS.
C=======================================================================
C     ATTENTION: THE COMPLEX CONJUGATION  OF  THE  WIGNER  FUNCTION  WAS
C                MISSING IN VERSIONS UP TO 2.15B, AND THIS BUG HAS  BEEN
C                CORRECTED IN VERSION 2.15C ON 18/03/05.
C=======================================================================
C
      IF (KROTMO.GT.KSHIMO) STOP 'KROTMO>KSHIMO IN PAXMOM'
C
C=======================================================================
C        COPYING THE INPUT MOMENTS TO AN AUXILIARY  ARRAY. THIS ALLOWS
C        CALLING THIS SUBROUTINE WITH THE SAME ARRAYS  FOR  INPUT  AND
C        AND OUTPUT.
C=======================================================================
C
      DO LAMBDA=0,KSHIMO
         DO MIU=-LAMBDA,LAMBDA
C
            XAUX_N(LAMBDA,MIU)=XSHI_N(LAMBDA,MIU)
            XAUX_P(LAMBDA,MIU)=XSHI_P(LAMBDA,MIU)
            XAUX_T(LAMBDA,MIU)=XSHI_T(LAMBDA,MIU)
C
         END DO
      END DO
C
C=======================================================================
C        ZEROING THE ROTATED MOMENTS
C=======================================================================
C
      DO LAMBDA=0,NDMULT
         DO MIU=-LAMBDA,LAMBDA
C
            XROT_N(LAMBDA,MIU)=0.0D0
            XROT_P(LAMBDA,MIU)=0.0D0
            XROT_T(LAMBDA,MIU)=0.0D0
C
         END DO
      END DO
C
      DO LAMBDA=-NDMULT,NDMULT
         DO MIU=-NDMULT-1,NDMULT+1
            WIGNED(LAMBDA,MIU)=0.0D0
         END DO
      END DO
C
C=======================================================================
C
      IF (KROTMO.EQ.0) GO TO 1
C
      XROT_N(0,0)=XAUX_N(0,0)
      XROT_P(0,0)=XAUX_P(0,0)
      XROT_T(0,0)=XAUX_T(0,0)
C
      DO LAMBDA=1,KROTMO
C
C=======================================================================
C        REMOVING THE UNITS
C=======================================================================
C
         DO MIU=-LAMBDA,LAMBDA
C
            XAUX_N(LAMBDA,MIU)=XAUX_N(LAMBDA,MIU)/
     *                         XUNITS(LAMBDA,IABS(MIU))
            XAUX_P(LAMBDA,MIU)=XAUX_P(LAMBDA,MIU)/
     *                         XUNITS(LAMBDA,IABS(MIU))
            XAUX_T(LAMBDA,MIU)=XAUX_T(LAMBDA,MIU)/
     *                         XUNITS(LAMBDA,IABS(MIU))
         END DO
C
C=======================================================================
C        ROTATING BY ALPACT
C=======================================================================
C        NOTE THAT THE ARRAYS XSHI AND  XROT  CONTAIN  REAL  (IMAGINARY)
C        PARTS OF MULTIPOLE MOMENTS FOR A GIVEN VALUE  OF  THE  MAGNETIC
C        INDEX MIU, FOR NON-NEGATIVE (NEGATIVE) VALUES OF MIU,  SEE  THE
C        CORRESPONDING COMMENTS IN SUBROUTINE "MOMETS".
C=======================================================================
C
         DO MIU=-LAMBDA,LAMBDA
C
            XROT_N(LAMBDA,MIU)=XAUX_N(LAMBDA, MIU)*COS(-MIU*ALPACT)
     *              -(-1)**MIU*XAUX_N(LAMBDA,-MIU)*SIN(-MIU*ALPACT)
            XROT_P(LAMBDA,MIU)=XAUX_P(LAMBDA, MIU)*COS(-MIU*ALPACT)
     *              -(-1)**MIU*XAUX_P(LAMBDA,-MIU)*SIN(-MIU*ALPACT)
            XROT_T(LAMBDA,MIU)=XAUX_T(LAMBDA, MIU)*COS(-MIU*ALPACT)
     *              -(-1)**MIU*XAUX_T(LAMBDA,-MIU)*SIN(-MIU*ALPACT)
         END DO
C
C=======================================================================
C        ROTATING BY BETACT
C=======================================================================
C        NOTE THAT THE SUBROUTINE THAT CALCULATES  THE  WIGNER  FUNCTION
C        IS CALLED WITH THE OPOSITE VALUE OF BETACT. THEREFORE, DE FACTO
C        IT RETURNS THE VALUES OF THE SMALL-D WIGNER FUNCTION  WITH  THE
C        TRANSPOSED MAGNETIC INDICES, SEE VARSHALOVICH EQ. 4.4(1). HENCE
C        THE SUMMATION BELOW IS PERFORMED OVER THE SECOND INDEX  OF  THE
C        WIGNER FUNCTION.
C=======================================================================
C
         CALL SMALLW(LAMBDA,-BETACT,WIGNED)
C
         DO MIURIG=-LAMBDA,-1
C
            XAUX_N(LAMBDA,MIURIG)=0.0
            XAUX_P(LAMBDA,MIURIG)=0.0
            XAUX_T(LAMBDA,MIURIG)=0.0
C
            DO MIUSUM=-LAMBDA,-1
C
               XAUX_N(LAMBDA,MIURIG)=XAUX_N(LAMBDA,MIURIG)
     *        +XROT_N(LAMBDA,MIUSUM)*(WIGNED(MIURIG, MIUSUM)
     *                  -(-1)**MIUSUM*WIGNED(MIURIG,-MIUSUM))
               XAUX_P(LAMBDA,MIURIG)=XAUX_P(LAMBDA,MIURIG)
     *        +XROT_P(LAMBDA,MIUSUM)*(WIGNED(MIURIG, MIUSUM)
     *                  -(-1)**MIUSUM*WIGNED(MIURIG,-MIUSUM))
               XAUX_T(LAMBDA,MIURIG)=XAUX_T(LAMBDA,MIURIG)
     *        +XROT_T(LAMBDA,MIUSUM)*(WIGNED(MIURIG, MIUSUM)
     *                  -(-1)**MIUSUM*WIGNED(MIURIG,-MIUSUM))
            END DO
C
         END DO
C
         DO MIURIG=0,LAMBDA
C
            XAUX_N(LAMBDA,MIURIG)=XROT_N(LAMBDA,0)*WIGNED(MIURIG,0)
            XAUX_P(LAMBDA,MIURIG)=XROT_P(LAMBDA,0)*WIGNED(MIURIG,0)
            XAUX_T(LAMBDA,MIURIG)=XROT_T(LAMBDA,0)*WIGNED(MIURIG,0)
C
            DO MIUSUM=1,LAMBDA
C
               XAUX_N(LAMBDA,MIURIG)=XAUX_N(LAMBDA,MIURIG)
     *        +XROT_N(LAMBDA,MIUSUM)*(WIGNED(MIURIG, MIUSUM)
     *                  +(-1)**MIUSUM*WIGNED(MIURIG,-MIUSUM))
               XAUX_P(LAMBDA,MIURIG)=XAUX_P(LAMBDA,MIURIG)
     *        +XROT_P(LAMBDA,MIUSUM)*(WIGNED(MIURIG, MIUSUM)
     *                  +(-1)**MIUSUM*WIGNED(MIURIG,-MIUSUM))
               XAUX_T(LAMBDA,MIURIG)=XAUX_T(LAMBDA,MIURIG)
     *        +XROT_T(LAMBDA,MIUSUM)*(WIGNED(MIURIG, MIUSUM)
     *                  +(-1)**MIUSUM*WIGNED(MIURIG,-MIUSUM))
            END DO
C
         END DO
C
C=======================================================================
C        ROTATING BY GAMACT
C=======================================================================
C
         DO MIU=-LAMBDA,LAMBDA
C
            XROT_N(LAMBDA,MIU)=XAUX_N(LAMBDA, MIU)*COS(-MIU*GAMACT)
     *              -(-1)**MIU*XAUX_N(LAMBDA,-MIU)*SIN(-MIU*GAMACT)
            XROT_P(LAMBDA,MIU)=XAUX_P(LAMBDA, MIU)*COS(-MIU*GAMACT)
     *              -(-1)**MIU*XAUX_P(LAMBDA,-MIU)*SIN(-MIU*GAMACT)
            XROT_T(LAMBDA,MIU)=XAUX_T(LAMBDA, MIU)*COS(-MIU*GAMACT)
     *              -(-1)**MIU*XAUX_T(LAMBDA,-MIU)*SIN(-MIU*GAMACT)
         END DO
C
C=======================================================================
C        RE-INSERTING THE UNITS
C=======================================================================
C
         DO MIU=-LAMBDA,LAMBDA
C
            XROT_N(LAMBDA,MIU)=XROT_N(LAMBDA,MIU)*
     *                         XUNITS(LAMBDA,IABS(MIU))
            XROT_P(LAMBDA,MIU)=XROT_P(LAMBDA,MIU)*
     *                         XUNITS(LAMBDA,IABS(MIU))
            XROT_T(LAMBDA,MIU)=XROT_T(LAMBDA,MIU)*
     *                         XUNITS(LAMBDA,IABS(MIU))
         END DO
C
      END DO
C
C=======================================================================
C
   1  CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('PAXMOM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SMALLW(J_SPIN,BETAWG,WIGNED)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          FACTOR(0:NDFACT),SQRAUX(0:NDFACT**2)
      DIMENSION
     *          WIGNED(-NDMULT:NDMULT,-NDMULT-1:NDMULT+1)
      DIMENSION
     *          WIGJJM(-NDMULT:NDMULT)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE SMALL D WIGNER FUNCTIONS
C        OF ANGLE BETAWG GIVEN IN RADIANS.  VARIABLE  J_SPIN  IS
C        EQUAL TO THE UPPER INDEX J OF THE WIGNER  FUNCTION.  WE
C        LIMIT OURSELVES TO INTEGER VALUES OF J_SPIN. THE PHASES
C        CORRESPOND TO THE VARSHALOVICH CONVENTION.
C=======================================================================
C
      IF (J_SPIN.GT.NDMULT) STOP 'J_SPIN>NDMULT IN SMALLW'
C
      FACTOR(0)=1
      FACTOR(1)=1
C
      DO I=2,2*J_SPIN
         FACTOR(I)=I*FACTOR(I-1)
      END DO
C
      SQRAUX(0)=0
C
      DO I=1,NDFACT**2
         SQRAUX(I)=SQRT(REAL(I))
      END DO
C
      COSBO2=+COS(BETAWG/2)
      SINBO2=-SIN(BETAWG/2)
C
      DO MWIGNE=-J_SPIN,+J_SPIN
C
C        COSSIN=COSBO2**(J_SPIN+MWIGNE)
C    *         *SINBO2**(J_SPIN-MWIGNE)
C
         COSSIN=1.0D0
         IF (J_SPIN+MWIGNE.NE.0) COSSIN=COSSIN*COSBO2**(J_SPIN+MWIGNE)
         IF (J_SPIN-MWIGNE.NE.0) COSSIN=COSSIN*SINBO2**(J_SPIN-MWIGNE)
C
         X_NORM=SQRT(FACTOR(J_SPIN+J_SPIN)
     *             /(FACTOR(J_SPIN+MWIGNE)
     *              *FACTOR(J_SPIN-MWIGNE)))
C
         WIGJJM(MWIGNE)=COSSIN*X_NORM
C
      END DO
C
      COSBET=COS(BETAWG)
      SINBET=SIN(BETAWG)
C
      COSBEM=(1.0D0-COSBET)/2
      COSBEP=(1.0D0+COSBET)/2
C
      DO M_RIGH=-J_SPIN,+J_SPIN
C
         WIGNED(J_SPIN,M_RIGH)=WIGJJM(M_RIGH)
C
      END DO
C
      DO M_LEFT=J_SPIN-1,-J_SPIN,-1
C
         CDENOM=+SQRAUX((J_SPIN+M_LEFT+1)*(J_SPIN-M_LEFT))
C
         DO M_RIGH=J_SPIN,-J_SPIN,-1
C
            COEFM1=-SQRAUX((J_SPIN+M_RIGH)*(J_SPIN-M_RIGH+1))
            COEFP1=+SQRAUX((J_SPIN-M_RIGH)*(J_SPIN+M_RIGH+1))
C
            COEF00=+REAL(M_RIGH)
C
            WIGNED(M_LEFT,M_RIGH)=
     *
     *            (COEFM1*COSBEM*WIGNED(M_LEFT+1,M_RIGH-1)
     *            +COEF00*SINBET*WIGNED(M_LEFT+1, M_RIGH )
     *            +COEFP1*COSBEP*WIGNED(M_LEFT+1,M_RIGH+1))/CDENOM
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RMSQUA(RMSPOS,RADPOS,NPARTI,NRAORD,ITWCEN)
C=======================================================================
      USE MAT_PP
      USE hfodd_sizes
      USE hfodd_twocen
      USE TWCOBO
      USE BIGDEN
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      COMPLEX
     *          RESULT
C=======================================================================
      ALLOCATABLE HAMRAD(:,:)
C=======================================================================
      DIMENSION
     *          RMSPOS(0:NDKART)
      DIMENSION
     *          RADPOS(1:NDMORD)
C
C=======================================================================
      COMMON
     *       /POWNMU/ NMUPOW
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAMRAD(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAMRAD','RMSQUA')
C=======================================================================
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE RMS VALUES OF X, Y, Z, AND R.
C       AND AVERAGE VALUES OF R^N FOR N=2,4,...,2*NRAORD
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN !NOT INDENTED
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         CALL INTRAD(HAMRAD,KARTEZ,1)
C
         RESULT=CMPLX(0.0D0,0.0D0)
C
         DO IBRA=1,LDBASE
            DO IKET=1,LDBASE
C
               RESULT=RESULT + HAMRAD(IBRA,IKET)
     *
     *                    * (BIG_PP(IKET,IBRA,0) + BIG_PP(IKET,IBRA,1))
C
            END DO
         END DO
C
         RMSPOS(KARTEZ)=REAL(RESULT)/NPARTI
C
      END DO
C
      RMSPOS(0)=RMSPOS(1)+RMSPOS(2)+RMSPOS(3)
C
      DO KARTEZ=0,NDKART
C
         RMSPOS(KARTEZ)=SQRT(RMSPOS(KARTEZ))
C
      END DO
C
C=======================================================================
C       CALCULATION OF AVERAGE VALUES OF R^N FOR N=2,4,...,2*NRAORD
C=======================================================================
C
      IF (NRAORD.GT.NDMORD) STOP ' INCREASE NDMORD IN RMSQUA'
C
      IF (NDMORD.NE.3) STOP ' UPDATE DATA FOR .UTORD IN RMSQUA'
C
      IF (2*NRAORD.GT.NMUPOW) STOP ' INCREASE NMUPOW IN RMSQUA'
C
      RADPOS(:)=0.0D0
C
      DO NUMORD=1,NRAORD
C
         CALL INTRAD(HAMRAD,0,NUMORD)
C
         RESULT=CMPLX(0.0D0,0.0D0)
C
         DO IBRA=1,LDBASE
            DO IKET=1,LDBASE
C
               RESULT=RESULT + HAMRAD(IBRA,IKET)
     *
     *                    * (BIG_PP(IKET,IBRA,0) + BIG_PP(IKET,IBRA,1))
C
            END DO
         END DO
C
         RADPOS(NUMORD)=REAL(RESULT)/NPARTI
C
      END DO
C=======================================================================
      ELSEIF (ITWCEN.EQ.2) THEN ! NOT INDENTED
C=======================================================================
C
      IMAREA=1
      DO KARTEZ=1,NDKART
C
         DO LTWCEN=1,NDTWBL
C
             CALL TWC_INTRAD(HAMRAD,KARTEZ,1,LTWCEN)
             CALL TWC_BIGSIM(HAMRAD,LTWCEN,IMAREA,0)
C
         END DO
C
         CALL TWC_BIGOBO
C
         RESULT=CMPLX(0.0D0,0.0D0)
C
         DO IBRA=1,2*LDBTOT
            DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
            END DO
         END DO
C
         RMSPOS(KARTEZ)=REAL(RESULT)/NPARTI
C
      END DO
C
      RMSPOS(0)=RMSPOS(1)+RMSPOS(2)+RMSPOS(3)
C
      DO KARTEZ=0,NDKART
C
         RMSPOS(KARTEZ)=SQRT(RMSPOS(KARTEZ))
C
      END DO
C
      IF (NRAORD.GT.NDMORD) STOP ' INCREASE NDMORD IN RMSQUA'
C
      IF (NDMORD.NE.3) STOP ' UPDATE DATA FOR .UTORD IN RMSQUA'
C
      IF (2*NRAORD.GT.NMUPOW) STOP ' INCREASE NMUPOW IN RMSQUA'
C
      RADPOS(:)=0.0D0
C
      DO NUMORD=1,NRAORD
C
         DO LTWCEN=1,NDTWBL
C
            CALL TWC_INTRAD(HAMRAD,0,NUMORD,LTWCEN)
            CALL TWC_BIGSIM(HAMRAD,LTWCEN,IMAREA,0)
C
         END DO
C
         CALL TWC_BIGOBO
C
         RESULT=CMPLX(0.0D0,0.0D0)
C
         DO IBRA=1,2*LDBTOT
            DO IKET=1,2*LDBTOT
               RESULT=RESULT+BIGOBO(IBRA,IKET)*BIGTWC(IKET,IBRA)
            END DO
         END DO
C
         RADPOS(NUMORD)=REAL(RESULT)/NPARTI
C
      END DO
C
C=======================================================================
C
      END IF !ITWCEN
C
C=======================================================================
      DEALLOCATE (HAMRAD)
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SHIRMS(KMULMO,ISHIFT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /RMSRAD/ RADI_N(0:NDKART),
     *                RADI_P(0:NDKART),
     *                RADI_T(0:NDKART)
      COMMON
     *       /RMSSHI/ RSHI_N(0:NDKART),
     *                RSHI_P(0:NDKART),
     *                RSHI_T(0:NDKART)
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES THE RMS VALUES OF X, Y, Z, AND R
C       IN THE CENTER-OF-MAS REFERENCE FRAME
C=======================================================================
C
      IF (KMULMO.LT.1) STOP 'KMULMO<1 IN SHIRMS'
C
C=======================================================================
C
      IF (ISHIFT.EQ.0) THEN
C
          DO KARTEZ=0,NDKART
C
             RSHI_N(KARTEZ)=RADI_N(KARTEZ)
             RSHI_P(KARTEZ)=RADI_P(KARTEZ)
             RSHI_T(KARTEZ)=RADI_T(KARTEZ)
C
          END DO
C
          GO TO 2
C
      END IF
C
C=======================================================================
C
      RSHI_N(0)=0.0D0
      RSHI_P(0)=0.0D0
      RSHI_T(0)=0.0D0
C
      DO KARTEZ=1,NDKART
C
C=======================================================================
C        CALCULATING THE AVERAGE POSITIONS IN THE INITIAL FRAME
C=======================================================================
C
         IF (KARTEZ.EQ.1) MIU= 1
         IF (KARTEZ.EQ.2) MIU=-1
         IF (KARTEZ.EQ.3) MIU= 0
C
         FACTOR=1.0D0
         IF (KARTEZ.EQ.2) FACTOR=-FACTOR
C
         RPOS_N=0.0D0
         RPOS_P=0.0D0
         RPOS_T=0.0D0
C
         IF (ABS(QMUL_N(0,0)).GT.1.D-10)
     *       RPOS_N=FACTOR*QMUL_N(1,MIU)*10/QMUL_N(0,0)
C
         IF (ABS(QMUL_P(0,0)).GT.1.D-10)
     *       RPOS_P=FACTOR*QMUL_P(1,MIU)*10/QMUL_P(0,0)
C
         IF (ABS(QMUL_T(0,0)).GT.1.D-10)
     *       RPOS_T=FACTOR*QMUL_T(1,MIU)*10/QMUL_T(0,0)
C
C=======================================================================
C        CALCULATING THE SQUARES OF AVERAGE POSITIONS IN THE CMS FRAME
C=======================================================================
C
         RSHI_N(KARTEZ)=
     *               RADI_N(KARTEZ)**2-2*RPOS_N*RADI_N(KARTEZ)+RPOS_N**2
         RSHI_P(KARTEZ)=
     *               RADI_P(KARTEZ)**2-2*RPOS_P*RADI_P(KARTEZ)+RPOS_P**2
         RSHI_T(KARTEZ)=
     *               RADI_T(KARTEZ)**2-2*RPOS_T*RADI_T(KARTEZ)+RPOS_T**2
C
C=======================================================================
C        CALCULATING THE SQUARES OF AVERAGE RADII IN THE CMS FRAME
C=======================================================================
C
         RSHI_N(0)=RSHI_N(0)+RSHI_N(KARTEZ)
         RSHI_P(0)=RSHI_P(0)+RSHI_P(KARTEZ)
         RSHI_T(0)=RSHI_T(0)+RSHI_T(KARTEZ)
C
      END DO
C
C=======================================================================
C        CALCULATING THE AVERAGE POSITIONS AND RADII IN THE CMS FRAME
C=======================================================================
C
      DO KARTEZ=0,NDKART
C
         RSHI_N(KARTEZ)=SQRT(RSHI_N(KARTEZ))
         RSHI_P(KARTEZ)=SQRT(RSHI_P(KARTEZ))
         RSHI_T(KARTEZ)=SQRT(RSHI_T(KARTEZ))
C
      END DO
C
C=======================================================================
C
    2 CONTINUE
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SIGPRI(ICHFLI,IPAFLI,IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN(0:NDISOS)*8,PLUMIN(0:1)*1,
     *          NAMOBS(10)*26,NAMLAR(2)*7
C
      COMMON
     *       /SIGNVA/ NVASIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGNPH/ NP_SIG(NDPAHO,0:NDPARI,0:NDREVE,0:NDISOS),
     *                NH_SIG(NDPAHO,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIG/ NPFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFLIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FILG/ NPFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFILG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMOBS /'ANGULAR MOMENTUM ALIGNMENT',
     *               ' INTRINSIC SPIN ALIGNMENT ',
     *               '  TOTAL SPIN X-ALIGNMENT  ',
     *               'INTRINSIC SPIN X-ALIGNMENT',
     *               '  TOTAL SPIN Z-ALIGNMENT  ',
     *               'INTRINSIC SPIN Z-ALIGNMENT',
     *               '  TOTAL SPIN O-ALIGNMENT  ',
     *               'INTRINSIC SPIN O-ALIGNMENT',
     *               '  QUADRUPOLE MOMENT Q_20  ',
     *               '  QUADRUPOLE MOMENT Q_22  '/
      DATA
     *       NAMLAR /'SMALLER','LARGER '/
      DATA
     *       NAMEPN /'NEUTRONS','PROTONS '/
      DATA
     *       PLUMIN /'+','-'/
C
C=======================================================================
C       PRINTING THE CONFIGURATION DATA READ FROM THE INPUT
C       FOR THE PARITY/SIGNATURE CASE
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''PARITY/SIGNATURE CONFIGURATIONS:'',
     *                                              43X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,11X,''     V A C U U M      '',
     *                         ''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',1H*,/,
     *                 1H*,11X,''     ===========      '',
     *                         ''  =================   '',
     *                         ''      =========       '',1H*,/,
     *                 1H*,11X,'' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
      DO ICHARG=0,NDISOS
C
         ITITLE=0
C
         DO NUPAHO=1,NDPAHO
C
            IF (NP_SIG(NUPAHO,0,0,ICHARG).NE.0.OR.
     *          NP_SIG(NUPAHO,0,1,ICHARG).NE.0.OR.
     *          NP_SIG(NUPAHO,1,0,ICHARG).NE.0.OR.
     *          NP_SIG(NUPAHO,1,1,ICHARG).NE.0.OR.
     *
     *          NH_SIG(NUPAHO,0,0,ICHARG).NE.0.OR.
     *          NH_SIG(NUPAHO,0,1,ICHARG).NE.0.OR.
     *          NH_SIG(NUPAHO,1,0,ICHARG).NE.0.OR.
     *          NH_SIG(NUPAHO,1,1,ICHARG).NE.0.OR.
     *
     *          ITITLE.EQ.0.AND.NUPAHO.EQ.NDPAHO) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(4(I4,1X),''  ''),
     *                                          4(I4,1X),''  '',1H*)')
     *
     *                    NAMEPN(ICHARG),
     *
     *                    NVASIG(       0,0,ICHARG),
     *                    NVASIG(       0,1,ICHARG),
     *                    NVASIG(       1,1,ICHARG),
     *                    NVASIG(       1,0,ICHARG),
     *
     *                    NP_SIG(NUPAHO,0,0,ICHARG),
     *                    NP_SIG(NUPAHO,0,1,ICHARG),
     *                    NP_SIG(NUPAHO,1,1,ICHARG),
     *                    NP_SIG(NUPAHO,1,0,ICHARG),
     *
     *                    NH_SIG(NUPAHO,0,0,ICHARG),
     *                    NH_SIG(NUPAHO,0,1,ICHARG),
     *                    NH_SIG(NUPAHO,1,1,ICHARG),
     *                    NH_SIG(NUPAHO,1,0,ICHARG)
C
                    ITITLE=1
                ELSE
                    WRITE(NFIPRI,'(1H*,2X,8X,'':'',
     *                              20X,''  '',4(I4,1X),''  '',
     *                                         4(I4,1X),''  '',1H*)')
     *
     *                    NVASIG(       0,0,ICHARG),
     *                    NVASIG(       0,1,ICHARG),
     *                    NVASIG(       1,1,ICHARG),
     *                    NVASIG(       1,0,ICHARG),
     *
     *                    NP_SIG(NUPAHO,0,0,ICHARG),
     *                    NP_SIG(NUPAHO,0,1,ICHARG),
     *                    NP_SIG(NUPAHO,1,1,ICHARG),
     *                    NP_SIG(NUPAHO,1,0,ICHARG),
     *
     *                    NH_SIG(NUPAHO,0,0,ICHARG),
     *                    NH_SIG(NUPAHO,0,1,ICHARG),
     *                    NH_SIG(NUPAHO,1,1,ICHARG),
     *                    NH_SIG(NUPAHO,1,0,ICHARG)
C
                END IF
            END IF
C
         END DO
      END DO
C
C=======================================================================
C       PRINTING THE FILLING-APPROXIMATION DATA READ FROM THE INPUT
C       FOR THE PARITY/SIGNATURE CASE
C=======================================================================
C
      ISFILL=0
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,NDREVE
            DO ICHARG=0,NDISOS
C
               IF (NOFILG(IPARIT,IREVER,ICHARG).GE.1) ISFILL=1
C
            END DO
         END DO
      END DO
C
      IF (ISFILL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH THE FILLING APPROXI'',
     *                        ''MATION FOR OCCUPATIONS IN THE''
     *                                                    ,9X,1H*,/,
     *                 1H*,2X,''PARITY/SIGNATURE BLOCKS'',52X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,'' FILLING UP TO STATE  '',
     *                         '' FILLING  FROM STATE  '',
     *                         '' TWICE PARTICLE NUMB  '',1H*,/,
     *                 1H*,11X,'' ===================  '',
     *                         '' ===================  '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,'' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          DO ICHARG=0,NDISOS
C
              WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(4(I4,1X),''  ''),
     *                                         4(I4,1X),''  '',1H*)')
     *
     *              NAMEPN(ICHARG),
     *              NPFILG(0,0,ICHARG),NPFILG(0,1,ICHARG),
     *              NPFILG(1,1,ICHARG),NPFILG(1,0,ICHARG),
     *              NHFILG(0,0,ICHARG),NHFILG(0,1,ICHARG),
     *              NHFILG(1,1,ICHARG),NHFILG(1,0,ICHARG),
     *              NOFILG(0,0,ICHARG),NOFILG(0,1,ICHARG),
     *              NOFILG(1,1,ICHARG),NOFILG(1,0,ICHARG)
C
          END DO
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (SINGLE-PAIR)
C       FOR THE PARITY/SIGNATURE CASE
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *              1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                     ''D CONFIGURATIONS. HERE IS THE INPUT:'',
     *                                                         2X,1H*,/,
     *              1H*,2X,''CHARGE='',    I1,'', PARITY='',         I1,
     *                     '', SIGNATURE='',I1,'', PARTICLE='',      I2,
     *                     '', HOLE='',    I2,'', OBSERVABLE CODE='',I2,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''THEREFORE:'',                    65X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''IN THE PARITY "'',A1,''" '',
     *                     ''AND SIGNATURE "'',A1,''i" '',
     *                     ''BLOCK FOR  '',A8,'' '',
     *                     ''THE STATE HAVING'',               2X,1H*,/,
     *              1H*,2X,''A '',A7,'' '',
     *                     ''VALUE OF THE -- '',A26,'' -- '',
     *                     ''WILL BE  OCCUPIED'',              2X,1H*)')
     *
     *           ICHFLI,IPAFLI,IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  PLUMIN(IPAFLI),
     *                  PLUMIN(IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI),
     *                  NAMEPN(ICHFLI),NAMLAR((SIGN(1,IFLIPI)+3)/2),
     *                  NAMOBS(ABS(IFLIPI))
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (ALL BLOCKS)
C       FOR THE PARITY/SIGNATURE CASE
C=======================================================================
C
      IDIABL=0
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,NDREVE
            DO ICHARG=0,NDISOS
C
               IF (NOFLIG(IPARIT,IREVER,ICHARG).NE.0) IDIABL=1
C
           END DO
         END DO
      END DO
C
      IF (IDIABL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                        ''D CONFIGURATIONS IN THE'',15X,1H*,/,
     *                 1H*,2X,''PARITY/SIGNATURE BLOCKS'',52X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',
     *                         '' O B S E R V A B L E  '',1H*,/,
     *                 1H*,11X,''  =================   '',
     *                         ''      =========       '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,'' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          DO ICHARG=0,NDISOS
C
              WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(4(I4,1X),''  ''),
     *                                         4(I4,1X),''  '',1H*)')
     *
     *              NAMEPN(ICHARG),
     *              NPFLIG(0,0,ICHARG),NPFLIG(0,1,ICHARG),
     *              NPFLIG(1,1,ICHARG),NPFLIG(1,0,ICHARG),
     *              NHFLIG(0,0,ICHARG),NHFLIG(0,1,ICHARG),
     *              NHFLIG(1,1,ICHARG),NHFLIG(1,0,ICHARG),
     *              NOFLIG(0,0,ICHARG),NOFLIG(0,1,ICHARG),
     *              NOFLIG(1,1,ICHARG),NOFLIG(1,0,ICHARG)
C
          END DO
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SIMPRI(ICHFLI,       IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN(0:NDISOS)*8,PLUMIN(0:1)*1,
     *          NAMOBS(10)*26,NAMLAR(2)*7
C
      COMMON
     *       /SIMNVA/ NVASIM(0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMNPH/ NP_SIM(NDPAHO,0:NDSIMP,0:NDISOS),
     *                NH_SIM(NDPAHO,0:NDSIMP,0:NDISOS)
      COMMON
     *       /N_FLIM/ NPFLIM(0:NDREVE,0:NDISOS),
     *                NHFLIM(0:NDREVE,0:NDISOS),
     *                NOFLIM(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMOBS /'ANGULAR MOMENTUM ALIGNMENT',
     *               ' INTRINSIC SPIN ALIGNMENT ',
     *               '  TOTAL SPIN X-ALIGNMENT  ',
     *               'INTRINSIC SPIN X-ALIGNMENT',
     *               '  TOTAL SPIN Z-ALIGNMENT  ',
     *               'INTRINSIC SPIN Z-ALIGNMENT',
     *               '  TOTAL SPIN O-ALIGNMENT  ',
     *               'INTRINSIC SPIN O-ALIGNMENT',
     *               '  QUADRUPOLE MOMENT Q_20  ',
     *               '  QUADRUPOLE MOMENT Q_22  '/
      DATA
     *       NAMLAR /'SMALLER','LARGER '/
      DATA
     *       NAMEPN /'NEUTRONS','PROTONS '/
      DATA
     *       PLUMIN /'+','-'/
C
C=======================================================================
C       PRINTING THE CONFIGURATION DATA READ FROM THE INPUT
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''SIMPLEX CONFIGURATIONS:'',  52X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,11X,''     V A C U U M      '',
     *                         ''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',1H*,/,
     *                 1H*,11X,''     ===========      '',
     *                         ''  =================   '',
     *                         ''     ===========      '',1H*,/,
     *                 1H*,11X,''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
      DO ICHARG=0,NDISOS
C
         ITITLE=0
C
         DO NUPAHO=1,NDPAHO
C
            IF (NP_SIM(NUPAHO,0,ICHARG).NE.0.OR.
     *          NP_SIM(NUPAHO,1,ICHARG).NE.0.OR.
     *          NH_SIM(NUPAHO,0,ICHARG).NE.0.OR.
     *          NH_SIM(NUPAHO,1,ICHARG).NE.0.OR.
     *
     *          ITITLE.EQ.0.AND.NUPAHO.EQ.NDPAHO) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,2I6,8X),
     *                                               2X,2I6,8X ,1H*)')
     *
     *                    NAMEPN(ICHARG),
     *
     *                    NVASIM(       0,ICHARG),
     *                    NVASIM(       1,ICHARG),
     *
     *                    NP_SIM(NUPAHO,0,ICHARG),
     *                    NP_SIM(NUPAHO,1,ICHARG),
     *
     *                    NH_SIM(NUPAHO,0,ICHARG),
     *                    NH_SIM(NUPAHO,1,ICHARG)
C
                    ITITLE=1
                ELSE
                    WRITE(NFIPRI,'(1H*,2X,8X,'':'',
     *                                   20X,''  '',2X,2I6,8X,
     *                                              2X,2I6,8X,1H*)')
     *
     *                    NP_SIM(NUPAHO,0,ICHARG),
     *                    NP_SIM(NUPAHO,1,ICHARG),
     *
     *                    NH_SIM(NUPAHO,0,ICHARG),
     *                    NH_SIM(NUPAHO,1,ICHARG)
C
                END IF
            END IF
C
         END DO
      END DO
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (SINGLE-PAIR)
C       FOR THE SIMPLEX CASE
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *              1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                     ''D CONFIGURATIONS. HERE IS THE INPUT:'',
     *                                                         2X,1H*,/,
     *              1H*,2X,''CHARGE='',   I1,'',           '',
     *                     ''  SIMPLEX='',I1,'', PARTICLE='',       I2,
     *                     '', HOLE='',   I2,'', OBSERVABLE CODE='',I2,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''THEREFORE:       '',
     *                     ''IN THE SIMPLEX "'',A1,''i" '',
     *                     ''BLOCK FOR  '',A8,'' '',
     *                     ''THE STATE HAVING'',               2X,1H*,/,
     *              1H*,2X,''A '',A7,'' '',
     *                     ''VALUE OF THE -- '',A26,'' -- '',
     *                     ''WILL BE  OCCUPIED'',              2X,1H*)')
     *
     *                  ICHFLI,       IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  PLUMIN(IREFLI),
     *                  NAMEPN(ICHFLI),NAMLAR((SIGN(1,IFLIPI)+3)/2),
     *                  NAMOBS(ABS(IFLIPI))
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (ALL BLOCKS)
C       FOR THE SIMPLEX CASE
C=======================================================================
C
      IDIABL=0
C
      DO IREVER=0,NDREVE
         DO ICHARG=0,NDISOS
C
            IF (NOFLIM(IREVER,ICHARG).NE.0) IDIABL=1
C
        END DO
      END DO
C
      IF (IDIABL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                        ''D CONFIGURATIONS IN THE'',15X,1H*,/,
     *                 1H*,2X,''SIMPLEX BLOCKS'',         61X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',
     *                         '' O B S E R V A B L E  '',1H*,/,
     *                 1H*,11X,''  =================   '',
     *                         ''      =========       '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          DO ICHARG=0,NDISOS
C
             WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,2I6,8X),
     *                                        2X,2I6,8X ,1H*)')
     *
     *             NAMEPN(ICHARG),
     *             NPFLIM(0,ICHARG),NPFLIM(1,ICHARG),
     *             NHFLIM(0,ICHARG),NHFLIM(1,ICHARG),
     *             NOFLIM(0,ICHARG),NOFLIM(1,ICHARG)
C
          END DO
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SIQPRI(ICHFLI,IPAFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN(0:NDISOS)*8,PLUMIN(0:1)*1,
     *          NAMOBS(10)*26,NAMLAR(2)*7
      CHARACTER
     *          NAMEPH(-1:+1)*8,NAMEPM(-1:+1)*8
      CHARACTER
     *          NIBLOL*15
C
      COMMON
     *       /SIQNVA/ NVASIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /SIQNPH/ NP_SIQ(NDPAHO,0:NDPARI,0:NDISOS),
     *                NH_SIQ(NDPAHO,0:NDPARI,0:NDISOS)
      COMMON
     *       /N_FLIQ/ NPFLIQ(0:NDPARI,         0:NDISOS),
     *                NHFLIQ(0:NDPARI,         0:NDISOS),
     *                NOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /BLOCNI/ NIBLOC(       0:NDISOS),NIBLOM(NDBLOC,0:NDISOS),
     *                NIBLOE(NDBLOC,0:NDISOS),NIBLOL(NDBLOC,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMOBS /'  TOTAL SPIN Y-ALIGNMENT  ',
     *               'INTRINSIC SPIN Y-ALIGNMENT',
     *               '  TOTAL SPIN X-ALIGNMENT  ',
     *               'INTRINSIC SPIN X-ALIGNMENT',
     *               '  TOTAL SPIN Z-ALIGNMENT  ',
     *               'INTRINSIC SPIN Z-ALIGNMENT',
     *               '  TOTAL SPIN O-ALIGNMENT  ',
     *               'INTRINSIC SPIN O-ALIGNMENT',
     *               '  QUADRUPOLE MOMENT Q_20  ',
     *               '  QUADRUPOLE MOMENT Q_22  '/
      DATA
     *       NAMLAR /'SMALLER','LARGER '/
      DATA
     *       NAMEPN /'NEUTRONS','PROTONS '/
      DATA
     *       NAMEPH /'  HOLE  ',' BAD PH ','PARTICLE'/
      DATA
     *       NAMEPM /'NEGATIVE',' BAD PM ','POSITIVE'/
      DATA
     *       PLUMIN /'+','-'/
C
C=======================================================================
C       PRINTING THE CONFIGURATION DATA READ FROM THE INPUT
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''PARITY CONFIGURATIONS:'',  53X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,11X,''     V A C U U M      '',
     *                         ''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',1H*,/,
     *                 1H*,11X,''     ===========      '',
     *                         ''  =================   '',
     *                         ''     ===========      '',1H*,/,
     *                 1H*,11X,''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
      DO ICHARG=0,NDISOS
C
         ITITLE=0
C
         DO NUPAHO=1,NDPAHO
C
            IF (NP_SIQ(NUPAHO,0,ICHARG).NE.0.OR.
     *          NP_SIQ(NUPAHO,1,ICHARG).NE.0.OR.
     *
     *          NH_SIQ(NUPAHO,0,ICHARG).NE.0.OR.
     *          NH_SIQ(NUPAHO,1,ICHARG).NE.0.OR.
     *
     *          ITITLE.EQ.0.AND.NUPAHO.EQ.NDPAHO) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,2I6,8X),
     *                                               2X,2I6,8X ,1H*)')
     *
     *                    NAMEPN(ICHARG),
     *
     *                    NVASIQ(       0,ICHARG),
     *                    NVASIQ(       1,ICHARG),
     *
     *                    NP_SIQ(NUPAHO,0,ICHARG),
     *                    NP_SIQ(NUPAHO,1,ICHARG),
     *
     *                    NH_SIQ(NUPAHO,0,ICHARG),
     *                    NH_SIQ(NUPAHO,1,ICHARG)
C
                    ITITLE=1
                ELSE
                    WRITE(NFIPRI,'(1H*,2X,8X,'':'',
     *                                   20X,''  '',2X,2I6,8X,
     *                                              2X,2I6,8X,1H*)')
     *
     *                    NP_SIQ(NUPAHO,0,ICHARG),
     *                    NP_SIQ(NUPAHO,1,ICHARG),
     *
     *                    NH_SIQ(NUPAHO,0,ICHARG),
     *                    NH_SIQ(NUPAHO,1,ICHARG)
C
                END IF
            END IF
C
         END DO
      END DO
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (SINGLE-PAIR)
C       FOR THE PARITY CASE
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *              1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                     ''D CONFIGURATIONS. HERE IS THE INPUT:'',
     *                                                         2X,1H*,/,
     *              1H*,2X,''CHARGE='',   I1,'',           '',
     *                     ''   PARITY='',I1,'', PARTICLE='',       I2,
     *                     '', HOLE='',   I2,'', OBSERVABLE CODE='',I2,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''THEREFORE:       '',
     *                     ''IN THE  PARITY "'',A1,''i" '',
     *                     ''BLOCK FOR  '',A8,'' '',
     *                     ''THE STATE HAVING'',               2X,1H*,/,
     *              1H*,2X,''A '',A7,'' '',
     *                     ''VALUE OF THE -- '',A26,'' -- '',
     *                     ''WILL BE  OCCUPIED'',              2X,1H*)')
     *
     *                  ICHFLI,IPAFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  PLUMIN(IPAFLI),
     *                  NAMEPN(ICHFLI),NAMLAR((SIGN(1,IFLIPI)+3)/2),
     *                  NAMOBS(ABS(IFLIPI))
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (ALL BLOCKS)
C       FOR THE PARITY CASE
C=======================================================================
C
      IDIABL=0
C
      DO IPARIT=0,NDPARI
         DO ICHARG=0,NDISOS
C
            IF (NOFLIQ(IPARIT,ICHARG).NE.0) IDIABL=1
C
         END DO
      END DO
C
      IF (IDIABL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                        ''D CONFIGURATIONS IN THE'',15X,1H*,/,
     *                 1H*,2X,''PARITY BLOCKS'',          62X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',
     *                         '' O B S E R V A B L E  '',1H*,/,
     *                 1H*,11X,''  =================   '',
     *                         ''      =========       '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          DO ICHARG=0,NDISOS
C
             WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,2I6,8X),
     *                                        2X,2I6,8X ,1H*)')
     *
     *             NAMEPN(ICHARG),
     *             NPFLIQ(0,ICHARG),NPFLIQ(1,ICHARG),
     *             NHFLIQ(0,ICHARG),NHFLIQ(1,ICHARG),
     *             NOFLIQ(0,ICHARG),NOFLIQ(1,ICHARG)
C
          END DO
C
      END IF
C
      IF (MAXVAL(NIBLOC).GE.1.AND.(MAXVAL(NIBLOM).EQ.+1.OR.
     *                             MINVAL(NIBLOM).EQ.-1.OR.
     *                             MAXVAL(NIBLOE).EQ.+1.OR.
     *                             MINVAL(NIBLOE).EQ.-1)) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,      1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH THE SINGLE-PARTICLE'',
     *                        '' BLOCKING BASED ON THE NILSSON LABELS'',
     *                                                      1X,1H*,/,
     *                 1H*,2X,''IN THE PARITY BLOCKS'',    55X,1H*,/,
     *                                                 1H*,77X,1H*)')
C
          DO ICHARG=0,NDISOS
             DO NUBLOC=1,NIBLOC(ICHARG)
C
                IF (IABS(NIBLOM(NUBLOC,ICHARG)).EQ.1.AND.
     *              IABS(NIBLOE(NUBLOC,ICHARG)).EQ.1)
     *
     *              WRITE(NFIPRI,'(1H*,2X,A8,'': NUMBER'',I2,
     *                                       '' NILSSON LABEL '',A15,
     *                                       '', OMEGA '',A8,
     *                                       '', '',A8,1X,1H*)')
     *             NAMEPN(ICHARG),NUBLOC,
     *                    NIBLOL(NUBLOC,ICHARG),
     *             NAMEPM(NIBLOM(NUBLOC,ICHARG)),
     *             NAMEPH(NIBLOE(NUBLOC,ICHARG))
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SIZPRI(ICHFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN(0:NDISOS)*8,
     *          NAMOBS(10)*26,NAMLAR(2)*7
C
      COMMON
     *       /SIZNPH/ NP_SIZ(NDPAHO,0:NDISOS),
     *                NH_SIZ(NDPAHO,0:NDISOS)
      COMMON
     *       /SIZNVA/ NVASIZ(0:NDISOS)
      COMMON
     *       /N_FLIZ/ NPFLIZ(                  0:NDISOS),
     *                NHFLIZ(                  0:NDISOS),
     *                NOFLIZ(                  0:NDISOS)
      COMMON
     *       /N_FILZ/ NPFILZ(                  0:NDISOS),
     *                NHFILZ(                  0:NDISOS),
     *                NOFILZ(                  0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMOBS /'  TOTAL SPIN Y-ALIGNMENT  ',
     *               'INTRINSIC SPIN Y-ALIGNMENT',
     *               '  TOTAL SPIN X-ALIGNMENT  ',
     *               'INTRINSIC SPIN X-ALIGNMENT',
     *               '  TOTAL SPIN Z-ALIGNMENT  ',
     *               'INTRINSIC SPIN Z-ALIGNMENT',
     *               '  TOTAL SPIN O-ALIGNMENT  ',
     *               'INTRINSIC SPIN O-ALIGNMENT',
     *               '  QUADRUPOLE MOMENT Q_20  ',
     *               '  QUADRUPOLE MOMENT Q_22  '/
      DATA
     *       NAMLAR /'SMALLER','LARGER '/
      DATA
     *       NAMEPN /'NEUTRONS','PROTONS '/
C
C=======================================================================
C       PRINTING THE CONFIGURATION DATA READ FROM THE INPUT
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''NO-SYMMETRY CONFIGURATIONS:'',48X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,11X,''     V A C U U M      '',
     *                         ''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',1H*,/,
     *                 1H*,11X,''     ===========      '',
     *                         ''  =================   '',
     *                         ''     ===========      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
      DO ICHARG=0,NDISOS
C
         ITITLE=0
C
         DO NUPAHO=1,NDPAHO
C
            IF (NP_SIZ(NUPAHO,ICHARG).NE.0.OR.
     *          NH_SIZ(NUPAHO,ICHARG).NE.0.OR.
     *
     *          ITITLE.EQ.0.AND.NUPAHO.EQ.NDPAHO) THEN
C
                IF (ITITLE.EQ.0) THEN
C
                    WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,I9,11X),
     *                                               2X,I9,11X ,1H*)')
     *
     *                    NAMEPN(ICHARG),
     *                    NVASIZ(ICHARG),
     *                    NP_SIZ(NUPAHO,ICHARG),
     *                    NH_SIZ(NUPAHO,ICHARG)
C
                    ITITLE=1
                ELSE
                    WRITE(NFIPRI,'(1H*,2X,8X,'':'',
     *                                   20X,''  '',2X,I9,11X,
     *                                              2X,I9,11X,1H*)')
     *
     *                    NP_SIZ(NUPAHO,ICHARG),
     *                    NH_SIZ(NUPAHO,ICHARG)
C
                END IF
            END IF
C
         END DO
      END DO
C
C=======================================================================
C       PRINTING THE FILLING-APPROXIMATION DATA READ FROM THE INPUT
C       FOR THE NO-SYMMETRY CASE
C=======================================================================
C
      ISFILL=0
C
      DO ICHARG=0,NDISOS
C
         IF (NOFILZ(ICHARG).GE.1) ISFILL=1
C
      END DO
C
      IF (ISFILL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH THE FILLING APPROXI'',
     *                        ''MATION FOR OCCUPATIONS IN THE'',
     *                                                     9X,1H*,/,
     *                 1H*,2X,''NO-SYMMETRY BLOCKS'',     57X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,'' FILLING UP TO STATE  '',
     *                         '' FILLING  FROM STATE  '',
     *                         '' NUMBER OF PARTICLES  '',1H*,/,
     *                 1H*,11X,'' ===================  '',
     *                         '' ===================  '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          DO ICHARG=0,NDISOS
C
             WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(8X,I6,8X),
     *                                        8X,I6,8X ,1H*)')
     *
     *             NAMEPN(ICHARG),
     *             NPFILZ(ICHARG),
     *             NHFILZ(ICHARG),
     *             NOFILZ(ICHARG)
C
          END DO
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (SINGLE-PAIR)
C       FOR THE NO-SYMMETRY CASE
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *              1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                     ''D CONFIGURATIONS. HERE IS THE INPUT:'',
     *                                                         2X,1H*,/,
     *              1H*,2X,''CHARGE='',   I1,'',           '',
     *                     ''          '',1X,'', PARTICLE='',       I2,
     *                     '', HOLE='',   I2,'', OBSERVABLE CODE='',I2,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''THEREFORE:       '',
     *                     ''                '',1X,''   '',
     *                     ''      FOR  '',A8,'' '',
     *                     ''THE STATE HAVING'',               2X,1H*,/,
     *              1H*,2X,''A '',A7,'' '',
     *                     ''VALUE OF THE -- '',A26,'' -- '',
     *                     ''WILL BE  OCCUPIED'',              2X,1H*)')
     *
     *                  ICHFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  NAMEPN(ICHFLI),NAMLAR((SIGN(1,IFLIPI)+3)/2),
     *                  NAMOBS(ABS(IFLIPI))
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (ALL BLOCKS)
C       FOR THE NO-SYMMETRY CASE
C=======================================================================
C
      IDIABL=0
C
      DO ICHARG=0,NDISOS
C
         IF (NOFLIZ(ICHARG).NE.0) IDIABL=1
C
      END DO
C
      IF (IDIABL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                        ''D CONFIGURATIONS IN THE'',15X,1H*,/,
     *                 1H*,2X,''NO-SYMMETRY BLOCKS'',     57X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',
     *                         '' O B S E R V A B L E  '',1H*,/,
     *                 1H*,11X,''  =================   '',
     *                         ''      =========       '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          DO ICHARG=0,NDISOS
C
             WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(8X,I6,8X),
     *                                        8X,I6,8X ,1H*)')
     *
     *             NAMEPN(ICHARG),
     *             NPFLIZ(ICHARG),
     *             NHFLIZ(ICHARG),
     *             NOFLIZ(ICHARG)
C
          END DO
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MIGPRI(       IPAFLI,IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PLUMIN(0:1)*1,
     *          NAMOBS(11)*26,NAMLAR(2)*7
C
      COMMON
     *       /MIGNVA/ NVAMIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGNPH/ NP_MIG(NDPAHO,0:NDPARI,0:NDREVE),
     *                NH_MIG(NDPAHO,0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MLIG/ NPMLIG(0:NDPARI,0:NDREVE),
     *                NHMLIG(0:NDPARI,0:NDREVE),
     *                NOMLIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MILG/ NPMILG(0:NDPARI,0:NDREVE),
     *                NHMILG(0:NDPARI,0:NDREVE),
     *                NOMILG(0:NDPARI,0:NDREVE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMOBS /'ANGULAR MOMENTUM ALIGNMENT',
     *               ' INTRINSIC SPIN ALIGNMENT ',
     *               '  TOTAL SPIN X-ALIGNMENT  ',
     *               'INTRINSIC SPIN X-ALIGNMENT',
     *               '  TOTAL SPIN Z-ALIGNMENT  ',
     *               'INTRINSIC SPIN Z-ALIGNMENT',
     *               '  TOTAL SPIN O-ALIGNMENT  ',
     *               'INTRINSIC SPIN O-ALIGNMENT',
     *               '  QUADRUPOLE MOMENT Q_20  ',
     *               '  QUADRUPOLE MOMENT Q_22  ',
     *               '       ISOSPIN Z-ALIGNMENT'/
      DATA
     *       NAMLAR /'SMALLER','LARGER '/
      DATA
     *       PLUMIN /'+','-'/
C
C=======================================================================
C       PRINTING THE CONFIGURATION DATA READ FROM THE INPUT
C       FOR THE PARITY/SIGNATURE CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *              1H*,2X,''PARITY/SIGNATURE PROTON-NEUTRON-MIXED '',
     *                     ''CONFIGURATIONS:'',
     *                                           22X,1H*,/,
     *                                       1H*,77X,1H*,/,
     *              1H*,11X,''     V A C U U M      '',
     *                      ''  P A R T I C L E S   '',
     *                      ''      H O L E S       '',1H*,/,
     *              1H*,11X,''     ===========      '',
     *                      ''  =================   '',
     *                      ''      =========       '',1H*,/,
     *              1H*,11X,'' (++) (+-) (-+) (--)  '',
     *                      '' (++) (+-) (-+) (--)  '',
     *                      '' (++) (+-) (-+) (--)  '',1H*,/,
     *              1H*,11X,2(21X,'' ''),22X,1H*)')
C
C
      ITITLE=0
C
      DO NUPAHO=1,NDPAHO
C
         IF (NP_MIG(NUPAHO,0,0).NE.0.OR.
     *       NP_MIG(NUPAHO,0,1).NE.0.OR.
     *       NP_MIG(NUPAHO,1,0).NE.0.OR.
     *       NP_MIG(NUPAHO,1,1).NE.0.OR.
     *
     *       NH_MIG(NUPAHO,0,0).NE.0.OR.
     *       NH_MIG(NUPAHO,0,1).NE.0.OR.
     *       NH_MIG(NUPAHO,1,0).NE.0.OR.
     *       NH_MIG(NUPAHO,1,1).NE.0.OR.
     *
     *       ITITLE.EQ.0.AND.NUPAHO.EQ.NDPAHO) THEN
C
             IF (ITITLE.EQ.0) THEN
C
                 WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(4(I4,1X),''  ''),
     *                                       4(I4,1X),''  '',1H*)')
     *
     *                 'NUCLEONS',
     *
     *                 NVAMIG(       0,0),
     *                 NVAMIG(       0,1),
     *                 NVAMIG(       1,1),
     *                 NVAMIG(       1,0),
     *
     *                 NP_MIG(NUPAHO,0,0),
     *                 NP_MIG(NUPAHO,0,1),
     *                 NP_MIG(NUPAHO,1,1),
     *                 NP_MIG(NUPAHO,1,0),
     *
     *                 NH_MIG(NUPAHO,0,0),
     *                 NH_MIG(NUPAHO,0,1),
     *                 NH_MIG(NUPAHO,1,1),
     *                 NH_MIG(NUPAHO,1,0)
C
                 ITITLE=1
             ELSE
                 WRITE(NFIPRI,'(1H*,2X,8X,'':'',
     *                           20X,''  '',4(I4,1X),''  '',
     *                                      4(I4,1X),''  '',1H*)')
     *
     *                 NVAMIG(       0,0),
     *                 NVAMIG(       0,1),
     *                 NVAMIG(       1,1),
     *                 NVAMIG(       1,0),
     *
     *                 NP_MIG(NUPAHO,0,0),
     *                 NP_MIG(NUPAHO,0,1),
     *                 NP_MIG(NUPAHO,1,1),
     *                 NP_MIG(NUPAHO,1,0),
     *
     *                 NH_MIG(NUPAHO,0,0),
     *                 NH_MIG(NUPAHO,0,1),
     *                 NH_MIG(NUPAHO,1,1),
     *                 NH_MIG(NUPAHO,1,0)
C
             END IF
         END IF
C
      END DO
C
C=======================================================================
C       PRINTING THE FILLING-APPROXIMATION DATA READ FROM THE INPUT
C       FOR THE PARITY/SIGNATURE CASE
C=======================================================================
C
      ISFILL=0
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,NDREVE
C
            IF (NOMILG(IPARIT,IREVER).GE.1) ISFILL=1
C
         END DO
      END DO
C
      IF (ISFILL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH THE FILLING APPROXI'',
     *                        ''MATION FOR OCCUPATIONS IN THE''
     *                                                    ,9X,1H*,/,
     *                 1H*,2X,''PARITY/SIGNATURE BLOCKS'',52X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,'' FILLING UP TO STATE  '',
     *                         '' FILLING  FROM STATE  '',
     *                         '' TWICE PARTICLE NUMB  '',1H*,/,
     *                 1H*,11X,'' ===================  '',
     *                         '' ===================  '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,'' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
C
          WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(4(I4,1X),''  ''),
     *                                      4(I4,1X),''  '',1H*)')
     *
     *           'NUCLEONS',
     *           NPMILG(0,0),NPMILG(0,1),
     *           NPMILG(1,1),NPMILG(1,0),
     *           NHMILG(0,0),NHMILG(0,1),
     *           NHMILG(1,1),NHMILG(1,0),
     *           NOMILG(0,0),NOMILG(0,1),
     *           NOMILG(1,1),NOMILG(1,0)
C
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (SINGLE-PAIR)
C       FOR THE PARITY/SIGNATURE AND PROTON-NEUTRON MIXING CASE
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *              1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                     ''D CONFIGURATIONS. HERE IS THE INPUT:'',
     *                                                         2X,1H*,/,
     *              1H*,2X,''       '',    1X,'', PARITY='',         I1,
     *                     '', SIGNATURE='',I1,'', PARTICLE='',      I2,
     *                     '', HOLE='',    I2,'', OBSERVABLE CODE='',I2,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''THEREFORE:'',                    65X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''IN THE PARITY "'',A1,''" '',
     *                     ''AND SIGNATURE "'',A1,''i" '',
     *                     ''BLOCK FOR  '',A8,'' '',
     *                     ''THE STATE HAVING'',               2X,1H*,/,
     *              1H*,2X,''A '',A7,'' '',
     *                     ''VALUE OF THE -- '',A26,'' -- '',
     *                     ''WILL BE  OCCUPIED'',              2X,1H*)')
     *
     *                  IPAFLI,IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  PLUMIN(IPAFLI),
     *                  PLUMIN(IREFLI*(1-IPAFLI)+(1-IREFLI)*IPAFLI),
     *                  'NUCLEONS',NAMLAR((SIGN(1,IFLIPI)+3)/2),
     *                  NAMOBS(ABS(IFLIPI))
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (ALL BLOCKS)
C       FOR THE PARITY/SIGNATURE AND PROTON-NEUTRON MIXING CASE
C=======================================================================
C
      IDIABL=0
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,NDREVE
C
            IF (NOMLIG(IPARIT,IREVER).NE.0) IDIABL=1
C
         END DO
      END DO
C
      IF (IDIABL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                        ''D CONFIGURATIONS IN THE'',15X,1H*,/,
     *                 1H*,2X,''PARITY/SIGNATURE BLOCKS'',52X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',
     *                         '' O B S E R V A B L E  '',1H*,/,
     *                 1H*,11X,''  =================   '',
     *                         ''      =========       '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,'' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',
     *                         '' (++) (+-) (-+) (--)  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
C
          WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(4(I4,1X),''  ''),
     *                                      4(I4,1X),''  '',1H*)')
     *
     *           'NUCLEONS',
     *           NPMLIG(0,0),NPMLIG(0,1),
     *           NPMLIG(1,1),NPMLIG(1,0),
     *           NHMLIG(0,0),NHMLIG(0,1),
     *           NHMLIG(1,1),NHMLIG(1,0),
     *           NOMLIG(0,0),NOMLIG(0,1),
     *           NOMLIG(1,1),NOMLIG(1,0)
C
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MIMPRI(              IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PLUMIN(0:1)*1,
     *          NAMOBS(11)*26,NAMLAR(2)*7
C
      COMMON
     *       /MIMNVA/ NVAMIM(0:NDREVE)
      COMMON
     *       /MIMNPH/ NP_MIM(NDPAHO,0:NDSIMP),
     *                NH_MIM(NDPAHO,0:NDSIMP)
      COMMON
     *       /N_MLIM/ NPMLIM(0:NDREVE),
     *                NHMLIM(0:NDREVE),
     *                NOMLIM(0:NDREVE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMOBS /'ANGULAR MOMENTUM ALIGNMENT',
     *               ' INTRINSIC SPIN ALIGNMENT ',
     *               '  TOTAL SPIN X-ALIGNMENT  ',
     *               'INTRINSIC SPIN X-ALIGNMENT',
     *               '  TOTAL SPIN Z-ALIGNMENT  ',
     *               'INTRINSIC SPIN Z-ALIGNMENT',
     *               '  TOTAL SPIN O-ALIGNMENT  ',
     *               'INTRINSIC SPIN O-ALIGNMENT',
     *               '  QUADRUPOLE MOMENT Q_20  ',
     *               '  QUADRUPOLE MOMENT Q_22  ',
     *               '       ISOSPIN Z-ALIGNMENT'/
      DATA
     *       NAMLAR /'SMALLER','LARGER '/
      DATA
     *       PLUMIN /'+','-'/
C
C=======================================================================
C       PRINTING THE CONFIGURATION DATA READ FROM THE INPUT
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''SIMPLEX PROTON-NEUTRON-MIXED '',
     *                        ''CONFIGURATIONS:'',  31X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,11X,''     V A C U U M      '',
     *                         ''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',1H*,/,
     *                 1H*,11X,''     ===========      '',
     *                         ''  =================   '',
     *                         ''     ===========      '',1H*,/,
     *                 1H*,11X,''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
      ITITLE=0
C
      DO NUPAHO=1,NDPAHO
C
         IF (NP_MIM(NUPAHO,0).NE.0.OR.
     *       NP_MIM(NUPAHO,1).NE.0.OR.
     *
     *       NH_MIM(NUPAHO,0).NE.0.OR.
     *       NH_MIM(NUPAHO,1).NE.0.OR.
     *
     *       ITITLE.EQ.0.AND.NUPAHO.EQ.NDPAHO) THEN
C
             IF (ITITLE.EQ.0) THEN
C
                 WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,2I6,8X),
     *                                            2X,2I6,8X ,1H*)')
     *
     *                 'NUCLEONS',
     *
     *                 NVAMIM(       0),
     *                 NVAMIM(       1),
     *
     *                 NP_MIM(NUPAHO,0),
     *                 NP_MIM(NUPAHO,1),
     *
     *                 NH_MIM(NUPAHO,0),
     *                 NH_MIM(NUPAHO,1)
C
                 ITITLE=1
             ELSE
                 WRITE(NFIPRI,'(1H*,2X,8X,'' '',
     *                                20X,''  '',2X,2I6,8X,
     *                                           2X,2I6,8X,1H*)')
     *
     *                 NP_MIM(NUPAHO,0),
     *                 NP_MIM(NUPAHO,1),
     *
     *                 NH_MIM(NUPAHO,0),
     *                 NH_MIM(NUPAHO,1)
C
             END IF
         END IF
C
      END DO
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (SINGLE-PAIR)
C       FOR THE SIMPLEX CASE
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *              1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                     ''D CONFIGURATIONS. HERE IS THE INPUT:'',
     *                                                         2X,1H*,/,
     *              1H*,2X,''       '',   1X,'',           '',
     *                     ''  SIMPLEX='',I1,'', PARTICLE='',       I2,
     *                     '', HOLE='',   I2,'', OBSERVABLE CODE='',I2,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''THEREFORE:       '',
     *                     ''IN THE SIMPLEX "'',A1,''i" '',
     *                     ''BLOCK FOR  '',A8,'' '',
     *                     ''THE STATE HAVING'',               2X,1H*,/,
     *              1H*,2X,''A '',A7,'' '',
     *                     ''VALUE OF THE -- '',A26,'' -- '',
     *                     ''WILL BE  OCCUPIED'',              2X,1H*)')
     *
     *                                IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  PLUMIN(IREFLI),
     *                  'NUCLEONS',NAMLAR((SIGN(1,IFLIPI)+3)/2),
     *                  NAMOBS(ABS(IFLIPI))
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (ALL BLOCKS)
C       FOR THE SIMPLEX CASE FOR THE PROTON-NEUTRON MIXING
C=======================================================================
C
      IDIABL=0
C
      DO IREVER=0,NDREVE
C
         IF (NOMLIM(IREVER).NE.0) IDIABL=1
C
      END DO
C
      IF (IDIABL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                        ''D CONFIGURATIONS IN THE'',15X,1H*,/,
     *                 1H*,2X,''SIMPLEX BLOCKS'',         61X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',
     *                         '' O B S E R V A B L E  '',1H*,/,
     *                 1H*,11X,''  =================   '',
     *                         ''      =========       '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,2I6,8X),
     *                                     2X,2I6,8X ,1H*)')
     *
     *          'NUCLEONS',
     *          NPMLIM(0),NPMLIM(1),
     *          NHMLIM(0),NHMLIM(1),
     *          NOMLIM(0),NOMLIM(1)
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MIQPRI(IPAFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PLUMIN(0:1)*1,
     *          NAMOBS(11)*26,NAMLAR(2)*7
C
      COMMON
     *       /MIQNVA/ NVAMIQ(0:NDPARI)
      COMMON
     *       /MIQNPH/ NP_MIQ(NDPAHO,0:NDPARI),
     *                NH_MIQ(NDPAHO,0:NDPARI)
      COMMON
     *       /N_MLIQ/ NPMLIQ(0:NDPARI),
     *                NHMLIQ(0:NDPARI),
     *                NOMLIQ(0:NDPARI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMOBS /'  TOTAL SPIN Y-ALIGNMENT  ',
     *               'INTRINSIC SPIN Y-ALIGNMENT',
     *               '  TOTAL SPIN X-ALIGNMENT  ',
     *               'INTRINSIC SPIN X-ALIGNMENT',
     *               '  TOTAL SPIN Z-ALIGNMENT  ',
     *               'INTRINSIC SPIN Z-ALIGNMENT',
     *               '  TOTAL SPIN O-ALIGNMENT  ',
     *               'INTRINSIC SPIN O-ALIGNMENT',
     *               '  QUADRUPOLE MOMENT Q_20  ',
     *               '  QUADRUPOLE MOMENT Q_22  ',
     *               '       ISOSPIN Z-ALIGNMENT'/
      DATA
     *       NAMLAR /'SMALLER','LARGER '/
      DATA
     *       PLUMIN /'+','-'/
C
C=======================================================================
C       PRINTING THE CONFIGURATION DATA READ FROM THE INPUT
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''PARITY PROTON-NEUTRON-MIXED '',
     *                        ''CONFIGURATIONS:'',  32X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,11X,''     V A C U U M      '',
     *                         ''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',1H*,/,
     *                 1H*,11X,''     ===========      '',
     *                         ''  =================   '',
     *                         ''     ===========      '',1H*,/,
     *                 1H*,11X,''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
C
      ITITLE=0
C
      DO NUPAHO=1,NDPAHO
C
         IF (NP_MIQ(NUPAHO,0).NE.0.OR.
     *       NP_MIQ(NUPAHO,1).NE.0.OR.
     *
     *       NH_MIQ(NUPAHO,0).NE.0.OR.
     *       NH_MIQ(NUPAHO,1).NE.0.OR.
     *
     *       ITITLE.EQ.0.AND.NUPAHO.EQ.NDPAHO) THEN
C
             IF (ITITLE.EQ.0) THEN
C
                 WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,2I6,8X),
     *                                            2X,2I6,8X ,1H*)')
     *
     *                 'NUCLEONS',
     *
     *                 NVAMIQ(       0),
     *                 NVAMIQ(       1),
     *
     *                 NP_MIQ(NUPAHO,0),
     *                 NP_MIQ(NUPAHO,1),
     *
     *                 NH_MIQ(NUPAHO,0),
     *                 NH_MIQ(NUPAHO,1)
C
                 ITITLE=1
             ELSE
                 WRITE(NFIPRI,'(1H*,2X,8X,'':'',
     *                                20X,''  '',2X,2I6,8X,
     *                                           2X,2I6,8X,1H*)')
     *
     *                 NP_MIQ(NUPAHO,0),
     *                 NP_MIQ(NUPAHO,1),
     *
     *                 NH_MIQ(NUPAHO,0),
     *                 NH_MIQ(NUPAHO,1)
C
             END IF
         END IF
C
      END DO
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (SINGLE-PAIR)
C       FOR THE PARITY CASE
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *              1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                     ''D CONFIGURATIONS. HERE IS THE INPUT:'',
     *                                                         2X,1H*,/,
     *              1H*,2X,''        '',   1X,'',           '',
     *                     ''   PARITY='',I1,'', PARTICLE='',       I2,
     *                     '', HOLE='',   I2,'', OBSERVABLE CODE='',I2,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''THEREFORE:       '',
     *                     ''IN THE  PARITY "'',A1,''i" '',
     *                     ''BLOCK FOR  '',A8,'' '',
     *                     ''THE STATE HAVING'',               2X,1H*,/,
     *              1H*,2X,''A '',A7,'' '',
     *                     ''VALUE OF THE -- '',A26,'' -- '',
     *                     ''WILL BE  OCCUPIED'',              2X,1H*)')
     *
     *                  IPAFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  PLUMIN(IPAFLI),
     *                  'NUCLEONS',NAMLAR((SIGN(1,IFLIPI)+3)/2),
     *                  NAMOBS(ABS(IFLIPI))
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (ALL BLOCKS)
C       FOR THE PARITY CASE FOR THE PROTON-NEUTRON MIXING
C=======================================================================
C
      IDIABL=0
C
      DO IPARIT=0,NDPARI
C
         IF (NOMLIQ(IPARIT).NE.0) IDIABL=1
C
      END DO
C
      IF (IDIABL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                        ''D CONFIGURATIONS IN THE'',15X,1H*,/,
     *                 1H*,2X,''PARITY BLOCKS'',          62X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',
     *                         '' O B S E R V A B L E  '',1H*,/,
     *                 1H*,11X,''  =================   '',
     *                         ''      =========       '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',
     *                         ''     ( + ) ( - )      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,2I6,8X),
     *                                        2X,2I6,8X ,1H*)')
     *
     *             'NUCLEONS',
     *             NPMLIQ(0),NPMLIQ(1),
     *             NHMLIQ(0),NHMLIQ(1),
     *             NOMLIQ(0),NOMLIQ(1)
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MIZPRI(
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMOBS(11)*26,NAMLAR(2)*7
C
      COMMON
     *       /MIZNPH/ NP_MIZ(NDPAHO),
     *                NH_MIZ(NDPAHO)
      COMMON
     *       /MIZNVA/ NVAMIZ
      COMMON
     *       /N_MLIZ/ NPMLIZ,
     *                NHMLIZ,
     *                NOMLIZ
      COMMON
     *       /N_MILZ/ NPMILZ,
     *                NHMILZ,
     *                NOMILZ
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMOBS /'  TOTAL SPIN Y-ALIGNMENT  ',
     *               'INTRINSIC SPIN Y-ALIGNMENT',
     *               '  TOTAL SPIN X-ALIGNMENT  ',
     *               'INTRINSIC SPIN X-ALIGNMENT',
     *               '  TOTAL SPIN Z-ALIGNMENT  ',
     *               'INTRINSIC SPIN Z-ALIGNMENT',
     *               '  TOTAL SPIN O-ALIGNMENT  ',
     *               'INTRINSIC SPIN O-ALIGNMENT',
     *               '  QUADRUPOLE MOMENT Q_20  ',
     *               '  QUADRUPOLE MOMENT Q_22  ',
     *               '       ISOSPIN Z-ALIGNMENT'/
      DATA
     *       NAMLAR /'SMALLER','LARGER '/
C
C=======================================================================
C       PRINTING THE CONFIGURATION DATA READ FROM THE INPUT
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''NO-SYMMETRY PROTON-NEUTRON-MIXED '',
     *                        ''CONFIGURATIONS:'',27X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,11X,''     V A C U U M      '',
     *                         ''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',1H*,/,
     *                 1H*,11X,''     ===========      '',
     *                         ''  =================   '',
     *                         ''     ===========      '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
      ITITLE=0
C
      DO NUPAHO=1,NDPAHO
C
         IF (NP_MIZ(NUPAHO).NE.0.OR.
     *       NH_MIZ(NUPAHO).NE.0.OR.
     *
     *       ITITLE.EQ.0.AND.NUPAHO.EQ.NDPAHO) THEN
C
             IF (ITITLE.EQ.0) THEN
C
                 WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(2X,I9,11X),
     *                                            2X,I9,11X ,1H*)')
     *
     *                 'NUCLEONS',
     *                 NVAMIZ,
     *                 NP_MIZ(NUPAHO),
     *                 NH_MIZ(NUPAHO)
C
                 ITITLE=1
             ELSE
                 WRITE(NFIPRI,'(1H*,2X,8X,'':'',
     *                                20X,''  '',2X,I9,11X,
     *                                           2X,I9,11X,1H*)')
     *
     *                 NP_MIZ(NUPAHO),
     *                 NH_MIZ(NUPAHO)
C
             END IF
         END IF
C
      END DO
C
C=======================================================================
C       PRINTING THE FILLING-APPROXIMATION DATA READ FROM THE INPUT
C       FOR THE NO-SYMMETRY CASE
C=======================================================================
C
      ISFILL=0
C
      IF (NOMILZ.GE.1) ISFILL=1
C
      IF (ISFILL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH THE FILLING APPROXI'',
     *                        ''MATION FOR OCCUPATIONS IN THE''
     *                                                    ,9X,1H*,/,
     *                 1H*,2X,''NO-SYMMETRY BLOCKS'',     57X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,'' FILLING UP TO STATE  '',
     *                         '' FILLING  FROM STATE  '',
     *                         '' NUMBER OF PARTICLES  '',1H*,/,
     *                 1H*,11X,'' ===================  '',
     *                         '' ===================  '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
C
          WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(8X,I6,8X),
     *                                     8X,I6,8X ,1H*)')
     *
     *          'NUCLEONS',
     *          NPMILZ,
     *          NHMILZ,
     *          NOMILZ
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (SINGLE-PAIR)
C       FOR THE NO-SYMMETRY CASE
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,         1H*,77X,1H*,/,
     *              1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                     ''D CONFIGURATIONS. HERE IS THE INPUT:'',
     *                                                         2X,1H*,/,
     *              1H*,2X,''       '',   1X,'',           '',
     *                     ''          '',1X,'', PARTICLE='',       I2,
     *                     '', HOLE='',   I2,'', OBSERVABLE CODE='',I2,
     *                                                         2X,1H*,/,
     *              1H*,77X,1H*,/,
     *              1H*,2X,''THEREFORE:       '',
     *                     ''                '',1X,''   '',
     *                     ''      FOR  '',A8,'' '',
     *                     ''THE STATE HAVING'',               2X,1H*,/,
     *              1H*,2X,''A '',A7,'' '',
     *                     ''VALUE OF THE -- '',A26,'' -- '',
     *                     ''WILL BE  OCCUPIED'',              2X,1H*)')
     *
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  'NUCLEONS',NAMLAR((SIGN(1,IFLIPI)+3)/2),
     *                  NAMOBS(ABS(IFLIPI))
C
      END IF
C
C=======================================================================
C       PRINTING THE DIABATIC CONFIGURATION DATA (ALL BLOCKS)
C       FOR THE NO-SYMMETRY CASE FOR THE PROTON-NEUTRON MIXING
C=======================================================================
C
      IDIABL=0
C
C
      IF (NOMLIZ.NE.0) IDIABL=1
C
C
      IF (IDIABL.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/,     1H*,77X,1H*,/,
     *                 1H*,2X,''CALCULATIONS WITH DIABATICALLY BLOCKE'',
     *                        ''D CONFIGURATIONS IN THE'',15X,1H*,/,
     *                 1H*,2X,''NO-SYMMETRY BLOCKS'',     57X,1H*,/,
     *                                                1H*,77X,1H*,/,
     *                 1H*,11X,''  P A R T I C L E S   '',
     *                         ''      H O L E S       '',
     *                         '' O B S E R V A B L E  '',1H*,/,
     *                 1H*,11X,''  =================   '',
     *                         ''      =========       '',
     *                         '' ===================  '',1H*,/,
     *                 1H*,11X,2(21X,'' ''),22X,1H*)')
C
          WRITE(NFIPRI,'(1H*,2X,A8,'':'',2(8X,I6,8X),
     *                                     8X,I6,8X ,1H*)')
     *
     *          'NUCLEONS',
     *          NPMLIZ,
     *          NHMLIZ,
     *          NOMLIZ
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MOMPRI(ISIMPY,NAMMOM,NAMREF,NAMEPN,
     *                         QMOMUL,NMOMUL,MOMTYP)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT)
      CHARACTER
     *          PRIMOM(-NDMULT:NDMULT)*15
      CHARACTER
     *          NAMMOM*45,NAMREF*17,NAMEPN*8,PRIMIU*2,MOMTYP*1
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE AVERAGE VALUES  OF  ELECTROMAGNETIC
C       MULTIPOLE   MOMENTS: R**LAMBDA*CONJG(Y(LAMBDA,MIU))
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *             1H*,2X,A45,1X,A17,2X,A8,2X,1H*,/,
     *                                1H*,77X,1H*)')
     *          NAMMOM,NAMREF,NAMEPN
C
      IF (ISIMPY.NE.1) THEN
C
          WRITE(NFIPRI,'(
     *              1H*,2X,''REAL PART  FOR A NON-NEGATIVE PROJECTION'',
     *                                                        35X,1H*,/,
     *              1H*,2X,''IMAGINARY PART FOR A NEGATIVE PROJECTION'',
     *                                                        35X,1H*,/,
     *                                      1H*,77X,1H*,/,
     *                                          79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(79(1H*))')
C
      END IF
C
C=======================================================================
C
      DO MIU=-NDMULT,NDMULT
         PRIMOM(MIU)='  .............'
      END DO
C
      DO LAMBDA=0,MIN(NMOMUL,NDMULT)
C
         DO MIU=-LAMBDA,LAMBDA
C
            QMOMEN = QMOMUL(LAMBDA,MIU)
C
            IF (ISIMPY.EQ.1) THEN
                IF (MIU.LT.0)       PRIMIU='  '
                IF (MIU.GE.0) WRITE(PRIMIU,'(I1,1X)') MIU
            ELSE
                WRITE(PRIMIU,'(I2)') MIU
                IF (PRIMIU(1:2).EQ.' 0') PRIMIU(1:2)='0 '
                IF (PRIMIU(1:1).EQ.' ' ) PRIMIU(1:1)='+'
            END IF
C
            IF (ABS(QMOMEN).LT.1.0E-10) THEN
C
                WRITE(PRIMOM(MIU),'(2X,A1,I1,A2,''='',4X,''ZERO'')')
     *                                          MOMTYP,LAMBDA,PRIMIU
            ELSE
C
               IF (ABS(QMOMEN).LT.1.0E-3.OR.QMOMEN.GT.1000.OR.
     *                                      QMOMEN.LT.-100) THEN
C
                   WRITE(PRIMOM(MIU),'(2X,A1,I1,A2,''='',1PE8.1)')
     *                                 MOMTYP,LAMBDA,PRIMIU,QMOMEN
               ELSE
C
                   WRITE(PRIMOM(MIU),'(2X,A1,I1,A2,''='',F8.4)')
     *                               MOMTYP,LAMBDA,PRIMIU,QMOMEN
               END IF
C
            END IF
C
         END DO
C
C=======================================================================
C
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=0,4)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,     15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-1,-4,-1)
C
C=======================================================================
C
         IF (LAMBDA.EQ.5) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,60X, A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,5)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         60X, A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-5)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.6) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,45X,2A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,6)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         45X,2A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-6,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.7) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,30X,3A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,7)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         30X,3A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-7,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.8) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,8)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-8,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.9) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,    5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,9)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,             5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-9,-1)
         END IF
C
      END DO
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE MAGPRI(IROTAT,NAMMOM,NAMREF,NAMEPN,
     *                  AMOMUL,NMOMAG,NMOORD,MOMTYP)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      DIMENSION
     *          AMOMUL(0:NDMULT,-NDMULT:NDMULT,0:NDMORD)
      DIMENSION
     *          DIPKAR(1:NDKART)
      CHARACTER
     *          PRIMOM(-NDMULT:NDMULT)*15
      CHARACTER
     *          NAMMOM*45,NAMORD*45,NAMREF*17,NAMEPN*8,PRIMIU*2,MOMTYP*1
C
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /ASMUNI/ BUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE AVERAGE VALUES OF MAGNETIC OR
C       SPIN-ASYMMETRY MOMENTS
C=======================================================================
C
      IF (NMOMAG.EQ.0.OR.IROTAT.NE.1) RETURN
C
      IF (NMOORD.GT.NDMORD) STOP ' INCREASE NDMORD IN MAGPRI'
C
C=======================================================================
C       ATTENTION: TEMPORARY TREATMENT OF CONSERVED SIMPLEX
C=======================================================================
C
      JSIMPY=0
C
C=======================================================================
C       LOOP OVER OREDERS OF RADIAL FORMFACTORS - NOT INDENTED
C=======================================================================
C
      DO NUMORD=0,NMOORD
C
      IF (NUMORD.LE.0) THEN
C
          NAMORD=NAMMOM
      ELSE
          WRITE (NAMORD,'(''RADIAL MOMENTS ORDER N='',I1,1X,
     *                    ''[MN*FM^(N+LAMBDA-1)]'')') 2*NUMORD
      END IF
C
      WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *             1H*,2X,A45,1X,A17,2X,A8,2X,1H*)')
     *
     *          NAMORD,NAMREF,NAMEPN
C
      IF (JSIMPY.NE.1.AND.NUMORD.LE.0) THEN
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *              1H*,2X,''REAL PART  FOR A NON-NEGATIVE PROJECTION'',
     *                                                        35X,1H*,/,
     *              1H*,2X,''IMAGINARY PART FOR A NEGATIVE PROJECTION'',
     *                                                        35X,1H*,/,
     *                                      1H*,77X,1H*,/,
     *                                          79(1H*))')
C
      END IF
C
C=======================================================================
C
      DO MIU=-NDMULT,NDMULT
         PRIMOM(MIU)='  .............'
      END DO
C
      DO LAMBDA=1,MIN(NMOMAG,NDMULT)
C
         DO MIU=-LAMBDA,LAMBDA
C
            AMOMEN = AMOMUL(LAMBDA,MIU,NUMORD)
C
            IF (JSIMPY.EQ.1) THEN
                IF (MIU.LT.0)       PRIMIU='  '
                IF (MIU.GE.0) WRITE(PRIMIU,'(I1,1X)') MIU
            ELSE
                WRITE(PRIMIU,'(I2)') MIU
                IF (PRIMIU(1:2).EQ.' 0') PRIMIU(1:2)='0 '
                IF (PRIMIU(1:1).EQ.' ' ) PRIMIU(1:1)='+'
            END IF
C
            IF (ABS(AMOMEN).LT.1.0E-10) THEN
C
                WRITE(PRIMOM(MIU),'(''  '',A1,I1,A2,''='',4X,''ZERO'')')
     *                                              MOMTYP,LAMBDA,PRIMIU
            ELSE
C
               IF (ABS(AMOMEN).LT.1.0E-3.OR.AMOMEN.GT.1000.OR.
     *                                      AMOMEN.LT.-100) THEN
C
                   WRITE(PRIMOM(MIU),'(''  '',A1,I1,A2,''='',1PE8.1)')
     *                                       MOMTYP,LAMBDA,PRIMIU,AMOMEN
               ELSE
C
                   WRITE(PRIMOM(MIU),'(''  '',A1,I1,A2,''='',F8.4)')
     *                                       MOMTYP,LAMBDA,PRIMIU,AMOMEN
               END IF
C
            END IF
C
         END DO
C
C=======================================================================
C
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=0,4)
         IF (JSIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,     15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-1,-4,-1)
C
C=======================================================================
C
         IF (LAMBDA.EQ.5) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,60X, A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,5)
         IF (JSIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         60X, A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-5)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.6) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,45X,2A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,6)
         IF (JSIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         45X,2A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-6,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.7) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,30X,3A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,7)
         IF (JSIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         30X,3A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-7,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.8) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,8)
         IF (JSIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-8,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.9) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,    5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,9)
         IF (JSIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,             5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-9,-1)
         END IF
C
      END DO
C
      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      PI=4.0D0*ATAN(1.00D0)
C
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS 2.07E AND 3.17C, VARIABLES "DIPKAR"
C                   BELOW WERE DIVIDED, FOR NO  GOOD  REASON,  BY  UNITS
C                   "AUNITS". SINCE THESE UNITS WERE ANYHOW IN  "DEFUNI"
C                   SET TO 1, THAT DIVISION HAD NO EFFECT.  ON  27/02/23
C                   IN VERSION 3.17D, WHEN IMPLEMENTING THIS ROUTINE FOR
C                   PRINTING THE SPIN-ASYMMETRY  MOMENTS,  THE  DIVISION
C                   WAS REMOVED TO AVOID A CONFUSION WITH UNITS "QUNITS"
C                   ON WHICH THE  SPIN-ASYMMETRY  MOMENTS  DEPEND.  THIS
C                   DIVISION WAS AGAIN REINSTATED IN VERSION 3.20R AFTER
C                   THE SPIN-ASYMMETRY UNITS  HAVE BEEN  INTRODUCED  FOR
C                   COMPABILITY.
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS 3.20R AND 3.21D, CARTESIAN  VECTORS
C                   OF THE  MAGNETIC  AND  SPIN-ASYMMETRY  MOMENTS  WERE
C                   CODED INCORRECTLY. ONE HAS TO  REMEBER  THAT  ARRAYS
C                   "AMOMUL" CONTAIN FOR MIU>=0 (MIU<0) REAL (IMAGINARY)
C                   PARTS OF THE MOMENTS. BY REVERTING TO WHAT HAS  BEEN
C                   IMPLEMENTED  BEFORE  VERSION  3.20R,  THIS  BUG  WAS
C                   CORRECTED ON 01/11/23 IN VERSION 3.21E.
C=======================================================================
C
      IF (MOMTYP.EQ.'M') THEN
C
          DIPNO1=SQRT(8.0D0*PI/3.0D0)/AUNITS(1,1)
          DIPNO0=SQRT(4.0D0*PI/3.0D0)/AUNITS(1,0)
C
      ELSE IF (MOMTYP.EQ.'A') THEN
C
          DIPNO1=SQRT(32.0D0*PI/5.0D0)/BUNITS(1,1)
          DIPNO0=SQRT(16.0D0*PI/5.0D0)/BUNITS(1,0)
C321G     DIPNO1=SQRT( 8.0D0*PI      )/BUNITS(1,1)
C321G     DIPNO0=SQRT( 4.0D0*PI      )/BUNITS(1,0)
C
      ELSE
          STOP 'INCORRECT MOMTYP IN MAGPRI'
      END IF
C
      DIPKAR(1)=-DIPNO1*AMOMUL(1, 1,NUMORD)
      DIPKAR(2)= DIPNO1*AMOMUL(1,-1,NUMORD)
      DIPKAR(3)= DIPNO0*AMOMUL(1, 0,NUMORD)
C
      IF (NUMORD.LE.0)
     *
     *    WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''CARTESIAN VECTOR OF THE '',A22,
     *                                      1X,A17,1X,A8,2X,1H*,/,
     *                                              1H*,77X,1H*)')
     *           NAMMOM(1:22),NAMREF,NAMEPN
C
      WRITE(NFIPRI,'(1H*,2X,A1,''1_X ='',F11.4,
     *                   2X,A1,''1_Y ='',F11.4,
     *                   2X,A1,''1_Z ='',F11.4,
     *                   2X,A1,''1 ='',  F12.4,            2X,1H*,/,
     *                                              1H*,77X,1H*)')
     *
     *          (MOMTYP,DIPKAR(KARTEZ),KARTEZ=1,NDKART),
     *           MOMTYP,SQRT(DIPKAR(1)**2+DIPKAR(2)**2+DIPKAR(3)**2)
C
C=======================================================================
C
      END DO
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TBCPRI
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDF2BC=5)
C=======================================================================
      COMPLEX
     *          EFO2BC
      COMPLEX
     *          TOT2BC
C
      DIMENSION
     *          TOT2BC(1:NDKART)
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /E2BCTI/ EFO2BC(1:NDF2BC,1:NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE AVERAGE VALUES OF THE TWO-BODY
C       CURRENT CONTRIBUTIONS TO MAGNETIC MOMENTS
C=======================================================================
C
      IF (MAXVAL(MAG2BC).EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *          1H*,2X,''TWO-BODY-CURRENT EXCHANGE CONTRIBUTIONS '',
     *                 ''TO THE MAGNETIC DIPOLE MOMENT    '',
     *                                                   2X,1H*,/,
     *                                              1H*,77X,1H*)')
C
          TOT2BC(:)=0
C
          DO KARTEZ=1,NDKART
             DO IFO2BC=1,NDF2BC
C
                TOT2BC(KARTEZ)=TOT2BC(KARTEZ)+EFO2BC(IFO2BC,KARTEZ)
C
             END DO
          END DO
C
          DO IFO2BC=1,NDF2BC
C
             IF (MAG2BC(IFO2BC).EQ.1)
     *           WRITE(NFIPRI,'(
     *           1H*,2X,''FF'',I1,'': TBC_X='',(1PD10.3),
     *                            ''  TBC_Y='',(1PD10.3),
     *                            ''  TBC_Z='',(1PD10.3),
     *                            ''  TBC=''  ,(1PD10.3),      2X,1H*)')
     *           IFO2BC,(REAL(EFO2BC(IFO2BC,KARTEZ)),KARTEZ=1,NDKART),
     *           SQRT(REAL(EFO2BC(IFO2BC,1))**2
     *               +REAL(EFO2BC(IFO2BC,2))**2
     *               +REAL(EFO2BC(IFO2BC,3))**2)
          END DO
C
          WRITE(NFIPRI,'(
     *       1H*,2X,73(1H-),2X,1H*,/,
     *       1H*,2X,''TOT''  ,'': TBC_X='',(1PD10.3),
     *                        ''  TBC_Y='',(1PD10.3),
     *                        ''  TBC_Z='',(1PD10.3),
     *                        ''  TBC=''  ,(1PD10.3),      2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *      (REAL(TOT2BC(KARTEZ)),KARTEZ=1,NDKART),
     *       SQRT(REAL(TOT2BC(1))**2
     *           +REAL(TOT2BC(2))**2
     *           +REAL(TOT2BC(3))**2)
C
          IPRIMA=1
C
          IF (IPRIMA.EQ.1) THEN  ! NOT INDENTED
C
          DO IFO2BC=1,NDF2BC
C
             IF (MAG2BC(IFO2BC).EQ.1)
     *           WRITE(NFIPRI,'(
     *           1H*,2X,''IM'',I1,'': TBC_X='',(1PD10.3),
     *                            ''  TBC_Y='',(1PD10.3),
     *                            ''  TBC_Z='',(1PD10.3),
     *                            ''  TBC=''  ,(1PD10.3),      2X,1H*)')
     *           IFO2BC,(AIMAG(EFO2BC(IFO2BC,KARTEZ)),KARTEZ=1,NDKART),
     *           SQRT(AIMAG(EFO2BC(IFO2BC,1))**2
     *               +AIMAG(EFO2BC(IFO2BC,2))**2
     *               +AIMAG(EFO2BC(IFO2BC,3))**2)
          END DO
C
          WRITE(NFIPRI,'(
     *       1H*,2X,73(1H-),2X,1H*,/,
     *       1H*,2X,''TOT''  ,'': TBC_X='',(1PD10.3),
     *                        ''  TBC_Y='',(1PD10.3),
     *                        ''  TBC_Z='',(1PD10.3),
     *                        ''  TBC=''  ,(1PD10.3),      2X,1H*,/,
     *                                                1H*,77X,1H*)')
     *      (AIMAG(TOT2BC(KARTEZ)),KARTEZ=1,NDKART),
     *       SQRT(AIMAG(TOT2BC(1))**2
     *           +AIMAG(TOT2BC(2))**2
     *           +AIMAG(TOT2BC(3))**2)
C
         END IF ! IPRIMA NOT INDENTED
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE BOHDEF(ISIMPY,NEXBET,IPRIBE,IPRIBL,NAMREF,NAMEPN,
     *                                RMSPOS,QMOMUL,BOHBET,NMOMUL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          RMSPOS(0:NDKART)
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT),
     *          BOHBET(0:NDMULT,-NDMULT:NDMULT)
      CHARACTER
     *          NAMBET*45,NAMREF*17,NAMEPN*8
C
C=======================================================================
C       THIS SUBROUTINE CALCULATES AND  PRINTS  THE  BOHR  DEFORMATION
C       PARAMETERS CORRESPONDING TO A UNIFORM MASS DISTRIBUTION WITHIN
C       THE SURFACE DEFINED BY
C       R(THETA,PHI)=R0*(1+SUM_{LM} ALPHA_{LM} Y_{LM}(THETA,PHI))
C       WHERE
C       ALPHA_{LM}=BETA_{LM}/SQRT(2-DELTA_{M0})
C       WHICH HAS IDENTICAL  MULTIPOLE  MOMENTS  AS  THOSE  CALCULATED
C       MICROSCOPICALLY. IN  CASE  WHEN  SUCH  DEFORMATION  PARAMETERS
C       CANNOT  BE  DETERMINED,   THE  SUBROUTINE  USES  THE  SIMPLEST
C       FIRST-ORDER EXPRESSION TAKEN FROM RING&SCHUCK (1.35).
C=======================================================================
C       ATTENTION: VALUES OF NON-AXIAL DEFORMATION PARAMETERS (|MIU|>0)
C       CONTAIN FACTOR SQRT(2), WHICH CORRESPONDS TO THE STANDARD  BOHR
C       DEFINITION AND REFLECTS THE FACT THAT THE POSITIVE AND NEGATIVE
C       VALUES OF "MIU" ARE COMBINED TOGETHER.
C=======================================================================
C
      IERROR=0
C
      IF (IPRIBE.EQ.1) THEN
C
          IF (NEXBET.GT.NMOMUL) STOP 'NEXBET.GT.NMOMUL IN BOHDEF'
C
C=======================================================================
C
          CALL EXADEF(NEXBET,IERROR,RMSPOS(0),QMOMUL,
     *                          BOHDEN,BOHRAD,BOHBET)
C
          IF (IERROR.EQ.0) THEN
C
              NAMBET='BOHR DEFORMATIONS  (EXACT MULTIPOLE MOMENTS) '
C
              CALL BETPRI(NEXBET,ISIMPY,NAMBET,NAMREF,NAMEPN,
     *                                  BOHDEN,BOHRAD,BOHBET)
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IPRIBL.EQ.1.OR.IERROR.EQ.1) THEN
C
          IF (NMOMUL.GT.NDMULT) STOP 'NMOMUL.GT.NDMULT IN BOHDEF'
C
C=======================================================================
C
          CALL APPDEF(NMOMUL,RMSPOS(0),QMOMUL,BOHDEN,BOHRAD,BOHBET)
C
          IF (IERROR.EQ.0) THEN
C
              NAMBET='BOHR DEFORMATIONS (FIRST-ORDER APPROXIMATION)'
          ELSE
              NAMBET='BOHR DEFORMATIONS (FIRST-ORDER; EXACT FAILED)'
C
          END IF
C
          CALL BETPRI(NMOMUL,ISIMPY,NAMBET,NAMREF,NAMEPN,
     *                              BOHDEN,BOHRAD,BOHBET)
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE APPDEF(NAPBET,DATRMS,QMOMUL,
     *                  APPDEN,APPRAD,APPBET)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT),
     *          ASKMUL(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          APPBET(0:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C THIS SUBROUTINE FINDS THE BOHR DEFORMATION PARAMETERS
C WITHIN THE LINEAR APPROXIMATION
C=======================================================================
C
      SQR4PI=SQRT(16.D0*ATAN(1.D0))
C
C=======================================================================
C REMOVING UNITS
C=======================================================================
C
      DO LAM=0,NAPBET
         DO MIU=-LAM,LAM
            ASKMUL(LAM,MIU)=QMOMUL(LAM,MIU)/QUNITS(LAM,IABS(MIU))
         END DO
      END DO
C
      ASKSUR=SQR4PI*ASKMUL(0,0)*DATRMS**2
      ASKRAD=SQRT(5.*ASKSUR/(3.*SQR4PI*ASKMUL(0,0)))
      ASKDEN=3*ASKMUL(0,0)/(SQR4PI*ASKRAD**3)
C
C=======================================================================
C CALCULATING LINEAR APPROXIMATION TO BETAS
C=======================================================================
C
      APPBET(:,:)=0.0D0
C
      APPRAD=ASKRAD
      APPDEN=ASKDEN
      FACTOR=APPDEN*APPRAD**4
      DO LAM=1,NAPBET
         DO MIU=-LAM,LAM
            APPBET(LAM,MIU)=ASKMUL(LAM,MIU)/FACTOR
         END DO
         FACTOR=FACTOR*APPRAD
      END DO
C
C=======================================================================
C MULTIPLYING NON-AXIAL BETAS BY SQUARE ROOT OF TWO
C=======================================================================
C
      DO LAM=1,NAPBET
         DO MIU=1,LAM
           APPBET(LAM, MIU)=APPBET(LAM, MIU)*SQRT(2.)
           APPBET(LAM,-MIU)=APPBET(LAM,-MIU)*SQRT(2.)
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE EXADEF(NEXBET,IERROR,DATRMS,QMOMUL,
     *                         EXADEN,EXARAD,EXABET)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          QMOMUL(0:NDMULT,-NDMULT:NDMULT),
     *          ASKMUL(0:NDMULT,-NDMULT:NDMULT),
     *          PARMUL(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          EXABET(1:NDMULT,-NDMULT:NDMULT)
C
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C THIS SUBROUTINE FINDS THE BOHR DEFORMATION PARAMETERS
C=======================================================================
C
      PI=4.D0*ATAN(1.D0)
      SQR4PI=SQRT(16.D0*ATAN(1.D0))
C
C=======================================================================
C REMOVING UNITS
C=======================================================================
C
      DO LAM=0,NEXBET
         DO MIU=-LAM,LAM
            ASKMUL(LAM,MIU)=QMOMUL(LAM,MIU)/QUNITS(LAM,IABS(MIU))
         END DO
      END DO
C
      ASKSUR=SQR4PI*ASKMUL(0,0)*DATRMS**2
      ASKRAD=SQRT(5.*ASKSUR/(3.*SQR4PI*ASKMUL(0,0)))
      ASKDEN=3*ASKMUL(0,0)/(SQR4PI*ASKRAD**3)
C
C=======================================================================
C SETTING INITIAL BETAS
C=======================================================================
C
      EXADEN=ASKDEN
      EXARAD=ASKRAD
      EXASUR=4.*PI*EXADEN*EXARAD**5/5.
      EXAQ00=SQR4PI*EXADEN*EXARAD**3/3.
C
      EXABET(:,:)=0.0D0
C
      EPS=0.01
      OLDCHI=0.
      ITERAT=0
C
    1 CONTINUE
C
C=======================================================================
C INTEGRATING MOMENTS
C=======================================================================
C
      CALL BOHINT(NEXBET,EXADEN,EXARAD,EXABET,PARSUR,PARMUL)
C
C=======================================================================
C CALCULATING CHI-SQUARE
C=======================================================================
C
      CHISQR=0
C
      DO LAM=0,NEXBET
         DO MIU=-LAM,LAM
            CHISQR=CHISQR+(PARMUL(LAM,MIU)-ASKMUL(LAM,MIU))**2
         END DO
      END DO
C
      CHISQR=CHISQR+(PARSUR-ASKSUR)**2
C
C=======================================================================
C ITERATIONS CONTROL
C=======================================================================
C
      IF (CHISQR.GT.1.0D+40.OR.ITERAT.GT.10000) THEN
          IERROR=1
          GO TO 3
      END IF
      IF (CHISQR.LT.1.0D-6) THEN
          IERROR=0
          GO TO 2
      END IF
      ITERAT=ITERAT+1
C
C=======================================================================
C ADJUSTING SLOW-DOWN
C=======================================================================
C
      IF (CHISQR.LT.OLDCHI) THEN
         EPS=EPS*(1.5-0.5*EPS*EPS)
      ELSE
         EPS=0.01
      END IF
      OLDCHI=CHISQR
C
C=======================================================================
C CALCULATING NEW BETAS
C=======================================================================
C
      FACTOR=EXADEN*EXARAD**4
      DO LAM=1,NEXBET
         DO MIU=-LAM,LAM
            EXABET(LAM,MIU)=EXABET(LAM,MIU)
     *                +EPS*(ASKMUL(LAM,MIU)-PARMUL(LAM,MIU))/FACTOR
         END DO
         FACTOR=FACTOR*EXARAD
      END DO
      EXASUR=EXASUR+EPS*(ASKSUR-PARSUR)
      EXAQ00=EXAQ00+EPS*(ASKMUL(0,0)-PARMUL(0,0))
      EXARAD=SQRT(5.*EXASUR/(3.*SQR4PI*EXAQ00))
      EXADEN=3.*EXAQ00/(SQR4PI*EXARAD**3)
C
      GO TO 1
C
    2 CONTINUE
C
C=======================================================================
C MULTIPLYING NON-AXIAL BETAS BY SQUARE ROOT OF TWO
C=======================================================================
C
      DO LAM=1,NEXBET
         DO MIU=1,LAM
           EXABET(LAM, MIU)=EXABET(LAM, MIU)*SQRT(2.)
           EXABET(LAM,-MIU)=EXABET(LAM,-MIU)*SQRT(2.)
         END DO
      END DO
C
    3 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE BOHINT(NEXBET,EXADEN,EXARAD,EXABET,PARSUR,PARMUL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          PARMUL(0:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          EXABET(1:NDMULT,-NDMULT:NDMULT)
      DIMENSION
     *          HAR(0:NDMULT,0:NDMULT)
      DIMENSION
     *          SINUS(-2:NDLAMB)
      DIMENSION
     *          XG32(ND32),WT32(ND32),
     *          XG64(ND64),WT64(ND64)
      DIMENSION
     *          XPOINT(NDMAX),YPOINT(NDMAX),XWEIGH(NDMAX),YWEIGH(NDMAX)
C
      COMMON
     *       /COEFAB/ ALMS00(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                ALMSS0(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                ALMSSS(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *
     *                BLMS00(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                BLMSS0(0:NDLAMB,0:NDLAMB,0:NDLAMB),
     *                BLMSSS(0:NDLAMB,0:NDLAMB,0:NDLAMB)
C
C=======================================================================
C POINTS AND WEIGHTS FOR 32-POINT GAUSS-LEGENDRE QUADRATURES
C=======================================================================
C
      DATA XG32
     *
     *          / .04830766568773832D0, .14447196158279649D0,
     *            .23928736225213708D0, .33186860228212765D0,
     *            .42135127613063535D0, .50689990893222939D0,
     *            .58771575724076233D0, .66304426693021520D0,
     *            .73218211874028968D0, .79448379596794241D0,
     *            .84936761373256997D0, .89632115576605213D0,
     *            .93490607593773969D0, .96476225558750643D0,
     *            .98561151154526834D0, .99726386184948156D0/
      DATA WT32
     *
     *          / .09654008851472780D0, .09563872007927486D0,
     *            .09384439908080457D0, .09117387869576389D0,
     *            .08765209300440381D0, .08331192422694676D0,
     *            .07819389578707031D0, .07234579410884851D0,
     *            .06582222277636185D0, .05868409347853555D0,
     *            .05099805926237618D0, .04283589802222668D0,
     *            .03427386291302143D0, .02539206530926206D0,
     *            .01627439473090567D0, .00701861000947009D0/
C
C=======================================================================
C POINTS AND WEIGHTS FOR 64-POINT GAUSS-LEGENDRE QUADRATURES
C=======================================================================
C
      DATA XG64
     *
     *          / .02435029266342443D0, .07299312178779904D0,
     *            .12146281929612055D0, .16964442042399282D0,
     *            .21742364374000708D0, .26468716220876742D0,
     *            .31132287199021096D0, .35722015833766812D0,
     *            .40227015796399160D0, .44636601725346409D0,
     *            .48940314570705296D0, .53127946401989455D0,
     *            .57189564620263404D0, .61115535517239325D0,
     *            .64896547125465734D0, .68523631305423324D0,
     *            .71988185017161083D0, .75281990726053190D0,
     *            .78397235894334141D0, .81326531512279756D0,
     *            .84062929625258036D0, .86599939815409282D0,
     *            .88931544599511411D0, .91052213707850281D0,
     *            .92956917213193958D0, .94641137485840282D0,
     *            .96100879965205372D0, .97332682778991097D0,
     *            .98333625388462596D0, .99101337147674432D0,
     *            .99634011677195528D0, .99930504173577214D0/
      DATA WT64
     *
     *          / .04869095700913972D0, .04857546744150343D0,
     *            .04834476223480296D0, .04799938859645831D0,
     *            .04754016571483031D0, .04696818281621002D0,
     *            .04628479658131442D0, .04549162792741815D0,
     *            .04459055816375657D0, .04358372452932346D0,
     *            .04247351512365359D0, .04126256324262353D0,
     *            .03995374113272034D0, .03855015317861563D0,
     *            .03705512854024005D0, .03547221325688239D0,
     *            .03380516183714161D0, .03205792835485155D0,
     *            .03023465707240248D0, .02833967261425948D0,
     *            .02637746971505466D0, .02435270256871087D0,
     *            .02227017380838325D0, .02013482315353021D0,
     *            .01795171577569734D0, .01572603047602472D0,
     *            .01346304789671864D0, .01116813946013112D0,
     *            .00884675982636395D0, .00650445796897837D0,
     *            .00414703326056246D0, .00178328072169639D0/
C
C=======================================================================
C THIS ROUTINE CALCULATES THE MASS SURFACE MOMENT AND MULTIPOLE MOMENTS
C OF A SHARP-EDGE UNIFORM-DENSITY BODY WHOSE SURFACE IS DEFINED BY THE
C INPUT SET OF BOHR DEFORMATION PARAMETERS.
C=======================================================================
C
      PI=4.D0*ATAN(1.D0)
C
C=======================================================================
C DEFINING GAUSS POINTS AND WEIGHTS
C=======================================================================
C
      NNX=16
      DO I=1,16
         XPOINT(I)=-XG32(17-I)
         XWEIGH(I)=+WT32(17-I)
         XPOINT(16+I)=XG32(I)
         XWEIGH(16+I)=WT32(I)
      END DO
C
      NNY=32
      DO I=1,32
         YPOINT(I)=-XG64(33-I)
         YWEIGH(I)=+WT64(33-I)
         YPOINT(32+I)=XG64(I)
         YWEIGH(32+I)=WT64(I)
      END DO
C
      AX=PI/2.
      AY=PI
      BX=PI/2.
      BY=PI
C
C=======================================================================
C ZEROING MOMENTS
C=======================================================================
C
      DO LAM=0,NEXBET
         DO MIU=-LAM,LAM
            PARMUL(LAM,MIU)=0.
         END DO
      END DO
      PARSUR=0
C
C=======================================================================
C INTEGRATING MOMENTS
C=======================================================================
C
      DO IX=1,2*NNX
C
         THE=AX+XPOINT(IX)*BX
C
         COSTHE=COS(THE)
         SINTHE=SIN(THE)
C
C=======================================================================
C STORING POWERS OF SINE OF THETA (WHY FROM -2 ???)
C=======================================================================
C
         SINUS(-2)=0.0D0
         SINUS(-1)=0.0D0
         SINUS( 0)=1.0D0
         SINUS(+1)=SINTHE
         DO I=2,NEXBET
            SINUS(I)=SINUS(I-1)*SINTHE
         END DO
C
C=======================================================================
C CALCULATING POLAR PARTS OF SPHERICAL HARMONICS
C=======================================================================
C
         DO LAM=0,NEXBET
            DO MIU=0,LAM
               HAR(LAM,MIU)=0.
               IF (MOD((LAM-MIU),2).EQ.0) THEN
                   DO IS=MIU,LAM,2
                      HAR(LAM,MIU)=HAR(LAM,MIU)
     *                         +ALMS00(LAM,MIU,IS)*SINUS(IS)
                   END DO
               ELSE
                   DO IS=MIU,LAM-1,2
                      HAR(LAM,MIU)=HAR(LAM,MIU)
     *                         +BLMS00(LAM,MIU,IS)*SINUS(IS)
                   END DO
                   HAR(LAM,MIU)=HAR(LAM,MIU)*COSTHE
               END IF
            END DO
         END DO
C
         DO IY=1,2*NNY
C
            PHI=AY+YPOINT(IY)*BY
C
C=======================================================================
C CALCULATING RADIUS
C=======================================================================
C
            RADIUS=0
            DO LAM=1,NEXBET
              RADIUS=RADIUS+EXABET(LAM,0)*HAR(LAM,0)
              DO MIU=1,LAM
                 RADIUS=RADIUS
     *                  +2.*(EXABET(LAM, MIU)*HAR(LAM,MIU)*COS(MIU*PHI)
     *            +(-1)**MIU*EXABET(LAM,-MIU)*HAR(LAM,MIU)*SIN(MIU*PHI))
              END DO
            END DO
            RADIUS=EXARAD*(1+RADIUS)
C
C=======================================================================
C SUMMING UP QUADRATURES
C=======================================================================
C
            FACTOR=EXADEN*RADIUS**3*SINTHE*XWEIGH(IX)*YWEIGH(IY)*BX*BY
            PARSUR=PARSUR+FACTOR*RADIUS**2/5.
            DO LAM=0,NEXBET
               PARMUL(LAM,0)=PARMUL(LAM,0)+FACTOR*HAR(LAM,0)/(LAM+3)
               DO MIU=1,LAM
                  PARMUL(LAM, MIU)=PARMUL(LAM, MIU)
     *                        +FACTOR*HAR(LAM, MIU)*COS(MIU*PHI)/(LAM+3)
                  PARMUL(LAM,-MIU)=PARMUL(LAM,-MIU)
     *              +(-1)**MIU*FACTOR*HAR(LAM, MIU)*SIN(MIU*PHI)/(LAM+3)
               END DO
               FACTOR=FACTOR*RADIUS
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE BETPRI(NMOMUL,ISIMPY,NAMBET,NAMREF,NAMEPN,
     *                                BOHDEN,BOHRAD,BOHBET)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          BOHBET(0:NDMULT,-NDMULT:NDMULT)
      CHARACTER
     *          PRIMOM(-NDMULT:NDMULT)*15
      CHARACTER
     *          NAMBET*45,NAMREF*17,NAMEPN*8,PRIMIU*2
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE BOHR DEFORMATION PARAMETERS
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *             1H*,2X,A45,1X,A17,2X,A8,2X,1H*,/,
     *                                1H*,77X,1H*)')
     *          NAMBET,NAMREF,NAMEPN
C
      IF (ISIMPY.NE.1) THEN
C
          WRITE(NFIPRI,'(
     *              1H*,2X,''REAL PART  FOR A NON-NEGATIVE PROJECTION'',
     *                                                        35X,1H*,/,
     *              1H*,2X,''IMAGINARY PART FOR A NEGATIVE PROJECTION'',
     *                                                        35X,1H*,/,
     *                                      1H*,77X,1H*,/,
     *                                           79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(79(1H*))')
C
      END IF
C
C=======================================================================
C
      DO MIU=-NDMULT,NDMULT
         PRIMOM(MIU)='  .............'
      END DO
C
      DO LAMBDA=1,MIN(NMOMUL,NDMULT)
C
         DO MIU=-LAMBDA,LAMBDA
C
            BMOMEN = BOHBET(LAMBDA,MIU)
C
            IF (ISIMPY.EQ.1) THEN
                IF (MIU.LT.0)       PRIMIU='  '
                IF (MIU.GE.0) WRITE(PRIMIU,'(I1,1X)') MIU
            ELSE
                WRITE(PRIMIU,'(I2)') MIU
                IF (PRIMIU(1:2).EQ.' 0') PRIMIU(1:2)='0 '
                IF (PRIMIU(1:1).EQ.' ' ) PRIMIU(1:1)='+'
            END IF
C
            IF (ABS(BMOMEN).LT.1.0E-10) THEN
C
                WRITE(PRIMOM(MIU),'(''  B'',I1,A2,''='',4X,''ZERO'')')
     *                                                   LAMBDA,PRIMIU
            ELSE
C
               IF (ABS(BMOMEN).LT.1.0E-3) THEN
C
                   WRITE(PRIMOM(MIU),'(''  B'',I1,A2,''='',1PE8.1)')
     *                                          LAMBDA,PRIMIU,BMOMEN
               ELSE
C
                   WRITE(PRIMOM(MIU),'(''  B'',I1,A2,''='',F8.4)')
     *                                        LAMBDA,PRIMIU,BMOMEN
               END IF
C
            END IF
C
         END DO
C
C=======================================================================
C
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=0,4)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,     15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-1,-4,-1)
C
C=======================================================================
C
         IF (LAMBDA.EQ.5) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,60X, A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,5)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         60X, A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-5)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.6) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,45X,2A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,6)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         45X,2A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-6,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.7) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,30X,3A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,7)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         30X,3A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-7,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.8) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,8)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,         15X,4A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-8,-1)
         END IF
C
C=======================================================================
C
         IF (LAMBDA.EQ.9) THEN
         WRITE(NFIPRI,'(1H*,77X,1H*,/,1H*,    5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=5,9)
         IF (ISIMPY.NE.1)
     *   WRITE(NFIPRI,'(1H*,             5A15,2X,1H*)')
     *                                        (PRIMOM(MIU),MIU=-5,-9,-1)
         END IF
C
      END DO
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*))')
C
      WRITE(NFIPRI,'(                                  1H*,77X,1H*,/,
     *          1H*,2X,''BOHR DENSITY = '',F6.4,'' FM^(-3)'',2X,
     *                 ''BOHR RADIUS = '', F8.4,'' FM'',   19X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *          BOHDEN,BOHRAD
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RADPRI(NAMEPN,RMSPOS,RADPOS,NRAORD)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDMORD=3)
C=======================================================================
      DIMENSION
     *          RMSPOS(0:NDKART)
      DIMENSION
     *          RADPOS(1:NDMORD)
C
      CHARACTER
     *          LINE*79
      CHARACTER
     *          NAMEPN*8
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE ROOT MEAN SQUARE POSITIONS, RADII AND
C       SIZES AS WELL AS THE EVEN POWERS OF RADII.
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *                 1H*,2X,''ROOT-MEAN-SQUARE AND GEOMETRIC '',
     *                        ''SIZES IN FERMIS'',19X,A8,2X,1H*,/,
     *                                              1H*,77X,1H*,/,
     *                 1H*,2X,''R_RMS ='',F8.4,3X,
     *                     2X,''X_RMS ='',F8.4,2X,
     *                     2X,''Y_RMS ='',F8.4,2X,
     *                     2X,''Z_RMS ='',F8.4,2X,      1H*,/,
     *                                              1H*,77X,1H*,/,
     *                 1H*,2X,''R_GEO ='',F8.4,3X,
     *                     2X,''X_GEO ='',F8.4,2X,
     *                     2X,''Y_GEO ='',F8.4,2X,
     *                     2X,''Z_GEO ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *           NAMEPN,(RMSPOS(KARTEZ),            KARTEZ=0,NDKART),
     *                   RMSPOS(0     )*SQRT(5.0D0/3.0D0),
     *                  (RMSPOS(KARTEZ)*SQRT(5.0D0),KARTEZ=1,NDKART)
C
      IF (NRAORD.GT.0) THEN
C
          WRITE (LINE,'(1H*,77X,1H*)')
C
          IF (NRAORD.GE.1)
     *        WRITE (LINE(02:24),'(''  RADIUS**2 ='',F10.6)') RADPOS(1)
          IF (NRAORD.GE.2)
     *        WRITE (LINE(25:49),'('', RADIUS**4 ='',F12.6)') RADPOS(2)
          IF (NRAORD.GE.3)
     *        WRITE (LINE(50:76),'('', RADIUS**6 ='',F14.6)') RADPOS(3)
C
          WRITE(NFIPRI,'(A79,/,1H*,77X,1H*,/,79(1H*),/)') LINE
C
      ELSE
C
          WRITE(NFIPRI,'(79(1H*),/)')
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CMSPRI(NAMEPN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN*8
C
      COMMON
     *       /SHIFTR/ RSHIFT(1:NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE CENTER-OF-MASS COORDINATES
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''CENTER-OF-MASS COORDINATES IN '',
     *                        ''FERMIS'',29X,A8,2X,1H*,/,
     *                                              1H*,77X,1H*,/,
     *                 1H*,2X,''R_CMS ='',F8.4,3X,
     *                     2X,''X_CMS ='',F8.4,2X,
     *                     2X,''Y_CMS ='',F8.4,2X,
     *                     2X,''Z_CMS ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*,/,
     *                                               79(1H*),/)')
     *
     *           NAMEPN,
     *           SQRT(RSHIFT(1)**2+RSHIFT(2)**2+RSHIFT(3)**2),
     *           (RSHIFT(KARTEZ),KARTEZ=1,NDKART)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE EULPRI(NAMEPN)
C
      CHARACTER
     *          NAMEPN*8
C
      COMMON
     *       /EANGLE/ ALPEUL,BETEUL,GAMEUL
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C     THIS ROUTINE PRINTS THE EULER ANGLES OF THE PRINCIPAL-AXES-FRAME
C=======================================================================
C
      DEGRAD=45/ATAN(1.0D0)
C
      WRITE(NFIPRI,'(79(1H*),/,
     *          1H*,77X,1H*,/,
     *          1H*,2X,''EULER ANGLES OF THE PRINCIPAL-AXES FRAME '',
     *                 ''IN DEGREES'',14X,A8,2X,1H*,/,
     *          1H*,77X,1H*,/,
     *          1H*,2X,''ALPHA ='',F9.5,2X,
     *                 ''BETA ='', F9.5,2X,
     *                 ''GAMMA ='',F9.5,24X,1H*,/,
     *          1H*,77X,1H*,/,
     *          79(1H*),/)')
     *
     *     NAMEPN,ALPEUL*DEGRAD,BETEUL*DEGRAD,GAMEUL*DEGRAD
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LINPRI(NAMEPN,COR_CM,ALINLI,TLINSQ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN*8
C
      LOGICAL
     *          COR_CM
C
      DIMENSION
     *          ALINLI(0:NDKART)
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE LINEAR MOMENTA AND THE LINEAR
C       MOMENTUM SQUARED
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''LINEAR MOMENTA IN FERMI^(-1)'',
     *                                   37X,A8,2X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' P_X  ='',F8.4,2X,
     *                     2X,'' P_Y  ='',F8.4,2X,
     *                     2X,'' P_Z  ='',F8.4,3X,
     *                     2X,''P_R   ='',F8.4,2X,      1H*)')
     *
     *           NAMEPN,
     *           (ALINLI(KARTEZ),KARTEZ=1,NDKART),SQRT(ALINLI(0))
C
      IF (COR_CM)
     *
     *    WRITE(NFIPRI,'(                       1H*,77X,1H*,/,
     *                 1H*,2X,''AVERAGE LINEAR MOMENTUM SQUARED '',
     *                        ''IN FERMI^(-2)                   ='',
     *                     F8.4,2X,                     1H*)')
     *
     *            TLINSQ
C
      WRITE(NFIPRI,'(                           1H*,77X,1H*,/,
     *                                               79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ROTPRI(NAMEPN,CORROT,AROTLI,TROTSQ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN*8
C
      LOGICAL
     *          CORROT
C
      DIMENSION
     *          AROTLI(0:NDKART),TROTSQ(0:NDKART)
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE ANGULAR MOMENTA AND THE ANGULAR
C       MOMENTUM SQUARED
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''AVERAGE ANGULAR MOMENTA'',
     *                                   42X,A8,2X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' JX   ='',F8.4,2X,
     *                     2X,'' JY   ='',F8.4,2X,
     *                     2X,'' JZ   ='',F8.4,3X,
     *                     2X,''  J   ='',F8.4,2X,      1H*)')
     *
     *           NAMEPN,
     *           (AROTLI(KARTEZ),KARTEZ=1,NDKART),SQRT(AROTLI(0))
C
      IF (CORROT)
     *
     *    WRITE(NFIPRI,'(                       1H*,77X,1H*,/,
     *                 1H*,2X,'' JX^2 ='',F8.4,2X,
     *                     2X,'' JY^2 ='',F8.4,2X,
     *                     2X,'' JZ^2 ='',F8.4,3X,
     *                     2X,''  J^2 ='',F8.4,2X,      1H*)')
     *
     *           (TROTSQ(KARTEZ),KARTEZ=1,NDKART),TROTSQ(0)
C
      WRITE(NFIPRI,'(                           1H*,77X,1H*,/,
     *                                               79(1H*),/)')
     *
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ISOPRI
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /ISOTOT/ TOTISO(0:NDKART),TOTIS2(0:NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE AVERAGE ISOSPINS AND ISOSPINS SQUARED
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,2X,''AVERAGE ISOSPINS       '',
     *                                              52X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' TX   ='',F10.6,
     *                     2X,'' TY   ='',F10.6,
     *                     2X,'' TZ   ='',F10.6,1X,
     *                        ''  T   ='',F10.6,2X,      1H*)')
     *
     *           (TOTISO(KARTEZ),KARTEZ=1,NDKART),SQRT(TOTISO(0))
C
      WRITE(NFIPRI,'(                           1H*,77X,1H*,/,
     *                 1H*,2X,'' TX^2 ='',F10.6,
     *                     2X,'' TY^2 ='',F10.6,
     *                     2X,'' TZ^2 ='',F10.6,1X,
     *                        ''  T^2 ='',F10.6,2X,      1H*)')
     *
     *           (TOTIS2(KARTEZ),KARTEZ=1,NDKART),TOTIS2(0)
C
      WRITE(NFIPRI,'(                           1H*,77X,1H*,/,
     *                                               79(1H*),/)')
     *
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE REMPRI(NAMEPN,TRAMAS,IDOGOA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN*8
C
      COMMON
     *       /RENORM/ HBMREN(NDKART)
      COMMON
     *       /RENGOA/ GOAREN(NDKART),GOAREI(NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE RENORMALIZED TRANSLATIONAL MASSES
C=======================================================================
C
      IF (IDOGOA.EQ.0)THEN
C=======================================================================
C        PRINT THE MASS CALCULATED BY LIPKIN METHOD
C=======================================================================
          HBMTOT=SQRT((HBMREN(1)**2+HBMREN(2)**2+HBMREN(3)**2)/3)
          TRATOT=TRAMAS*SQRT(((-HBMREN(1))**(-2)
     *                       +(-HBMREN(2))**(-2)
     *                       +(-HBMREN(3))**(-2))/3)
C
          WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,1X,'' RENORMALIZED MASSES IN MEV*FERMI^2'',
     *                        '' AND RATIOS W.R. TO M*A'',
     *                                         8X,A8,2X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' M_X  ='',F10.6,
     *                     2X,'' M_Y  ='',F10.6,
     *                     2X,'' M_Z  ='',F10.6,1X,
     *                     2X,''M_R   ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' F_X  ='',F10.6,
     *                     2X,'' F_Y  ='',F10.6,
     *                     2X,'' F_Z  ='',F10.6,1X,
     *                     2X,''F_R   ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *           NAMEPN,
     *           (-HBMREN(KARTEZ)         ,KARTEZ=1,NDKART),HBMTOT,
     *           (TRAMAS/(-HBMREN(KARTEZ)),KARTEZ=1,NDKART),TRATOT
C
      ELSE
C
C=======================================================================
C        PRINT THE MASS CALCULATED BY GOA
C=======================================================================
          HBMTOT=SQRT((GOAREN(1)**2+GOAREN(2)**2+GOAREN(3)**2)/3)
          TRATOT=TRAMAS*SQRT(((-GOAREN(1))**(-2)
     *                       +(-GOAREN(2))**(-2)
     *                       +(-GOAREN(3))**(-2))/3)
C
          WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,1X,'' GAUSSIAN-OVERLAP MASSES'',
     *                        '' IN MEV*FERMI^2 AND RATIOS'',
     *                        '' W.R. TO M*A'',4X,A8,2X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' M_X  ='',F10.6,
     *                     2X,'' M_Y  ='',F10.6,
     *                     2X,'' M_Z  ='',F10.6,1X,
     *                     2X,''M_R   ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' F_X  ='',F10.6,
     *                     2X,'' F_Y  ='',F10.6,
     *                     2X,'' F_Z  ='',F10.6,1X,
     *                     2X,''F_R   ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *           NAMEPN,
     *           (-GOAREN(KARTEZ)         ,KARTEZ=1,NDKART),HBMTOT,
     *           (TRAMAS/(-GOAREN(KARTEZ)),KARTEZ=1,NDKART),TRATOT
C
C=======================================================================
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE REIPRI(NAMEPN,IDOGOA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN*8
C
      COMMON
     *       /RENROT/ ROTREN(NDKART)
      COMMON
     *       /RENGOA/ GOAREN(NDKART),GOAREI(NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C       THIS SUBROUTINE PRINTS THE RENORMALIZED TRANSLATIONAL INERTS
C=======================================================================
C
      IF (IDOGOA.EQ.0) THEN
C
C=======================================================================
C        PRINT THE MOI CALCULATED BY LIPKIN METHOD
C=======================================================================
C
         HBMTOT=SQRT((ROTREN(1)**2+ROTREN(2)**2+ROTREN(3)**2)/3)
         WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,1X,'' RENORMALIZED INERTS IN MEV*FERMI^2'',
     *                        '' AND LIPKIN PARAMETER'',
     *                                         8X,A8,4X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' I_X  ='',F10.6,
     *                     2X,'' I_Y  ='',F10.6,
     *                     2X,'' I_Z  ='',F10.6,1X,
     *                     2X,''I_R   ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' k_X  ='',F10.6,
     *                     2X,'' k_Y  ='',F10.6,
     *                     2X,'' k_Z  ='',F10.6,1X,
     *                     2X,''k_R   ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *           NAMEPN,
     * (-1/(2.0d0*ROTREN(KARTEZ)),KARTEZ=1,NDKART),-1/(2.0d0*HBMTOT),
     *          (-ROTREN(KARTEZ) ,KARTEZ=1,NDKART),          HBMTOT
C
      ELSE
C
C=======================================================================
C        PRINT THE MOI CALCULATED BY GOA
C=======================================================================
C
         HBMTOT=SQRT((GOAREI(1)**2+GOAREI(2)**2+GOAREI(3)**2)/3)
         WRITE(NFIPRI,'(79(1H*),/,                 1H*,77X,1H*,/,
     *                 1H*,1X,'' GAUSSIAN-OVERLAP INERTS'',
     *                        '' IN MEV*FERMI^2 AND LIPKIN'',
     *                        '' PARAMETER'',4X,A8,4X,1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' I_X  ='',F10.6,
     *                     2X,'' I_Y  ='',F10.6,
     *                     2X,'' I_Z  ='',F10.6,1X,
     *                     2X,''I_R   ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*,/,
     *                 1H*,2X,'' k_X  ='',F10.6,
     *                     2X,'' k_Y  ='',F10.6,
     *                     2X,'' k_Z  ='',F10.6,1X,
     *                     2X,''F_R   ='',F8.4,2X,      1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *           NAMEPN,
     * (-1/(2.0d0*GOAREI(KARTEZ)),KARTEZ=1,NDKART),-1/(2.0d0*HBMTOT),
     *          (-GOAREI(KARTEZ) ,KARTEZ=1,NDKART),          HBMTOT
C
C=======================================================================
C
      END IF
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C=======================================================================
C
      SUBROUTINE RESPRI(IWRIRE,IWRIYU,IWRIFI,IWRIGO,IWRIRO,IWRILI,
     *                  IWRIBA,I_YUKA,JETACM,KETA_R,LIPKIN,LIPKIP,
     *                                I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                                              ICOUDI,ICOUEX)
C=======================================================================
      PARAMETER (NDFSTA=3)
C=======================================================================
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C      THIS ROUTINE PRINTS OUT INFORMATION ON THE VARIOUS FILES THAT
C      ARE READ/WRITTEN IN THIS RUN
C=======================================================================
C
      IF (IWRIRE.NE.1) THEN
C
          IF (IWRIRE.NE.-1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE RECORD FILE WILL BE SAVED ONLY'',
     *                  '' AFTER THE LAST ITERATION IS COMPLETED'',
     *                                                      3X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE RECORD FILE WILL NOT BE SAVED;'',
     *                  '' AND THIS RUN CANNOT BE LATER CONTINUED''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
         END IF
C
      END IF
C
C=======================================================================
C
      IF (IWRIYU.NE.1.AND.I_YUKA.GE.2) THEN
C
          IF (IWRIYU.NE.-1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE YUKAWA FILE WILL BE SAVED ONLY'',
     *                  '' AFTER THE LAST ITERATION IS COMPLETED'',
     *                                                      3X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
          ELSE
C
              IF (IWRIFI.EQ.-1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE YUKAWA FILE WILL NOT BE SAVED'',
     *                  '' AND THE YUKAWA CALC CANNOT BE CONTINUED''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
              ELSE
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE YUKAWA FILE WILL NOT BE SAVED'',
     *                  '', BUT YUKAWA CALC CAN BE CONTD FROM FLDS''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IWRIRO.NE.1.AND.I_REGA.GE.2) THEN
C
          IF (IWRIRO.NE.-1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE REGUL. FILE WILL BE SAVED ONLY'',
     *                  '' AFTER THE LAST ITERATION IS COMPLETED '',
     *                                                      2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
          ELSE
C
              IF (IWRIFI.EQ.-1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE REGUL. FILE WILL NOT BE SAVED'',
     *                  '' AND THE REGUL. CALC CANNOT BE CONTINUED''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
              ELSE
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE REGUL FILE WILL NOT BE SAVED'',
     *                  '', BUT REGUL CALC CAN BE CONTD FROM FIELDS''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IWRIFI.EQ.-1.AND.JETACM.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *      1H*,''  THE FIELDS FILE WILL NOT BE SAVED'',
     *          '' AND THE CM CORRECT. CANNOT BE CONTINUED''
     *                                             ,2X,1H*,/,
     *      1H*,                          77X,1H*,/,79(1H*),/)')
C
      END IF
C
C=======================================================================
C
      IF (IWRIFI.EQ.-1.AND.KETA_R.EQ.2) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *      1H*,''  THE FIELDS FILE WILL NOT BE SAVED'',
     *          '' AND THE ROTL CORRCT CANNOT BE CONTINUED''
     *                                             ,2X,1H*,/,
     *      1H*,                          77X,1H*,/,79(1H*),/)')
C
      END IF
C
C=======================================================================
C
      IF (LIPKIN.EQ.1.OR.LIPKIP.EQ.1) THEN
C
          IF (IWRILI.EQ.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE LIPKIN FILE WILL BE SAVED ONLY'',
     *                  '' AFTER THE LAST ITERATION IS COMPLETED'',
     *                                                      3X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
          END IF
C
          IF (IWRILI.EQ.-1) THEN
C
              IF (IWRIFI.EQ.-1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE LIPKIN FILE WILL NOT BE SAVED,'',
     *                  '' THUS LIPKIN METHOD CANNOT BE CONTINUED''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
              ELSE
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE LIPKIN FILE WILL NOT BE SAVED,'',
     *                  '' BUT LIPKIN CALC CAN BE CONTD FROM FLDS''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
              END IF
C
          END IF
C
          IF (IWRILI.EQ.1) THEN
C
              IF (IWRIFI.NE.-1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  SAVING OF LIPKIN FILE IS CANCELLED,'',
     *                  '' AS LIPKIN CALC CAN BE CONTD FROM FLDS''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IWRIFI.NE.1) THEN
C
          IF (IWRIFI.NE.-1) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE FIELDS FILE WILL BE SAVED ONLY'',
     *                  '' AFTER THE LAST ITERATION IS COMPLETED'',
     *                                                      3X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
          ELSE
C
             IF (ICOUDI.EQ.2.OR.ICOUEX.EQ.2)
     *
     *            WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE FIELDS FILE WILL NOT BE SAVED,'',
     *                  '' THUS EXACT COULOMB CANNOT BE CONTINUED''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
             IF (I_GOGA.GE.2.OR.IGOGPA.GE.2)
     *
     *            WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE FIELDS FILE WILL NOT BE SAVED,'',
     *                  '' THUS GOGNY RESULTS CANNOT BE CONTINUED''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
             IF (I_REGA.GE.2.OR.IREGPA.EQ.2)
     *
     *            WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE FIELDS FILE WILL NOT BE SAVED,'',
     *                  '' THUS REGUL RESULTS CANNOT BE CONTINUED''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
             IF (MAXVAL(I_FSTA).GE.2.OR.MAXVAL(IFSTPA).EQ.2)
     *
     *            WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE FIELDS FILE WILL NOT BE SAVED,'',
     *                  '' FR SO/TENS RESULTS CANNOT BE CONTINUED''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IWRIBA.NE.-1) THEN
C
          IF (IWRIBA.EQ.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE BASIS FILE WILL BE SAVED ONLY'',
     *                  '' AFTER THE LAST ITERATION IS COMPLETED'',
     *                                                      4X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
          ELSE
C
              WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *              1H*,''  THE BASIS FILE WILL BE SAVED AFTER'',
     *                  '' EACH ITERATION IS COMPLETED           ''
     *                                                     ,2X,1H*,/,
     *              1H*,                          77X,1H*,/,79(1H*),/)')
C
         END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ANGPRI(IMOVAX,ISIMPY,ISHIFT,INTRIP)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          ANGLEC*8
C
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /ANGSPI/ SPIN_N(1:NDKART),SPIN_P(1:NDKART),SPIN_T(1:NDKART)
      COMMON
     *       /SHIANG/ ANGS_N(1:NDKART),ANGS_P(1:NDKART),ANGS_T(1:NDKART)
      COMMON
     *       /ROTANG/ ANGR_N(1:NDKART),ANGR_P(1:NDKART),ANGR_T(1:NDKART)
      COMMON
     *       /ROTSPI/ SPIR_N(1:NDKART),SPIR_P(1:NDKART),SPIR_T(1:NDKART)
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE AVERAGE VALUES OF ANGULAR MOMENTA
C=======================================================================
C
      IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C         CASE OF CONSERVED Y-SIMPLEX
C=======================================================================
C
          WRITE(NFIPRI,'(79(1H*),/,                1H*,77X,1H*,/,
     *                 1H*,2X,''ANGULAR MOMENTA AND THE FIRST '',
     *                        ''MOMENTS OF INERTIA'',  27X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/,
     *                                             1H*,77X,1H*,/,
     *                 1H*,1X,13X,2X,10X,''  SPINS   '',10X,
     *                            2X,10X,''   J(1)   '',7X,
     *                                                  2X,1H*,/,
     *                 1H*,1X,13X,2X,''---------------------------   '',
     *                            2X,''---------------------------'',
     *                                                  2X,1H*,/,
     *                 1H*,1X,13X,2X,''ORBITAL   INTRINSIC   TOTAL   '',
     *                            2X,''ORBITAL   INTRINSIC   TOTAL'',
     *                                                  2X,1H*,/,
     *                                             1H*,77X,1H*)')
C
          OMEGAN=OMOVAY+OMISOY
          OMEGAP=OMOVAY-OMISOY
C
          IF (ABS(OMEGAN).GT.1.0D-06.AND.
     *        ABS(OMEGAP).GT.1.0D-06.AND.
     *        ABS(OMOVAY).GT.1.0D-06) THEN
C
              WRITE(NFIPRI,'(1H*,1X,'' NEUTRONS '',2(2X,3F10.5),
     *                                                       2X,1H*,/,
     *                       1H*,1X,''  PROTONS '',2(2X,3F10.5),
     *                                                       2X,1H*,/,
     *                       1H*,1X,'' -------- '',         66X,1H*,/,
     *                       1H*,1X,''    TOTAL '',2(2X,3F10.5),
     *                                                       2X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *
     *                ANGU_N(2)-SPIN_N(2),SPIN_N(2),ANGU_N(2),
     *               (ANGU_N(2)-SPIN_N(2))/OMEGAN,
     *                SPIN_N(2)/OMEGAN,ANGU_N(2)/OMEGAN,
     *
     *                ANGU_P(2)-SPIN_P(2),SPIN_P(2),ANGU_P(2),
     *               (ANGU_P(2)-SPIN_P(2))/OMEGAP,
     *                SPIN_P(2)/OMEGAP,ANGU_P(2)/OMEGAP,
     *
     *                ANGU_T(2)-SPIN_T(2),SPIN_T(2),ANGU_T(2),
     *               (ANGU_T(2)-SPIN_T(2))/OMOVAY,
     *                SPIN_T(2)/OMOVAY,ANGU_T(2)/OMOVAY
C
          ELSE
C
              WRITE(NFIPRI,'(1H*,1X,'' NEUTRONS '', (2X,3F10.5),
     *                                                      34X,1H*,/,
     *                       1H*,1X,''  PROTONS '', (2X,3F10.5),
     *                                                      34X,1H*,/,
     *                       1H*,1X,'' -------- '',         66X,1H*,/,
     *                       1H*,1X,''    TOTAL '', (2X,3F10.5),
     *                                                      34X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *
     *                ANGU_N(2)-SPIN_N(2),SPIN_N(2),ANGU_N(2),
     *                ANGU_P(2)-SPIN_P(2),SPIN_P(2),ANGU_P(2),
     *                ANGU_T(2)-SPIN_T(2),SPIN_T(2),ANGU_T(2)
C
          END IF
C
          IF (ISHIFT.NE.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,            1H*,77X,1H*,/,
     *                 1H*,2X,''ANGULAR MOMENTA IN THE CENTER-'',
     *                        ''OF-MASS REFERENCE FRAME'',
     *                                                 22X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/,
     *                                             1H*,77X,1H*,/,
     *                 1H*,1X,13X,2X,10X,''  SPINS   '',10X,
     *                            2X,10X,''   J(1)   '',7X,
     *                                                  2X,1H*,/,
     *                 1H*,1X,13X,2X,''---------------------------   '',
     *                            2X,''---------------------------'',
     *                                                  2X,1H*,/,
     *                 1H*,1X,13X,2X,''ORBITAL   INTRINSIC   TOTAL   '',
     *                            2X,''ORBITAL   INTRINSIC   TOTAL'',
     *                                                  2X,1H*,/,
     *                                             1H*,77X,1H*)')
C
              IF (ABS(OMEGAN).GT.1.0D-06.AND.
     *            ABS(OMEGAP).GT.1.0D-06.AND.
     *            ABS(OMOVAY).GT.1.0D-06) THEN
C
                  WRITE(NFIPRI,'(
     *                  1H*,1X,'' NEUTRONS '',2(2X,3F10.5),
     *                                                  2X,1H*,/,
     *                  1H*,1X,''  PROTONS '',2(2X,3F10.5),
     *                                                  2X,1H*,/,
     *                  1H*,1X,'' -------- '',          66X,1H*,/,
     *                  1H*,1X,''    TOTAL '',2(2X,3F10.5),
     *                                                  2X,1H*,/,
     *                                            1H*,77X,1H*)')
     *
     *                ANGS_N(2)-SPIN_N(2),SPIN_N(2),ANGS_N(2),
     *               (ANGS_N(2)-SPIN_N(2))/OMEGAN,
     *                SPIN_N(2)/OMEGAN,ANGS_N(2)/OMEGAN,
     *
     *                ANGS_P(2)-SPIN_P(2),SPIN_P(2),ANGS_P(2),
     *               (ANGS_P(2)-SPIN_P(2))/OMEGAP,
     *                SPIN_P(2)/OMEGAP,ANGS_P(2)/OMEGAP,
     *
     *                ANGS_T(2)-SPIN_T(2),SPIN_T(2),ANGS_T(2),
     *               (ANGS_T(2)-SPIN_T(2))/OMOVAY,
     *                SPIN_T(2)/OMOVAY,ANGS_T(2)/OMOVAY
C
              ELSE
C
                  WRITE(NFIPRI,'(
     *                  1H*,1X,'' NEUTRONS '', (2X,3F10.5),
     *                                                 34X,1H*,/,
     *                  1H*,1X,''  PROTONS '', (2X,3F10.5),
     *                                                 34X,1H*,/,
     *                  1H*,1X,'' -------- '',          66X,1H*,/,
     *                  1H*,1X,''    TOTAL '', (2X,3F10.5),
     *                                                 34X,1H*,/,
     *                                            1H*,77X,1H*)')
     *
     *                ANGS_N(2)-SPIN_N(2),SPIN_N(2),ANGS_N(2),
     *                ANGS_P(2)-SPIN_P(2),SPIN_P(2),ANGS_P(2),
     *                ANGS_T(2)-SPIN_T(2),SPIN_T(2),ANGS_T(2)
C
              END IF
C
          END IF
C
      ELSE
C
C=======================================================================
C         CASE OF NON-CONSERVED Y-SIMPLEX
C=======================================================================
C
          WRITE(NFIPRI,'(79(1H*),/,                1H*,77X,1H*,/,
     *                 1H*,2X,''ANGULAR MOMENTA IN THE THREE C'',
     *                        ''ARTESIAN DIRECTIONS'', 26X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/,
     *                                             1H*,77X,1H*,/,
     *                 1H*,12X,''SPIN IN X-DIRECTION'', 2X,
     *                      1X,''SPIN IN Y-DIRECTION'', 2X,
     *                      1X,''SPIN IN Z-DIRECTION'', 2X,1H*,/,
     *                 1H*,12X,''-------------------'', 2X,
     *                      1X,''-------------------'', 2X,
     *                      1X,''-------------------'', 2X,1H*,/,
     *                 1H*,12X,''INTRI  ORBIT  TOTAL'', 2X,
     *                      1X,''INTRI  ORBIT  TOTAL'', 2X,
     *                      1X,''INTRI  ORBIT  TOTAL'', 2X,1H*,/,
     *                                             1H*,77X,1H*)')
C
          WRITE(NFIPRI,'(1H*, 1X,'' NEUTRONS'',3(3F7.3,1X),
     *                                                    1X,1H*,/,
     *                   1H*, 1X,''  PROTONS'',3(3F7.3,1X),
     *                                                    1X,1H*,/,
     *                   1H*, 1X,'' --------'',          67X,1H*,/,
     *                   1H*, 1X,''    TOTAL'',3(3F7.3,1X),
     *                                                    1X,1H*,/,
     *                                               1H*,77X,1H*)')
     *
     *             (SPIN_N(L),ANGU_N(L)-SPIN_N(L),ANGU_N(L),L=1,NDKART),
     *             (SPIN_P(L),ANGU_P(L)-SPIN_P(L),ANGU_P(L),L=1,NDKART),
     *             (SPIN_T(L),ANGU_T(L)-SPIN_T(L),ANGU_T(L),L=1,NDKART)
C
C=======================================================================
C
          IF (IMOVAX.NE.0)
     *        WRITE(NFIPRI,'(79(1H*),/,
     *                  1H*,77X,1H*,/,
     *                  1H*,2X,''ROTATIONAL FREQUENCIES IN THE THREE '',
     *                         ''CARTESIAN DIRECTIONS:'', 18X,1H*,/,
     *                  1H*,77X,1H*,/
     *                  1H*,2X,''OMEGAX ='',F9.6,2X,''OMEGAY ='',F9.6,
     *                         2X,''OMEGAZ ='',F9.6,2X,
     *                         ''OMEGA ='',F9.6,
     *                         2X,1H*,/,
     *                  1H*,77X,1H*)')
     *
     *        OMOVAX,OMOVAY,OMOVAZ,
     *        SQRT(OMOVAX**2+OMOVAY**2+OMOVAZ**2)
C
C=======================================================================
C
          OMETOT=OMOVAX   **2+OMOVAY   **2+OMOVAZ   **2
          ANGTOT=ANGU_T(1)**2+ANGU_T(2)**2+ANGU_T(3)**2
          ANGLET=0.0
C
          IF (OMETOT.GT.0.0.AND.ANGTOT.GT.0.0) THEN
C
              SINANG=1-( OMOVAX*ANGU_T(1)
     *                  +OMOVAY*ANGU_T(2)
     *                  +OMOVAZ*ANGU_T(3))**2/OMETOT/ANGTOT
C
              IF (ABS(SINANG).LE.1.0D0)
     *
     *            ANGLET=ASIN(SINANG)*45.0D0/ATAN(1.0D0)
C
          END IF
C
          OMETOT=SQRT(OMETOT)
          ANGTOT=SQRT(ANGTOT)
C
C=======================================================================
C
          IF (ABS(ANGLET).GE.1E-2.OR.ANGLET.EQ.0.0) THEN
C
              WRITE(ANGLEC,'(F8.3)')     ANGLET
          ELSE
              WRITE(ANGLEC,'((1PE8.1))') ANGLET
C
          END IF
C
          WRITE(NFIPRI,'(79(1H*),/,                1H*,77X,1H*,/,
     *                 1H*,2X,''ANGLE BETWEEN ANGULAR MOMENTUM '',
     *                        ''AND ANGULAR FREQUENCY VECTORS='',
     *                                      A8,'' DEG'',2X,1H*,/,
     *                                             1H*,77X,1H*)')
     *        ANGLEC
C
C=======================================================================
C
          IF (ISHIFT.NE.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,            1H*,77X,1H*,/,
     *                 1H*,2X,''ANGULAR MOMENTA IN THE CENTER-'',
     *                        ''OF-MASS REFERENCE FRAME'',
     *                                                 22X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/,
     *                                             1H*,77X,1H*,/,
     *                 1H*,12X,''SPIN IN X-DIRECTION'', 2X,
     *                      1X,''SPIN IN Y-DIRECTION'', 2X,
     *                      1X,''SPIN IN Z-DIRECTION'', 2X,1H*,/,
     *                 1H*,12X,''-------------------'', 2X,
     *                      1X,''-------------------'', 2X,
     *                      1X,''-------------------'', 2X,1H*,/,
     *                 1H*,12X,''INTRI  ORBIT  TOTAL'', 2X,
     *                      1X,''INTRI  ORBIT  TOTAL'', 2X,
     *                      1X,''INTRI  ORBIT  TOTAL'', 2X,1H*,/,
     *                                             1H*,77X,1H*)')
C
              WRITE(NFIPRI,'(1H*, 1X,'' NEUTRONS'',3(3F7.3,1X),
     *                                                        1X,1H*,/,
     *                       1H*, 1X,''  PROTONS'',3(3F7.3,1X),
     *                                                        1X,1H*,/,
     *                       1H*, 1X,'' --------'',          67X,1H*,/,
     *                       1H*, 1X,''    TOTAL'',3(3F7.3,1X),
     *                                                        1X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *             (SPIN_N(L),ANGS_N(L)-SPIN_N(L),ANGS_N(L),L=1,NDKART),
     *             (SPIN_P(L),ANGS_P(L)-SPIN_P(L),ANGS_P(L),L=1,NDKART),
     *             (SPIN_T(L),ANGS_T(L)-SPIN_T(L),ANGS_T(L),L=1,NDKART)
C
          END IF
C
      END IF
C
C=======================================================================
C         HERE WE PRINT THE ANGULAR MOMENTA IN THE INTRINSIC FRAME.
C         IRRESPECTIVE OF WHETHER SIMPLEX IS CONSERVED OR  NOT,  WE
C         ALWAYS PRINT ALL THREE CARTESIAN COMPONENTS, BECAUSE EVEN
C         FOR A CONSERVED SIMPLEX, THE NON-ZERO  Y-COMPONENT  COULD
C         END UP IN THE INTRINSIC FRAME IN ANOTHER DIRECTION.
C=======================================================================
C
      IF (INTRIP.NE.0) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                1H*,77X,1H*,/,
     *                 1H*,2X,''ANGULAR MOMENTA IN THE INTRINS'',
     *                        ''IC REFERENCE FRAME'',
     *                                                 27X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/,
     *                                             1H*,77X,1H*,/,
     *                 1H*,12X,''SPIN IN X-DIRECTION'', 2X,
     *                      1X,''SPIN IN Y-DIRECTION'', 2X,
     *                      1X,''SPIN IN Z-DIRECTION'', 2X,1H*,/,
     *                 1H*,12X,''-------------------'', 2X,
     *                      1X,''-------------------'', 2X,
     *                      1X,''-------------------'', 2X,1H*,/,
     *                 1H*,12X,''INTRI  ORBIT  TOTAL'', 2X,
     *                      1X,''INTRI  ORBIT  TOTAL'', 2X,
     *                      1X,''INTRI  ORBIT  TOTAL'', 2X,1H*,/,
     *                                             1H*,77X,1H*)')
C
          WRITE(NFIPRI,'(1H*, 1X,'' NEUTRONS'',3(3F7.3,1X),
     *                                                    1X,1H*,/,
     *                   1H*, 1X,''  PROTONS'',3(3F7.3,1X),
     *                                                    1X,1H*,/,
     *                   1H*, 1X,'' --------'',          67X,1H*,/,
     *                   1H*, 1X,''    TOTAL'',3(3F7.3,1X),
     *                                                    1X,1H*,/,
     *                                               1H*,77X,1H*)')
     *
     *             (SPIR_N(L),ANGR_N(L)-SPIR_N(L),ANGR_N(L),L=1,NDKART),
     *             (SPIR_P(L),ANGR_P(L)-SPIR_P(L),ANGR_P(L),L=1,NDKART),
     *             (SPIR_T(L),ANGR_T(L)-SPIR_T(L),ANGR_T(L),L=1,NDKART)
C
      END IF
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE IWRPRI(NFIISO)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          Z_AXIS(1:NDKART)
C
      COMMON
     *       /ITERTS/ ITESTA,ITESTO,NOITER,NUMITE
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /EANGLE/ ALPEUL,BETEUL,GAMEUL
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QROTAT/ QROT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QROT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QROT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),
     *                ANGU_P(1:NDKART),
     *                ANGU_T(1:NDKART)
      COMMON
     *       /ANGSPI/ SPIN_N(1:NDKART),
     *                SPIN_P(1:NDKART),
     *                SPIN_T(1:NDKART)
C
      PI=4.0D0*ATAN(1.0D0)
      DEGRAD=180/PI
C
      OMEGA=SQRT(OMOVAX**2+OMOVAY**2+OMOVAZ**2)
C
      Z_AXIS(1)=SIN(BETEUL)*COS(ALPEUL)
      Z_AXIS(2)=SIN(BETEUL)*SIN(ALPEUL)
      Z_AXIS(3)=COS(BETEUL)
C
      ANGTOT=SQRT(ANGU_T(1)**2+ANGU_T(2)**2+ANGU_T(3)**2)
      ANGNEU=SQRT(ANGU_N(1)**2+ANGU_N(2)**2+ANGU_N(3)**2)
      ANGPRO=SQRT(ANGU_P(1)**2+ANGU_P(2)**2+ANGU_P(3)**2)
C
      IF (OMEGA*ANGTOT.NE.0.) THEN
          ANGUWJ=ACOS((OMOVAX*ANGU_T(1)
     *                +OMOVAY*ANGU_T(2)
     *                +OMOVAZ*ANGU_T(3))/(OMEGA*ANGTOT))
      ELSE
          ANGUWJ=0.
      END IF
C
      IF (ANGTOT.NE.0.) THEN
          ANGUZJ=ACOS((Z_AXIS(1)*ANGU_T(1)
     *                +Z_AXIS(2)*ANGU_T(2)
     *                +Z_AXIS(3)*ANGU_T(3))/(1*ANGTOT))
      ELSE
          ANGUZJ=0.
      END IF
C
      IF (ANGNEU*ANGPRO.NE.0.) THEN
          ANGUNP=ACOS((ANGU_N(1)*ANGU_P(1)
     *                +ANGU_N(2)*ANGU_P(2)
     *                +ANGU_N(3)*ANGU_P(3))/(ANGNEU*ANGPRO))
      ELSE
          ANGUNP=0.
      END IF
C
      WRITE(NFIISO,'(1H*,1X,I4,2X,
     *               F4.0,1X,F4.0,1X,F4.0,2X,
     *               F7.3,1X,F7.3,1X,F7.3,2X,
     *               F7.3,1X,F7.3,1X,F7.3,1X,F7.3,1X,F7.3,2X,
     *               F5.1,1X,F5.1,1X,F5.1,2X,
     *               F5.1,1X,F5.1,1X,F5.1,3X,
     *               F4.0,1X,F4.0,1X,F4.0)')
     *
     *      NUMITE,
     *      ALPEUL*DEGRAD,BETEUL*DEGRAD,GAMEUL*DEGRAD,
     *      QMUL_T(1,-1),QMUL_T(1, 0),QMUL_T(1, 1),
     *      QROT_T(2,-2),QROT_T(2,-1),QROT_T(2, 0),
     *                   QROT_T(2, 1),QROT_T(2, 2),
     *      ANGU_T(1),ANGU_T(2),ANGU_T(3),
     *      SPIN_T(1),SPIN_T(2),SPIN_T(3),
     *      ANGUWJ*DEGRAD,
     *      ANGUZJ*DEGRAD,
     *      ANGUNP*DEGRAD
C
      WRITE(NFIISO,'(1H*,23X,
     *               F7.3,1X,F7.3,1X,F7.3,2X,
     *               F7.3,1X,F7.3,1X,F7.3,1X,F7.3,1X,F7.3,2X,
     *               F5.1,1X,F5.1,1X,F5.1,2X,
     *               F5.1,1X,F5.1,1X,F5.1)')
     *
     *      QROT_N(1,-1),QROT_N(1, 0),QROT_N(1, 1),
     *      QROT_N(2,-2),QROT_N(2,-1),QROT_N(2, 0),
     *                   QROT_N(2, 1),QROT_N(2, 2),
     *      ANGU_N(1),ANGU_N(2),ANGU_N(3),
     *      SPIN_N(1),SPIN_N(2),SPIN_N(3)
C
      WRITE(NFIISO,'(1H*,23X,
     *               F7.3,1X,F7.3,1X,F7.3,2X,
     *               F7.3,1X,F7.3,1X,F7.3,1X,F7.3,1X,F7.3,2X,
     *               F5.1,1X,F5.1,1X,F5.1,2X,
     *               F5.1,1X,F5.1,1X,F5.1)')
     *
     *      QROT_P(1,-1),QROT_P(1, 0),QROT_P(1, 1),
     *      QROT_P(2,-2),QROT_P(2,-1),QROT_P(2, 0),
     *                   QROT_P(2, 1),QROT_P(2, 2),
     *      ANGU_P(1),ANGU_P(2),ANGU_P(3),
     *      SPIN_P(1),SPIN_P(2),SPIN_P(3)
C
      WRITE(NFIISO,'(1H*)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTCEN(SONBAS,KARTEZ,ISIMPY,HPPCEN,HPMCEN,
     *                                       ITWCEN,INDCOE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX)
      COMPLEX
     *          HPPCEN(1:NDBASE,1:NDBASE),
     *          HPMCEN(1:NDBASE,1:NDBASE)
      COMPLEX
     *          Y_HELP(0:ND2MAX)
      COMPLEX
     *          X_HELP(0:ND2MAX,0:ND2MAX)
      COMPLEX
     *          Z_HELP(0:NDOSCI,0:NDOSCI)
      COMPLEX
     *          RESULT,C_ZERO
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /COEFH4/ CF4H00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE)
C
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('INTCEN',1)
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS  THE  GAUSS - HERMITE INTEGRATIONS
C        OF THE MATRIX ELEMENTS OF THE CENTRAL TERM IN THE POTENTIAL
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
C        VECTORIZATION COMMENT:
C        PLEASE REFER TO THE COMMENT IN THE "INTCOU" SUBROUTINE
C
C=======================================================================
C
      HPPCEN(:,:)=C_ZERO
      HPMCEN(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
      DO NX=0,NXMAXV(IND4HI(INDCOE))
         DO MX=0,NXMAXV(IND4HJ(INDCOE))
C
            DO KY=0,NYMAXV(IND4HI(INDCOE))+NYMAXV(IND4HJ(INDCOE))
               DO KZ=0,NZMAXV(IND4HI(INDCOE))+NZMAXV(IND4HJ(INDCOE))
C
                  RESULT=C_ZERO
C
                  IF (ITWCEN.EQ.1) THEN
                  DO KX=NX+MX,0,-2
                         RESULT=RESULT+COEF00(KX,MX,NX,1)*
     *                                   SONBAS(KX,KY,KZ)
                  END DO
                  ELSEIF (ITWCEN.EQ.2) THEN
                      DO KX=0,NX+MX
                         RESULT=RESULT+CF4H00(KX,NX,MX,1,INDCOE)*
     *                                          SONBAS(KX,KY,KZ)
                      END DO
                  END IF
C
                  X_HELP(KY,KZ)=RESULT
C
               END DO
            END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
            DO NY=0,LYOFXV(NX,IND4HI(INDCOE))
               DO MY=0,LYOFXV(MX,IND4HJ(INDCOE))
C
                  IF (IPHAPP(NY,MY,KARTEZ).EQ.0.AND.ISIMPY.EQ.1) GO TO 1
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE))+NZMAXV(IND4HJ(INDCOE))
C
                     RESULT=C_ZERO
C
                     IF (ITWCEN.EQ.1) THEN
                     DO KY=NY+MY,0,-2
                            RESULT=RESULT+COEF00(KY,MY,NY,2)*
     *                                         X_HELP(KY,KZ)
                     END DO
                     ELSEIF (ITWCEN.EQ.2) THEN
                         DO KY=0,NY+MY
                            RESULT=RESULT+CF4H00(KY,NY,MY,2,INDCOE)*
     *                                                X_HELP(KY,KZ)
                         END DO
                     END IF
C
                     Y_HELP(KZ)=RESULT
C
                  END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Z DIRECTION
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        RESULT=C_ZERO
C
                        IF (ITWCEN.EQ.1) THEN
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)
#else
                        DO KZ=NZ+MZ,0,-2
#endif
                               RESULT=RESULT+COEF00(KZ,MZ,NZ,3)*
     *                                               Y_HELP(KZ)
                        END DO
C
                        ELSEIF (ITWCEN.EQ.2) THEN
#if(SWITCH_VECT==1)
                            DO KZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))+
     *                              LZOXYV(MX,MY,IND4HJ(INDCOE))
#else
                            DO KZ=0,NZ+MZ
#endif
                               RESULT=RESULT+CF4H00(KZ,NZ,MZ,3,INDCOE)*
     *                                                      Y_HELP(KZ)
                            END DO
C
                        END IF
C
                        Z_HELP(NZ,MZ)=RESULT
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-CONSERVING BLOCK
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        HPPCEN(INDICE(NX,NY,NZ,IND4HI(INDCOE)),
     *                         INDICE(MX,MY,MZ,IND4HJ(INDCOE)))=
     *                            Z_HELP(NZ,MZ)*IPHAPP(NY,MY,KARTEZ)
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-NON-CONSERVING BLOCK
C=======================================================================
C
              IF (ISIMPY.NE.1) THEN
C
               DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
                   DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                    HPMCEN(INDICE(NX,NY,NZ,IND4HI(INDCOE)),
     *                     INDICE(MX,MY,MZ,IND4HJ(INDCOE)))=
     *                           Z_HELP(NZ,MZ)*IPHAPM(NY,MY,KARTEZ)
C
                   END DO
               END DO
C
              END IF
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
    1             CONTINUE
C
               END DO
            END DO
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE Z DIRECTION
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTCEN',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTSOR(VONBAS,KARTEZ,ISIMPY,HPPSOR,HPMSOR,
     *                                       ITWCEN,INDCOE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          VONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX,NDKART)
      COMPLEX
     *          HPPSOR(1:NDBASE,1:NDBASE),
     *          HPMSOR(1:NDBASE,1:NDBASE)
      COMPLEX
     *          X_HELP(0:ND2MAX,0:ND2MAX),
     *          Y_HELP(0:ND2MAX,0:ND2MAX),
     *          Z_HELP(0:ND2MAX,0:ND2MAX)
      COMPLEX
     *          T_HELP(0:NDOSCI,0:NDOSCI)
      COMPLEX
     *          X_AUXI(0:ND2MAX),
     *          Y_AUXI(0:ND2MAX),
     *          Z_AUXI(0:ND2MAX),
     *          T_AUXI(0:ND2MAX)
      COMPLEX
     *          RESULT,C_ZERO
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /COEFH4/ CF4H00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE)
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('INTSOR',1)
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS  THE  GAUSS - HERMITE INTEGRATIONS
C        OF THE MATRIX ELEMENTS OF THE S P I N - O R B I T POTENTIAL
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
C        VECTORIZATION COMMENT:
C        PLEASE REFER TO THE COMMENT IN THE "INTCOU" SUBROUTINE
C
C=======================================================================
C
C=======================================================================
C        TWO-CENTRE BASIS OPTION: FOR ANTISYMMETRISING, WE SUBTRACT THE
C        COEFFICIENT SWAPPING LEFT AND RIGHT QUANTUM NUMBERS. WHEN THE
C        CROSS-TERM IS INVOLVED, THE DIFFERENTIAL OPERATOR WILL ACT ON
C        A WAVE FUNCTIONS RELATED TO A DIFFERENT CENTRE. HENCE, IT IS
C        NECESSARY TO SWAP INDEXES. THIS IS MADE CHOOSING A DIFFERENT
C        POSITION FOR THE INDEX INDCOE (ORDER IN COMMENTS BEFORE INTEGH)
C
C=======================================================================
C
      HPPSOR(:,:)=C_ZERO
      HPMSOR(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
      IPOS=0
      IF ((INDCOE.GE.9.).AND.(INDCOE.LE.12)) IPOS=-4
C
      DO NX=0,NXMAXV(IND4HI(INDCOE))
         DO MX=0,NXMAXV(IND4HJ(INDCOE))
C
            DO KY=0,NYMAXV(IND4HI(INDCOE))+NYMAXV(IND4HJ(INDCOE))+1
C
C=======================================================================
C        INTEGRAL OVER X - FIRST DERIVATIVE
C=======================================================================
C
               DO KZ=0,NZMAXV(IND4HI(INDCOE))+NZMAXV(IND4HJ(INDCOE))+1
C
                  RESULT=C_ZERO
C
                  IF (ITWCEN.EQ.1) THEN
C
                  DO KX=NX+MX+1,0,-2
                        RESULT=RESULT+COEF01(KX,NX,MX,1)
     *                               *VONBAS(KX,KY,KZ,1)
                  END DO
C
                  ELSEIF (ITWCEN.EQ.2) THEN
C
                     DO KX=0,NX+MX+1
                        RESULT=RESULT+CF4H01(KX,NX,MX,1,INDCOE)
     *                                      *VONBAS(KX,KY,KZ,1)
                     END DO
C
                  END IF
C
                  X_HELP(KY,KZ)=RESULT
C
               END DO
C
C=======================================================================
C        INTEGRAL OVER X - FIRST DERIVATIVE AND ANTISYMMETRIZATION
C=======================================================================
C
               DO KZ=0,NZMAXV(IND4HI(INDCOE))+NZMAXV(IND4HJ(INDCOE))+1
C
                  RESULT=C_ZERO
C
                  IF (ITWCEN.EQ.1) THEN
C
                  DO KX=NX+MX+1,0,-2
                        RESULT=RESULT-COEF01(KX,MX,NX,1)*
     *                                VONBAS(KX,KY,KZ,1)
                  END DO
C
                  ELSEIF (ITWCEN.EQ.2) THEN
C
                     DO KX=0,NX+MX+1
                        RESULT=RESULT-CF4H01(KX,MX,NX,1,INDCOE+IPOS)*
     *                                       VONBAS(KX,KY,KZ,1)
                     END DO
C
                  END IF
C
                  X_HELP(KY,KZ)=X_HELP(KY,KZ)+RESULT
C
               END DO
C
C=======================================================================
C        INTEGRAL OVER X - NO DERIVATIVE
C=======================================================================
C
               DO KZ=0,NZMAXV(IND4HI(INDCOE))+NZMAXV(IND4HJ(INDCOE))+1
C
                  RESULT=C_ZERO
C
                  IF (ITWCEN.EQ.1) THEN
C
                  DO KX=NX+MX,0,-2
                        RESULT=RESULT+COEF00(KX,MX,NX,1)*
     *                                VONBAS(KX,KY,KZ,2)
                  END DO
C
                  ELSEIF (ITWCEN.EQ.2) THEN
C
                     DO KX=0,NX+MX
                        RESULT=RESULT+CF4H00(KX,NX,MX,1,INDCOE)*
     *                                       VONBAS(KX,KY,KZ,2)
                     END DO
C
                  END IF
C
                  Y_HELP(KY,KZ)=RESULT
C
               END DO
C
C=======================================================================
C        INTEGRAL OVER X - NO DERIVATIVE, AND SYMMETRIZATION
C=======================================================================
C
               DO KZ=0,NZMAXV(IND4HI(INDCOE))+NZMAXV(IND4HJ(INDCOE))+1
C
                  RESULT=C_ZERO
C
                  IF (ITWCEN.EQ.1) THEN
C
                  DO KX=NX+MX,0,-2
                         RESULT=RESULT+COEF00(KX,MX,NX,1)*
     *                                 VONBAS(KX,KY,KZ,3)
                  END DO
C
                  ELSEIF (ITWCEN.EQ.2) THEN
C
                      DO KX=0,NX+MX
                         RESULT=RESULT+CF4H00(KX,MX,NX,1,INDCOE+IPOS)*
     *                                        VONBAS(KX,KY,KZ,3)
                      END DO
C
                  END IF
C
                  Z_HELP(KY,KZ)=RESULT
C
               END DO
            END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
            DO NY=0,LYOFXV(NX,IND4HI(INDCOE))
               DO MY=0,LYOFXV(MX,IND4HJ(INDCOE))
C
                  IF (IPHAPP(NY,MY,KARTEZ).EQ.0.AND.ISIMPY.EQ.1) GO TO 1
C
C=======================================================================
C        INTEGRAL OVER Y - NO DERIVATIVE, AND PREVIOUS X-DERIVATIVE
C=======================================================================
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE)) +
     *                    NZMAXV(IND4HJ(INDCOE)) + 1
C
                     RESULT=C_ZERO
C
                     IF (ITWCEN.EQ.1) THEN
C
                     DO KY=NY+MY,0,-2
                           RESULT=RESULT+COEF00(KY,MY,NY,2)*
     *                                        X_HELP(KY,KZ)
                     END DO
C
                     ELSEIF (ITWCEN.EQ.2) THEN
C
                        DO KY=0,NY+MY
                           RESULT=RESULT+CF4H00(KY,NY,MY,2,INDCOE)*
     *                                               X_HELP(KY,KZ)
                        END DO
C
                     END IF
C
                     X_AUXI(KZ)=RESULT
C
                  END DO
C
C=======================================================================
C        INTEGRAL OVER Y - FIRST DERIVATIVE AND ANTISYMMETRIZATION
C=======================================================================
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE)) +
     *                    NZMAXV(IND4HJ(INDCOE)) + 1
C
                     RESULT=C_ZERO
C
                     IF (ITWCEN.EQ.1) THEN
C
                     DO KY=NY+MY+1,0,-2
                           RESULT=RESULT+COEF01(KY,NY,MY,2)*
     *                                        Y_HELP(KY,KZ)
                     END DO
C
                     ELSEIF (ITWCEN.EQ.2) THEN
C
                        DO KY=0,NY+MY+1
                           RESULT=RESULT+CF4H01(KY,NY,MY,2,INDCOE)*
     *                                               Y_HELP(KY,KZ)
                        END DO
C
                     END IF
C
                     Y_AUXI(KZ)=RESULT
C
                  END DO
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE))+
     *                    NZMAXV(IND4HJ(INDCOE))+1
C
                     RESULT=C_ZERO
C
                     IF (ITWCEN.EQ.1) THEN
C
                     DO KY=NY+MY+1,0,-2
                            RESULT=RESULT-COEF01(KY,MY,NY,2)*
     *                                         Y_HELP(KY,KZ)
                     END DO
C
                     ELSEIF (ITWCEN.EQ.2) THEN
C
                         DO KY=0,NY+MY+1
                           RESULT=RESULT-CF4H01(KY,MY,NY,2,INDCOE+IPOS)*
     *                                                Y_HELP(KY,KZ)
                         END DO
C
                     END IF
C
                     Y_AUXI(KZ)=Y_AUXI(KZ)+RESULT
C
                  END DO
C
C=======================================================================
C        INTEGRAL OVER Y - NO DERIVATIVE
C=======================================================================
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE)) +
     *                    NZMAXV(IND4HJ(INDCOE)) + 1
C
                     RESULT=C_ZERO
C
                     IF (ITWCEN.EQ.1) THEN
                     DO KY=NY+MY,0,-2
                            RESULT=RESULT+COEF00(KY,MY,NY,2)*
     *                                         Z_HELP(KY,KZ)
                     END DO
C
                     ELSEIF (ITWCEN.EQ.2) THEN
C
                         DO KY=0,NY+MY
                            RESULT=RESULT+CF4H00(KY,NY,MY,2,INDCOE)*
     *                                                Z_HELP(KY,KZ)
                         END DO
C
                     END IF
C
                     Z_AUXI(KZ)=RESULT
C
                  END DO
C
C=======================================================================
C        INTEGRAL OVER Y - AUXILIARY SUM
C=======================================================================
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE)) +
     *                    NZMAXV(IND4HJ(INDCOE)) + 1
C
                     T_AUXI(KZ)=X_AUXI(KZ)+Y_AUXI(KZ)
C
                  END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Z DIRECTION
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
C
C=======================================================================
C        INTEGRAL OVER Z - NO DERIVATIVE, PREVIOUS X- AND Y-DERIVATIVE
C=======================================================================
C
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        RESULT=C_ZERO
C
                        IF (ITWCEN.EQ.1) THEN
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)
#else
                        DO KZ=NZ+MZ,0,-2
#endif
                               RESULT=RESULT+COEF00(KZ,NZ,MZ,3)*
     *                                               T_AUXI(KZ)
                        END DO
C
                        ELSEIF (ITWCEN.EQ.2) THEN
C
#if(SWITCH_VECT==1)
                            DO KZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))+
     *                              LZOXYV(MX,MY,IND4HJ(INDCOE))
#else
                            DO KZ=0,NZ+MZ
#endif
                               RESULT=RESULT+CF4H00(KZ,NZ,MZ,3,INDCOE)*
     *                                                      T_AUXI(KZ)
                            END DO
C
                        END IF
C
                        T_HELP(NZ,MZ)=RESULT
C
                     END DO
C
C=======================================================================
C        INTEGRAL OVER Z - FIRST DERIVATIVE, AND ANTISYMMETRIZATION
C=======================================================================
C
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        RESULT=C_ZERO
C
                        IF (ITWCEN.EQ.1) THEN
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)+1
#else
                        DO KZ=NZ+MZ+1,0,-2
#endif
                               RESULT=RESULT+COEF01(KZ,NZ,MZ,3)*
     *                                               Z_AUXI(KZ)
                        END DO
C
                        ELSEIF (ITWCEN.EQ.2) THEN
C
#if(SWITCH_VECT==1)
                            DO KZ=0,LZOXYV(NX,NY,IND4HI(INDCOE)) +
     *                              LZOXYV(MX,MY,IND4HJ(INDCOE)) + 1
#else
                            DO KZ=0,NZ+MZ+1
#endif
                               RESULT=RESULT+CF4H01(KZ,NZ,MZ,3,INDCOE)*
     *                                                      Z_AUXI(KZ)
                            END DO
C
                        END IF
C
                        T_HELP(NZ,MZ)=T_HELP(NZ,MZ)+RESULT
C
                     END DO
C
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        RESULT=C_ZERO
C
                        IF (ITWCEN.EQ.1) THEN
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)+1
#else
                        DO KZ=NZ+MZ+1,0,-2
#endif
                               RESULT=RESULT-COEF01(KZ,MZ,NZ,3)*
     *                                               Z_AUXI(KZ)
                        END DO
C
                        ELSEIF (ITWCEN.EQ.2) THEN
C
#if(SWITCH_VECT==1)
                            DO KZ=0,LZOXYV(NX,NY,IND4HI(INDCOE)) +
     *                              LZOXYV(MX,MY,IND4HJ(INDCOE)) + 1
#else
                            DO KZ=0,NZ+MZ+1
#endif
                          RESULT=RESULT-CF4H01(KZ,MZ,NZ,3,INDCOE+IPOS)*
     *                                                      Z_AUXI(KZ)
                            END DO
C
                        END IF
C
                        T_HELP(NZ,MZ)=T_HELP(NZ,MZ)+RESULT
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-CONSERVING BLOCK
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        HPPSOR(INDICE(NX,NY,NZ,IND4HI(INDCOE)),
     *                         INDICE(MX,MY,MZ,IND4HJ(INDCOE)))=
     *                        (T_HELP(NZ,MZ)/2)*IPHAPP(NY,MY,KARTEZ)
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-NON-CONSERVING BLOCK
C=======================================================================
C
            IF (ISIMPY.NE.1) THEN
C
                DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
                    DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                      HPMSOR(INDICE(NX,NY,NZ,IND4HI(INDCOE)),
     *                       INDICE(MX,MY,MZ,IND4HJ(INDCOE)))=
     *                         (T_HELP(NZ,MZ)/2)*IPHAPM(NY,MY,KARTEZ)
C
                    END DO
                END DO
C
            END IF
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
    1             CONTINUE
C
               END DO
            END DO
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTSOR',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTMAS(SONBAS,KARTEZ,ISIMPY,HPPMAS,HPMMAS,
     *                                       ITWCEN,INDCOE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX)
      COMPLEX
     *          HPPMAS(1:NDBASE,1:NDBASE),
     *          HPMMAS(1:NDBASE,1:NDBASE)
      COMPLEX
     *          X_HELP(0:ND2MAX,0:ND2MAX),
     *          T_HELP(0:ND2MAX,0:ND2MAX)
      COMPLEX
     *          Z_HELP(0:NDOSCI,0:NDOSCI)
      COMPLEX
     *          X_AUXI(0:ND2MAX),
     *          Y_AUXI(0:ND2MAX),
     *          Z_AUXI(0:ND2MAX),
     *          T_AUXI(0:ND2MAX)
      COMPLEX
     *          RESULT,C_ZERO
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /COEFH4/ CF4H00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE),
     *                CF4H11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART,
     *                                                  1:NDTWHE)
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('INTMAS',1)
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS  THE  GAUSS - HERMITE INTEGRATIONS
C        OF THE MATRIX ELEMENTS OF THE  E F F E C T I V E  MASS-TERM
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
C        VECTORIZATION COMMENT:
C        PLEASE REFER TO THE COMMENT IN THE "INTCOU" SUBROUTINE
C
C=======================================================================
C
      HPPMAS(:,:)=C_ZERO
      HPMMAS(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
      DO NX=0,NXMAXV(IND4HI(INDCOE))
         DO MX=0,NXMAXV(IND4HJ(INDCOE))
C
            DO KY=0,NYMAXV(IND4HI(INDCOE))+NYMAXV(IND4HJ(INDCOE))+2
C
C=======================================================================
C        INTEGRAL OVER X - NO DERIVATIVE
C=======================================================================
C
               DO KZ=0,NZMAXV(IND4HI(INDCOE))+NZMAXV(IND4HJ(INDCOE))+2
C
                  RESULT=C_ZERO
C
                  IF (ITWCEN.EQ.1) THEN
                  DO KX=NX+MX,0,-2
                         RESULT=RESULT+COEF00(KX,MX,NX,1)*
     *                                   SONBAS(KX,KY,KZ)
                  END DO
                  ELSEIF(ITWCEN.EQ.2) THEN
                      DO KX=0,NX+MX
                         RESULT=RESULT+CF4H00(KX,NX,MX,1,INDCOE)*
     *                                          SONBAS(KX,KY,KZ)
                      END DO
                  END IF
C
                  T_HELP(KY,KZ)=RESULT
C
               END DO
C
C=======================================================================
C        INTEGRAL OVER X - SECOND DERIVATIVE
C=======================================================================
C
               DO KZ=0,NZMAXV(IND4HI(INDCOE))+NZMAXV(IND4HJ(INDCOE))+2
C
                  RESULT=C_ZERO
C
                  IF (ITWCEN.EQ.1) THEN
                  DO KX=NX+MX+2,0,-2
                         RESULT=RESULT+COEF11(KX,MX,NX,1)*
     *                                   SONBAS(KX,KY,KZ)
                  END DO
                  ELSEIF(ITWCEN.EQ.2) THEN
                      DO KX=0,NX+MX+2
                         RESULT=RESULT+CF4H11(KX,NX,MX,1,INDCOE)*
     *                                          SONBAS(KX,KY,KZ)
                      END DO
                  END IF
C
                  X_HELP(KY,KZ)=RESULT
C
               END DO
            END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
            DO NY=0,LYOFXV(NX,IND4HI(INDCOE))
               DO MY=0,LYOFXV(MX,IND4HJ(INDCOE))
C
                  IF (IPHAPP(NY,MY,KARTEZ).EQ.0.AND.ISIMPY.EQ.1) GO TO 1
C
C=======================================================================
C        INTEGRAL OVER Y - NO DERIVATIVE, AND SECOND X-DERIVATIVE
C=======================================================================
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE)) +
     *                    NZMAXV(IND4HJ(INDCOE)) + 2
C
                     RESULT=C_ZERO
C
                     IF (ITWCEN.EQ.1) THEN
                     DO KY=NY+MY,0,-2
                            RESULT=RESULT+COEF00(KY,MY,NY,2)*
     *                                        X_HELP(KY,KZ)
                     END DO
                     ELSEIF(ITWCEN.EQ.2) THEN
                         DO KY=0,NY+MY
                            RESULT=RESULT+CF4H00(KY,NY,MY,2,INDCOE)*
     *                                             X_HELP(KY,KZ)
                         END DO
                     END IF
C
                     X_AUXI(KZ)=RESULT
C
                  END DO
C
C=======================================================================
C        INTEGRAL OVER Y - SECOND DERIVATIVE
C=======================================================================
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE)) +
     *                    NZMAXV(IND4HJ(INDCOE)) + 2
C
                     RESULT=C_ZERO
C
                     IF (ITWCEN.EQ.1) THEN
                     DO KY=NY+MY+2,0,-2
                            RESULT=RESULT+COEF11(KY,MY,NY,2)*
     *                                         T_HELP(KY,KZ)
                     END DO
                     ELSEIF(ITWCEN.EQ.2) THEN
                         DO KY=0,NY+MY+2
                            RESULT=RESULT+CF4H11(KY,NY,MY,2,INDCOE)*
     *                                                T_HELP(KY,KZ)
                         END DO
                     END IF
C
                     Y_AUXI(KZ)=RESULT
C
                  END DO
C
C=======================================================================
C        INTEGRAL OVER Y - NO DERIVATIVE
C=======================================================================
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE)) +
     *                    NZMAXV(IND4HJ(INDCOE)) + 2
C
                     RESULT=C_ZERO
C
                     IF (ITWCEN.EQ.1) THEN
                     DO KY=NY+MY,0,-2
                            RESULT=RESULT+COEF00(KY,MY,NY,2)*
     *                                         T_HELP(KY,KZ)
                     END DO
                     ELSEIF(ITWCEN.EQ.2) THEN
                         DO KY=0,NY+MY
                            RESULT=RESULT+CF4H00(KY,NY,MY,2,INDCOE)*
     *                                                T_HELP(KY,KZ)
                         END DO
                     END IF
C
                     Z_AUXI(KZ)=RESULT
C
                  END DO
C
C=======================================================================
C        INTEGRAL OVER Y - AUXILIARY SUM
C=======================================================================
C
                  DO KZ=0,NZMAXV(IND4HI(INDCOE)) +
     *                    NZMAXV(IND4HJ(INDCOE)) + 2
C
                     T_AUXI(KZ)=X_AUXI(KZ)+Y_AUXI(KZ)
C
                  END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Z DIRECTION
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
C
C=======================================================================
C        INTEGRAL OVER Z - NO DERIVATIVE, SECOND X- AND Y-DERIVATIVES
C=======================================================================
C
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        RESULT=C_ZERO
C
                        IF (ITWCEN.EQ.1) THEN
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)
#else
                        DO KZ=NZ+MZ,0,-2
#endif
                               RESULT=RESULT+COEF00(KZ,NZ,MZ,3)
     *                                              *T_AUXI(KZ)
                        END DO
C
                        ELSEIF(ITWCEN.EQ.2) THEN
#if(SWITCH_VECT==1)
                            DO KZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))+
     *                              LZOXYV(MX,MY,IND4HJ(INDCOE))
#else
                            DO KZ=0,NZ+MZ
#endif
                               RESULT=RESULT+CF4H00(KZ,NZ,MZ,3,INDCOE)
     *                                                     *T_AUXI(KZ)
                            END DO
C
                        END IF
C
                        Z_HELP(NZ,MZ)=RESULT
C
                     END DO
C
C=======================================================================
C        INTEGRAL OVER Z - SECOND DERIVATIVE
C=======================================================================
C
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        RESULT=C_ZERO
C
                        IF (ITWCEN.EQ.1) THEN
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)+2
#else
                        DO KZ=NZ+MZ+2,0,-2
#endif
                               RESULT=RESULT+COEF11(KZ,NZ,MZ,3)*
     *                                               Z_AUXI(KZ)
                        END DO
C
                        ELSEIF (ITWCEN.EQ.2) THEN
C
#if(SWITCH_VECT==1)
                            DO KZ=0,LZOXYV(NX,NY,IND4HI(INDCOE)) +
     *                              LZOXYV(MX,MY,IND4HJ(INDCOE)) + 2
#else
                            DO KZ=0,NZ+MZ+2
#endif
                               RESULT=RESULT+CF4H11(KZ,NZ,MZ,3,INDCOE)*
     *                                                      Z_AUXI(KZ)
                            END DO
C
                        END IF
C
                        Z_HELP(NZ,MZ)=Z_HELP(NZ,MZ)+RESULT
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-CONSERVING BLOCK
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
                     DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                        HPPMAS(INDICE(NX,NY,NZ,IND4HI(INDCOE)),
     *                         INDICE(MX,MY,MZ,IND4HJ(INDCOE)))=
     *                            Z_HELP(NZ,MZ)*IPHAPP(NY,MY,KARTEZ)
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-NON-CONSERVING BLOCK
C=======================================================================
C
            IF (ISIMPY.NE.1) THEN
C
                DO NZ=0,LZOXYV(NX,NY,IND4HI(INDCOE))
                    DO MZ=0,LZOXYV(MX,MY,IND4HJ(INDCOE))
C
                      HPMMAS(INDICE(NX,NY,NZ,IND4HI(INDCOE)),
     *                       INDICE(MX,MY,MZ,IND4HJ(INDCOE)))=
     *                            Z_HELP(NZ,MZ)*IPHAPM(NY,MY,KARTEZ)
C
                    END DO
                END DO
C
            END IF
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
    1             CONTINUE
C
               END DO
            END DO
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTMAS',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTTEN(VONBAS,ISIMPY,HPPTEN,HPMTEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          VONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX,1:NDKART)
      COMPLEX
     *          HPPTEN(1:NDBASE,1:NDBASE),
     *          HPMTEN(1:NDBASE,1:NDBASE)
      COMPLEX
     *          X00HEL(0:ND2MAX,0:ND2MAX,1:NDKART),
     *          X01HEL(0:ND2MAX,0:ND2MAX,1:NDKART),
     *          X10HEL(0:ND2MAX,0:ND2MAX,1:NDKART),
     *          X11HEL(0:ND2MAX,0:ND2MAX,1:NDKART)
      COMPLEX
     *          X00Y00(0:ND2MAX,1:NDKART),
     *          X00Y01(0:ND2MAX,1:NDKART),
     *          X00Y10(0:ND2MAX,1:NDKART),
     *          X00Y11(0:ND2MAX,1:NDKART),
     *          X01Y00(0:ND2MAX,1:NDKART),
     *          X01Y10(0:ND2MAX,1:NDKART),
     *          X10Y00(0:ND2MAX,1:NDKART),
     *          X10Y01(0:ND2MAX,1:NDKART),
     *          X11Y00(0:ND2MAX,1:NDKART)
      COMPLEX
     *          Z_HELP(0:NDOSCI,0:NDOSCI,1:NDKART,1:NDKART,1:NDKART)
      COMPLEX
     *          RESULT,C_ZERO
      COMPLEX
     *          PHACOM
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEAUX/ COEF10(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('INTTEN',1)
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS  THE  GAUSS - HERMITE INTEGRATIONS
C        OF THE MATRIX ELEMENTS OF THE TENSOR TERM
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
C        VECTORIZATION COMMENT:
C        PLEASE REFER TO THE COMMENT IN THE "INTCOU" SUBROUTINE
C
C=======================================================================
C
      HPPTEN(:,:)=C_ZERO
      HPMTEN(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
      DO NX=0,NXMAXV(1)
         DO MX=0,NXMAXV(1)
C
            X00HEL(:,:,:)=C_ZERO
            X01HEL(:,:,:)=C_ZERO
            X10HEL(:,:,:)=C_ZERO
            X11HEL(:,:,:)=C_ZERO
C
C=======================================================================
C        INTEGRALS OVER X
C=======================================================================
C
            DO KY=0,2*NYMAXV(1)+2
               DO KZ=0,2*NZMAXV(1)+2
C
                  DO KARTEZ=1,NDKART
C
                     DO KX=NX+MX,0,-2
C
                        X00HEL(KY,KZ,KARTEZ)=
     *                  X00HEL(KY,KZ,KARTEZ)+COEF00(KX,NX,MX,1)
     *                                      *VONBAS(KX,KY,KZ,KARTEZ)
C
                     END DO
C
                     DO KX=NX+MX+1,0,-2
C
                        X01HEL(KY,KZ,KARTEZ)=
     *                  X01HEL(KY,KZ,KARTEZ)+COEF01(KX,NX,MX,1)
     *                                      *VONBAS(KX,KY,KZ,KARTEZ)
                        X10HEL(KY,KZ,KARTEZ)=
     *                  X10HEL(KY,KZ,KARTEZ)+COEF10(KX,NX,MX,1)
     *                                      *VONBAS(KX,KY,KZ,KARTEZ)
C
                     END DO
C
                     DO KX=NX+MX+2,0,-2
C
                        X11HEL(KY,KZ,KARTEZ)=
     *                  X11HEL(KY,KZ,KARTEZ)+COEF11(KX,NX,MX,1)
     *                                      *VONBAS(KX,KY,KZ,KARTEZ)
C
                     END DO
C
                  END DO
C
               END DO
            END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
            DO NY=0,LYOFXV(NX,1)
               DO MY=0,LYOFXV(MX,1)
C
                  X00Y00(:,:)=C_ZERO
                  X00Y01(:,:)=C_ZERO
                  X00Y10(:,:)=C_ZERO
                  X00Y11(:,:)=C_ZERO
                  X01Y00(:,:)=C_ZERO
                  X01Y10(:,:)=C_ZERO
                  X10Y00(:,:)=C_ZERO
                  X10Y01(:,:)=C_ZERO
                  X11Y00(:,:)=C_ZERO
C
C=======================================================================
C        INTEGRALS OVER Y
C=======================================================================
C
                  DO KZ=0,2*NZMAXV(1)+2
C
                     DO KARTEZ=1,NDKART
C
                        DO KY=NY+MY,0,-2
C
                           X00Y00(KZ,KARTEZ)=X00Y00(KZ,KARTEZ)
     *                                      +COEF00(KY,NY,MY,2)
     *                                      *X00HEL(KY,KZ,KARTEZ)
C
                           X01Y00(KZ,KARTEZ)=X01Y00(KZ,KARTEZ)
     *                                      +COEF00(KY,NY,MY,2)
     *                                      *X01HEL(KY,KZ,KARTEZ)
C
                           X10Y00(KZ,KARTEZ)=X10Y00(KZ,KARTEZ)
     *                                      +COEF00(KY,NY,MY,2)
     *                                      *X10HEL(KY,KZ,KARTEZ)
C
                           X11Y00(KZ,KARTEZ)=X11Y00(KZ,KARTEZ)
     *                                      +COEF00(KY,NY,MY,2)
     *                                      *X11HEL(KY,KZ,KARTEZ)
C
                        END DO
C
                        DO KY=NY+MY+1,0,-2
C
                           X00Y01(KZ,KARTEZ)=X00Y01(KZ,KARTEZ)
     *                                      +COEF01(KY,NY,MY,2)
     *                                      *X00HEL(KY,KZ,KARTEZ)
C
                           X00Y10(KZ,KARTEZ)=X00Y10(KZ,KARTEZ)
     *                                      +COEF10(KY,NY,MY,2)
     *                                      *X00HEL(KY,KZ,KARTEZ)
C
                           X01Y10(KZ,KARTEZ)=X01Y10(KZ,KARTEZ)
     *                                      +COEF10(KY,NY,MY,2)
     *                                      *X01HEL(KY,KZ,KARTEZ)
C
                           X10Y01(KZ,KARTEZ)=X10Y01(KZ,KARTEZ)
     *                                      +COEF01(KY,NY,MY,2)
     *                                      *X10HEL(KY,KZ,KARTEZ)
C
                        END DO
C
                        DO KY=NY+MY+2,0,-2
C
                           X00Y11(KZ,KARTEZ)=X00Y11(KZ,KARTEZ)
     *                                      +COEF11(KY,NY,MY,2)
     *                                      *X00HEL(KY,KZ,KARTEZ)
C
                        END DO
C
                     END DO
C
                  END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Z DIRECTION
C=======================================================================
C
                  Z_HELP(:,:,:,:,:)=C_ZERO
C
                  DO NZ=0,LZOXYV(NX,NY,1)
                     DO MZ=0,LZOXYV(MX,MY,1)
C
                        DO KARTEZ=1,NDKART
C
#if(SWITCH_VECT==1)
                           DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)
#else
                           DO KZ=NZ+MZ,0,-2
#endif
                             Z_HELP(NZ,MZ,1,1,KARTEZ)
     *                      =Z_HELP(NZ,MZ,1,1,KARTEZ)+X11Y00(KZ,KARTEZ)
     *                                               *COEF00(KZ,NZ,MZ,3)
C
                             Z_HELP(NZ,MZ,1,2,KARTEZ)
     *                      =Z_HELP(NZ,MZ,1,2,KARTEZ)+X10Y01(KZ,KARTEZ)
     *                                               *COEF00(KZ,NZ,MZ,3)
C
                             Z_HELP(NZ,MZ,2,1,KARTEZ)
     *                      =Z_HELP(NZ,MZ,2,1,KARTEZ)+X01Y10(KZ,KARTEZ)
     *                                               *COEF00(KZ,NZ,MZ,3)
                             Z_HELP(NZ,MZ,2,2,KARTEZ)
     *                      =Z_HELP(NZ,MZ,2,2,KARTEZ)+X00Y11(KZ,KARTEZ)
     *                                               *COEF00(KZ,NZ,MZ,3)
C
                           END DO
C
#if(SWITCH_VECT==1)
                           DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)+1
#else
                           DO KZ=NZ+MZ+1,0,-2
#endif
                             Z_HELP(NZ,MZ,1,3,KARTEZ)
     *                      =Z_HELP(NZ,MZ,1,3,KARTEZ)+X10Y00(KZ,KARTEZ)
     *                                               *COEF01(KZ,NZ,MZ,3)
C
                             Z_HELP(NZ,MZ,2,3,KARTEZ)
     *                      =Z_HELP(NZ,MZ,2,3,KARTEZ)+X00Y10(KZ,KARTEZ)
     *                                               *COEF01(KZ,NZ,MZ,3)
C
                             Z_HELP(NZ,MZ,3,1,KARTEZ)
     *                      =Z_HELP(NZ,MZ,3,1,KARTEZ)+X01Y00(KZ,KARTEZ)
     *                                               *COEF10(KZ,NZ,MZ,3)
                             Z_HELP(NZ,MZ,3,2,KARTEZ)
     *                      =Z_HELP(NZ,MZ,3,2,KARTEZ)+X00Y01(KZ,KARTEZ)
     *                                               *COEF10(KZ,NZ,MZ,3)
C
                           END DO
C
#if(SWITCH_VECT==1)
                           DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)+2
#else
                           DO KZ=NZ+MZ+2,0,-2
#endif
                             Z_HELP(NZ,MZ,3,3,KARTEZ)
     *                      =Z_HELP(NZ,MZ,3,3,KARTEZ)+X00Y00(KZ,KARTEZ)
     *                                               *COEF11(KZ,NZ,MZ,3)
C
                           END DO
C
                        END DO
C
                     END DO
                  END DO
C
C=======================================================================
C        AT THIS POINT, ARRAY Z_HELP(:,:,KARTEL,KARTER,KARTEZ) CONTAINS
C        THE MATRIX ELEMENT OF:
C               THE   L E F T   DERIVATIVE IN THE DIRECTION "KARTEL"
C        TIMES  THE  R I G H T  DERIVATIVE IN THE DIRECTION "KARTER"
C        CALCULATED FOR THE COMPONENT OF:
C               THE  FORMFACTOR  "VONBAS"  IN THE DIRECTION "KARTEZ".
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-CONSERVING BLOCK
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,1)
                     DO MZ=0,LZOXYV(MX,MY,1)
C
                        RESULT=C_ZERO
C
                        DO KARTEL=1,NDKART
                           DO KARTER=1,NDKART
C
                              RESULT=RESULT
     *                              +Z_HELP(NZ,MZ,KARTEL,KARTER,KARTEL)
     *                              *IPHAPP(NY,MY,KARTER)*PHACOM(KARTER)
     *                              +Z_HELP(NZ,MZ,KARTEL,KARTER,KARTER)
     *                              *IPHAPP(NY,MY,KARTEL)*PHACOM(KARTEL)
C
                           END DO
                        END DO
C
                        HPPTEN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *                                                        RESULT/2
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-NON-CONSERVING BLOCK
C=======================================================================
C
             IF (ISIMPY.NE.1) THEN
C
              DO NZ=0,LZOXYV(NX,NY,1)
                  DO MZ=0,LZOXYV(MX,MY,1)
C
                    RESULT=C_ZERO
C
                    DO KARTEL=1,NDKART
                        DO KARTER=1,NDKART
C
                          RESULT=RESULT
     *                          +Z_HELP(NZ,MZ,KARTEL,KARTER,KARTEL)
     *                          *IPHAPM(NY,MY,KARTER)*PHACOM(KARTER)
     *                          +Z_HELP(NZ,MZ,KARTEL,KARTER,KARTER)
     *                          *IPHAPM(NY,MY,KARTEL)*PHACOM(KARTEL)
C
                        END DO
                    END DO
C
                    HPMTEN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *                                                    RESULT/2
C
                  END DO
              END DO
C
          END IF
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTTEN',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTSPT(SONBAS,ISIMPY,HPPTEN,HPMTEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX)
      COMPLEX
     *          HPPTEN(1:NDBASE,1:NDBASE),
     *          HPMTEN(1:NDBASE,1:NDBASE)
      COMPLEX
     *          X00HEL(0:ND2MAX,0:ND2MAX),
     *          X01HEL(0:ND2MAX,0:ND2MAX),
     *          X10HEL(0:ND2MAX,0:ND2MAX)
      COMPLEX
     *          X00Y00(0:ND2MAX),
     *          X00Y01(0:ND2MAX),
     *          X00Y10(0:ND2MAX),
     *          X01Y00(0:ND2MAX),
     *          X10Y00(0:ND2MAX)
      COMPLEX
     *          Z_HELP(0:NDOSCI,0:NDOSCI,1:NDKART)
      COMPLEX
     *          RESULT,C_ZERO
      COMPLEX
     *          PHACOM
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEAUX/ COEF10(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('INTSPT',1)
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS  THE  GAUSS - HERMITE INTEGRATIONS
C        OF THE MATRIX ELEMENTS OF THE DIV-SPIN (SPT) TENSOR TERM
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
C        VECTORIZATION COMMENT:
C        PLEASE REFER TO THE COMMENT IN THE "INTCOU" SUBROUTINE
C
C=======================================================================
C
      HPPTEN(:,:)=C_ZERO
      HPMTEN(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
      DO NX=0,NXMAXV(1)
         DO MX=0,NXMAXV(1)
C
            X00HEL(:,:)=C_ZERO
            X01HEL(:,:)=C_ZERO
            X10HEL(:,:)=C_ZERO
C
C=======================================================================
C        INTEGRALS OVER X
C=======================================================================
C
            DO KY=0,2*NYMAXV(1)+2
               DO KZ=0,2*NZMAXV(1)+2
C
                  DO KX=NX+MX,0,-2
C
                     X00HEL(KY,KZ)=
     *               X00HEL(KY,KZ)+COEF00(KX,NX,MX,1)
     *                            *SONBAS(KX,KY,KZ)
C
                  END DO
C
                  DO KX=NX+MX+1,0,-2
C
                     X01HEL(KY,KZ)=
     *               X01HEL(KY,KZ)+COEF01(KX,NX,MX,1)
     *                            *SONBAS(KX,KY,KZ)
C
                     X10HEL(KY,KZ)=
     *               X10HEL(KY,KZ)+COEF10(KX,NX,MX,1)
     *                            *SONBAS(KX,KY,KZ)
C
                  END DO
C
               END DO
            END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
            DO NY=0,LYOFXV(NX,1)
               DO MY=0,LYOFXV(MX,1)
C
                  X00Y00(:)=C_ZERO
                  X00Y01(:)=C_ZERO
                  X00Y10(:)=C_ZERO
                  X01Y00(:)=C_ZERO
                  X10Y00(:)=C_ZERO
C
C=======================================================================
C        INTEGRALS OVER Y
C=======================================================================
C
                  DO KZ=0,2*NZMAXV(1)+2
                     DO KY=NY+MY,0,-2
C
                        X00Y00(KZ)=X00Y00(KZ)
     *                            +COEF00(KY,NY,MY,2)
     *                            *X00HEL(KY,KZ)
C
                        X01Y00(KZ)=X01Y00(KZ)
     *                            +COEF00(KY,NY,MY,2)
     *                            *X01HEL(KY,KZ)
C
                        X10Y00(KZ)=X10Y00(KZ)
     *                            +COEF00(KY,NY,MY,2)
     *                            *X10HEL(KY,KZ)
                     END DO
C
                     DO KY=NY+MY+1,0,-2
C
                        X00Y01(KZ)=X00Y01(KZ)
     *                            +COEF01(KY,NY,MY,2)
     *                            *X00HEL(KY,KZ)
C
                        X00Y10(KZ)=X00Y10(KZ)
     *                            +COEF10(KY,NY,MY,2)
     *                            *X00HEL(KY,KZ)
C
                     END DO
                  END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Z DIRECTION
C=======================================================================
C
                  Z_HELP(:,:,:)=C_ZERO
C
                  DO NZ=0,LZOXYV(NX,NY,1)
                     DO MZ=0,LZOXYV(MX,MY,1)
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)
#else
                        DO KZ=NZ+MZ,0,-2
#endif
                           Z_HELP(NZ,MZ,1)=
     *                     Z_HELP(NZ,MZ,1)+(X10Y00(KZ)+X01Y00(KZ))
     *                                    * COEF00(KZ,NZ,MZ,3)
                           Z_HELP(NZ,MZ,2)=
     *                     Z_HELP(NZ,MZ,2)+(X00Y10(KZ)+X00Y01(KZ))
     *                                    * COEF00(KZ,NZ,MZ,3)
C
                        END DO
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)+1
#else
                        DO KZ=NZ+MZ+1,0,-2
#endif
                           Z_HELP(NZ,MZ,3)=
     *                     Z_HELP(NZ,MZ,3)+X00Y00(KZ)
     *                                    *(COEF10(KZ,NZ,MZ,3)
     *                                     +COEF01(KZ,NZ,MZ,3))
C
                        END DO
C
                     END DO
                  END DO
C
C=======================================================================
C        AT THIS POINT, ARRAY Z_HELP(:,:,KARTEZ) CONTAINS
C        THE MATRIX ELEMENT OF:
C               THE   L E F T   DERIVATIVE IN THE DIRECTION "KARTEZ"
C        MINUS  THE  R I G H T  DERIVATIVE IN THE DIRECTION "KARTEZ"
C        CALCULATED FOR THE FORMFACTOR "SONBAS".
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-CONSERVING BLOCK
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,1)
                     DO MZ=0,LZOXYV(MX,MY,1)
C
                        RESULT=C_ZERO
C
                        DO KARTEZ=1,NDKART
C
                           RESULT=RESULT
     *                           +Z_HELP(NZ,MZ,KARTEZ)
     *                           *IPHAPP(NY,MY,KARTEZ)*PHACOM(KARTEZ)
C
                        END DO
C
                        HPPTEN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *                                                          RESULT
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-NON-CONSERVING BLOCK
C=======================================================================
C
            IF (ISIMPY.NE.1) THEN
C
                DO NZ=0,LZOXYV(NX,NY,1)
                    DO MZ=0,LZOXYV(MX,MY,1)
C
                      RESULT=C_ZERO
C
                      DO KARTEZ=1,NDKART
C
                          RESULT=RESULT
     *                        +Z_HELP(NZ,MZ,KARTEZ)
     *                        *IPHAPM(NY,MY,KARTEZ)*PHACOM(KARTEZ)
C
                      END DO
C
                      HPMTEN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *                                                         RESULT
C
                    END DO
                END DO
C
              END IF
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTSPT',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ESKYRM(ENESKY,ENEVEN,ENEODD,ENREAR,ENE_W0,EEVEW0,
     *                                       EODDW0,EKESKY,LDPNMX,
     *                                              IVIPRI,LDTWCE)
C=======================================================================
      USE HE_DEN
      USE hfodd_tgrad
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          CCPALL(NDCOUT),DCPALL(NDCOUT),ECPALL(NDCOUT)
      DIMENSION
     *          VCPALL(NDVIOL)
      COMPLEX
     *          ZCPALL(NDCOUT)
      COMPLEX
     *          EKESKY,C_ZERO,DE_ROJ
C
      EQUIVALENCE
     *            (CCPALL,CRHO_T),(DCPALL,DRHO_T),(ECPALL,ERHO_T)
      EQUIVALENCE
     *            (VCPALL,DSCRPP)
      EQUIVALENCE
     *            (ZCPALL,ZRHO_T)
C
      ALLOCATABLE DE_ROJ(:,:,:,:,:)
C
C=======================================================================
C            ATTENTION: BETWEEN VERSIONS (2.19D) AND (2.39B),  VARIABLES
C                       "QUNDIV" AND "QUNROT" BELOW WERE NOT DECLARED AS
C                       COMPLEX. THIS BUG WAS CORRECTED ON 31/03/2009 IN
C                       VERSION (2.39C).
C=======================================================================
C
      COMPLEX
     *          QUNRHO,QUPRHO,QUTRHO,
     *          QUNLPR,QUPLPR,QUTLPR,
     *          QUNTAU,QUPTAU,QUTTAU,
     *          QUNSCU,QUPSCU,QUTSCU,
     *          QUNDIV,QUPDIV,QUTDIV,
     *          QUNSPI,QUPSPI,QUTSPI,
     *          QUNLPS,QUPLPS,QUTLPS,
     *          QUNCUR,QUPCUR,QUTCUR,
     *          QUNKIS,QUPKIS,QUTKIS,
     *          QUNROT,QUPROT,QUTROT,
     *          QUNSCT,QUPSCT,QUTSCT,
     *          QUNKIT,QUPKIT,QUTKIT,
     *          QUNSPT,QUPSPT,QUTSPT
      COMPLEX
     *          QUNSC0,QUPSC0,QUTSC0
      COMPLEX
     *          QPPSCR,QMMSCR,QPMSCR,QMPSCR,QPPDIS,QMMDIS,QPMDIS,QMPDIS,
     *          QPPDSR,QMMDSR,QPMDSR,QMPDSR,QPPSCS,QMMSCS,QPMSCS,QMPSCS,
     *          QPPSCJ,QMMSCJ,QPMSCJ,QMPSCJ,QPPCUS,QMMCUS,QPMCUS,QMPCUS,
     *          QPPROS,QMMROS,QPMROS,QMPROS,QPPDES,QMMDES,QPMDES,QMPDES,
     *          QUNDIS,QUPDIS
      COMPLEX
     *          QPPRHS(NDKART),QMMRHS(NDKART),
     *          QPMRHS(NDKART),QMPRHS(NDKART),
     *          QPPRHC(NDKART),QMMRHC(NDKART),
     *          QPMRHC(NDKART),QMPRHC(NDKART)
      COMPLEX
     *          ZRHO_T,ZRHO_S,ZRHODT,ZRHODS,
     *          ZLPR_T,ZLPR_S,
     *          ZTAU_T,ZTAU_S,
     *          ZSCU_T,ZSCU_S,
     *          ZDIV_T,ZDIV_S,
     *          ZSPI_T,ZSPI_S,ZSPIDT,ZSPIDS,
     *          ZLPS_T,ZLPS_S,
     *          ZCUR_T,ZCUR_S,
     *          ZKIS_T,ZKIS_S,
     *          ZROT_T,ZROT_S,
     *          ZSCT_T,ZSCT_S,
     *          ZKIT_T,ZKIT_S,
     *          ZSPT_T,ZSPT_S
      COMPLEX
     *          XSCUET,XSCUES,XLPSET,XLPSES,XKISET,XKISES,
     *          XSCUOT,XSCUOS,XLPSOT,XLPSOS,XKISOT,XKISOS,
     *
     *          XSCTET,XSCTES,XKITET,XKITES,XSPTET,XSPTES,
     *          XSCTOT,XSCTOS,XKITOT,XKITOS,XSPTOT,XSPTOS
      COMPLEX
     *          ECCALL
      COMPLEX
     *          DENSIC,DENCHC,DENPOW
      COMPLEX
     *          DENNEU,DENPRO,SPINEU(NDKART),SPIPRO(NDKART)
      COMPLEX
     *          E3BEVE,E3BODD
      COMPLEX
     *          E4BEVE,E4BODD
      COMPLEX
     *          DR_CBR,DS_CBR,
     *          DT_CBR,DK_CBR,
     *          DL_CBR,DP_CBR,
     *          DC_CBR,DJ_CBR
      COMPLEX
     *          ER2CBR,ES2CBR,ER3CBR,ES3CBR,
     *          ET2CBR,EK2CBR,ET3CBR,EK3CBR,
     *          EL2CBR,EP2CBR,EL3CBR,EP3CBR,
     *          EC2CBR,EJ2CBR,EC3CBR,EJ3CBR
      COMPLEX
     *          FR2CBR,FS2CBR,FR3CBR,FS3CBR,
     *          FT2CBR,FK2CBR,FT3CBR,FK3CBR,
     *          FL2CBR,FP2CBR,FL3CBR,FP3CBR,
     *          FC2CBR,FJ2CBR,FC3CBR,FJ3CBR
      COMPLEX
     *          QUNSPT_1,QUPSPT_1,QUPSC0_1,QUNSC0_1,
     *          QUNDIS_1,QUPDIS_1,
     *          QUNSPT_2,QUPSPT_2,QUPSC0_2,QUNSC0_2,
     *          QUNDIS_2,QUPDIS_2
C
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /CCPSKY/ CRHO_T,CRHO_S,CRHODT,CRHODS,
     *                CLPR_T,CLPR_S,
     *                CTAU_T,CTAU_S,
     *                CSCU_T,CSCU_S,
     *                CDIV_T,CDIV_S,
     *                CSPI_T,CSPI_S,CSPIDT,CSPIDS,
     *                CLPS_T,CLPS_S,
     *                CCUR_T,CCUR_S,
     *                CKIS_T,CKIS_S,
     *                CROT_T,CROT_S,
     *                CSCT_T,CSCT_S,
     *                CKIT_T,CKIT_S,
     *                CSPT_T,CSPT_S
      COMMON
     *       /CCPTEN/ TLPSET,TLPSES,
     *                TKISET,TKISES,
     *                TSCUET,TSCUES,
     *                TLPSOT,TLPSOS,
     *                TKISOT,TKISOS,
     *                TSCUOT,TSCUOS,
     *
     *                TKITET,TKITES,
     *                TSCTET,TSCTES,
     *                TSPTET,TSPTES,
     *                TKITOT,TKITOS,
     *                TSCTOT,TSCTOS,
     *                TSPTOT,TSPTOS
      COMMON
     *       /DCPSKY/ DRHO_T,DRHO_S,DRHODT,DRHODS,
     *                DLPR_T,DLPR_S,
     *                DTAU_T,DTAU_S,
     *                DSCU_T,DSCU_S,
     *                DDIV_T,DDIV_S,
     *                DSPI_T,DSPI_S,DSPIDT,DSPIDS,
     *                DLPS_T,DLPS_S,
     *                DCUR_T,DCUR_S,
     *                DKIS_T,DKIS_S,
     *                DROT_T,DROT_S,
     *                DSCT_T,DSCT_S,
     *                DKIT_T,DKIT_S,
     *                DSPT_T,DSPT_S
      COMMON
     *       /ECPSKY/ ERHO_T,ERHO_S,ERHODT,ERHODS,
     *                ELPR_T,ELPR_S,
     *                ETAU_T,ETAU_S,
     *                ESCU_T,ESCU_S,
     *                EDIV_T,EDIV_S,
     *                ESPI_T,ESPI_S,ESPIDT,ESPIDS,
     *                ELPS_T,ELPS_S,
     *                ECUR_T,ECUR_S,
     *                EKIS_T,EKIS_S,
     *                EROT_T,EROT_S,
     *                ESCT_T,ESCT_S,
     *                EKIT_T,EKIT_S,
     *                ESPT_T,ESPT_S
      COMMON
     *       /ECCSKY/ ECCALL(NDCOUT)
      COMMON
     *       /ZCPSKY/ ZRHO_T,ZRHO_S,ZRHODT,ZRHODS,
     *                ZLPR_T,ZLPR_S,
     *                ZTAU_T,ZTAU_S,
     *                ZSCU_T,ZSCU_S,
     *                ZDIV_T,ZDIV_S,
     *                ZSPI_T,ZSPI_S,ZSPIDT,ZSPIDS,
     *                ZLPS_T,ZLPS_S,
     *                ZCUR_T,ZCUR_S,
     *                ZKIS_T,ZKIS_S,
     *                ZROT_T,ZROT_S,
     *                ZSCT_T,ZSCT_S,
     *                ZKIT_T,ZKIT_S,
     *                ZSPT_T,ZSPT_S
      COMMON
     *       /VCPSKY/ DSCRPP,DSCRMM,DSCRPM,DSCRMP,
     *                DDISPP,DDISMM,DDISPM,DDISMP,
     *                DDSRPP,DDSRMM,DDSRPM,DDSRMP,
     *                DSCSPP,DSCSMM,DSCSPM,DSCSMP,
     *                DSCJPP,DSCJMM,DSCJPM,DSCJMP,
     *                DCUSPP,DCUSMM,DCUSPM,DCUSMP,
     *                DROSPP,DROSMM,DROSPM,DROSMP,
     *                DDESPP,DDESMM,DDESPM,DDESMP,
     *
     *                XRHSPP,XRHSMM,XRHSPM,XRHSMP,
     *                YRHSPP,YRHSMM,YRHSPM,YRHSMP,
     *                ZRHSPP,ZRHSMM,ZRHSPM,ZRHSMP,
     *
     *                XRHCPP,XRHCMM,XRHCPM,XRHCMP,
     *                YRHCPP,YRHCMM,YRHCPM,YRHCMP,
     *                ZRHCPP,ZRHCMM,ZRHCPM,ZRHCMP
C
      COMMON
     *       /INTSKY/ T0,X0,T1,X1,T2,X2,T3,X3,W0,POWER
C
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /ETHRGR/ ETGRAF,ETGRAP
      COMMON
     *       /ETHREE/ E3BEVE,E3BODD
      COMMON
     *       /EFOURB/ E4BEVE,E4BODD
      COMMON
     *       /CC2CBR/ CR2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CS2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CT2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CK2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CL2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CP2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CC2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CJ2CBR(0:NDISOS,0:NDISOS,0:1)
     *       /CC3CBR/ CR3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CS3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CT3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CK3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CL3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CP3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CC3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CJ3CBR(0:NDISOS,0:NDISOS,0:1)
     *       /GC2CBR/ GR2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GS2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GT2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GK2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GL2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GP2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GC2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GJ2CBR(0:NDISOS,0:NDISOS,0:1,0:2)
     *       /GC3CBR/ GR3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GS3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GT3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GK3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GL3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GP3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GC3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GJ3CBR(0:NDISOS,0:NDISOS,0:1,0:2)
     *       /HC_CBR/ HR2CBR(0:2),HS2CBR(0:2),HR3CBR(0:2),HS3CBR(0:2),
     *                HT2CBR(0:2),HK2CBR(0:2),HT3CBR(0:2),HK3CBR(0:2),
     *                HL2CBR(0:2),HP2CBR(0:2),HL3CBR(0:2),HP3CBR(0:2),
     *                HC2CBR(0:2),HJ2CBR(0:2),HC3CBR(0:2),HJ3CBR(0:2)
      COMMON
     *       /DC_CBR/ DR_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DS_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DT_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DK_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DL_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DP_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DC_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DJ_CBR(0:NDISOS,0:NDISOS,0:1)
      COMMON
     *       /E_2CBR/ ER2CBR(0:NDISOS,0:NDISOS,0:1),
     *                ES2CBR(0:NDISOS,0:NDISOS,0:1),
     *                ET2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EK2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EL2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EP2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EC2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EJ2CBR(0:NDISOS,0:NDISOS,0:1)
     *       /E_3CBR/ ER3CBR(0:NDISOS,0:NDISOS,0:1),
     *                ES3CBR(0:NDISOS,0:NDISOS,0:1),
     *                ET3CBR(0:NDISOS,0:NDISOS,0:1),
     *                EK3CBR(0:NDISOS,0:NDISOS,0:1),
     *                EL3CBR(0:NDISOS,0:NDISOS,0:1),
     *                EP3CBR(0:NDISOS,0:NDISOS,0:1),
     *                EC3CBR(0:NDISOS,0:NDISOS,0:1),
     *                EJ3CBR(0:NDISOS,0:NDISOS,0:1)
      COMMON
     *       /FC_CBR/ FR2CBR,FS2CBR,FR3CBR,FS3CBR,
     *                FT2CBR,FK2CBR,FT3CBR,FK3CBR,
     *                FL2CBR,FP2CBR,FL3CBR,FP3CBR,
     *                FC2CBR,FJ2CBR,FC3CBR,FJ3CBR
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *      /HERMIN/  INTWHE(1:NDTWCE,1:NDTWCE,1:NDTWCE,1:NDTWCE)
      COMMON
     *       /TWCINT/ WGHERM(1:NDGAUS,1:NDKART),
     *                PTHERM(1:NDGAUS,1:NDKART)
      COMMON
     *       /TWINTF/ FACNE2(1:NDKART,1:NDTWBL),
     *                FACNE4(1:NDKART,1:NDTWHE)
      COMMON
     *       /E_TENS/ ETEVEN,ETEODD,
     *                ETOVEN,ETOODD
C
C=======================================================================
C
      CALL CPUTIM('ESKYRM',1)
C
C=======================================================================
C
C        THE EFFECTIVE COUPLING CONSTANTS AND THE CORRESPONDING CONTRI-
C                    BUTIONS TO THE ENERGY ARE CODED AS:
C                           'Z'//XXX//'N'//'TYP'
C        WHERE:
C
C        A.  'Z'  = 'C' = SHORT  FOR  THE " COUPLING    CONSTANT "
C            'Z'  = 'D' = SHORT  FOR  THE " DENSITY CONTRIBUTION "
C            'Z'  = 'E' = SHORT  FOR  THE " ENERGY  CONTRIBUTION "
C
C        B. 'XXX' = REPEATS  THE NAME OF THE CORRESPONDING DENSITY
C                   ACCORDING TO THE VOCABULARY IN THE  SUBROUTINE
C                                                           DENSHF
C
C                   SCALAR SYMMETRY-VIOLATING TERMS ARE DENOTED  BY  THE
C                   FOLLOWING SYMBOLS:
C
C                      SCR = SCALAR PART OF SPIN CURRENT  TIMES  DENSITY
C                      DIS = DIVERGENCE OF SPIN TIMES DIVERGENCE OF SPIN
C                      DSR = DIVERGENCE OF SPIN TIMES DENSITY
C                      SCS = VECTOR PART OF SPIN CURRENT  TIMES  SPIN
C                      SCJ = VECTOR PART OF SPIN CURRENT  TIMES  CURRENT
C                      CUS = CURRENT TIMES SPIN
C                      ROS = CURL OF SPIN TIMES SPIN
C                      DES = TENSOR DERIVATIVE OF SPIN TIMES TENSOR SPIN
C                            CURRENT
C
C                   VECTOR SYMMETRY-VIOLATING TERMS ARE DENOTED  BY  THE
C                   FOLLOWING SYMBOLS:
C
C                      RHS = SPIN TIMES DENSITY
C                      RHC = CURRENT TIMES DENSITY
C
C        C.  'N'  = '_' FOR THE DENSITY-INDEPENDENT TERM
C            'N'  = 'D' FOR THE DENSITY-DEPENDENT   TERM
C
C        D. 'TYP'   REFERS TO  THE  TYPE OF THE DENSITY EXPRESSION
C                   BECAUSE THE TERMS IN  THE  FUNCTIONAL  CAN  BE
C                   CLASSIFIED IN TWO WAYS:
C                                EITHER AS:
C           'TYP' = 'T' (THE TERM DEPENDS ON THE TOTAL DENSITY)
C                 = 'S' (THE TERM IS THE SUM OF CONTRIBUTIONS
C                        FROM PROTONS AND NEUTRONS)
C                                    OR AS:
C                 = 'P' (THE ISOSCALAR TERM)
C                 = 'M' (THE ISOVECTOR TERM)
C
C=======================================================================
C
C        THE EFFECTIVE CHARGE-SYMMETRY-BREAKING COUPLING CONSTANTS
C        AND THE CORRESPONDING CONTRIBUTIONS TO THE ENERGY ARE CODED AS:
C                           'Z'//'X'//'N'//CBR
C        WHERE:
C
C        A.  'Z'  = 'C' = SHORT  FOR  THE " COUPLING    CONSTANT "
C            'Z'  = 'D' = SHORT  FOR  THE " DENSITY CONTRIBUTION "
C            'Z'  = 'E' = SHORT  FOR  THE " ENERGY  CONTRIBUTION "
C
C        B.  'X'  = 'R' = SHORT FOR "RHO" (     PARTICLE DENSITY     )
C            'X'  = 'S' = SHORT FOR "SPI" (       SPIN DENSITY       )
C            'X'  = 'T' = SHORT FOR "TAU" (     KINETIC DENSITY      )
C            'X'  = 'K' = SHORT FOR "KIS" (  VECTOR KINETIC DENSITY  )
C            'X'  = 'L' = SHORT FOR "LPR" (LAPLACIAN PARTICLE DENSITY)
C            'X'  = 'P' = SHORT FOR "LPS" (LAPLACIAN   SPIN   DENSITY)
C            'X'  = 'C' = SHORT FOR "CUR" (     CURRENT DENSITY      )
C            'X'  = 'J' = SHORT FOR "SCU" (   SPIN CURRENT DENSITY   )
C
C        C.  'N'  = '2' = CLASS II
C            'N'  = '3' = CLASS III
C                         WHERE CLASSES ARE GIVEN IN "MESONS IN NUCLEI"
C                         EDS. M. RHO AND D.H. WILKINSON, CHAPTER 10
C
C=======================================================================
      IF ((IVIPRI.EQ.0.OR.IVIPRI.EQ.1).AND.NDVIOL.NE.32)
     *     STOP 'FOR IVIPRI=0 OR 1, NDVIOL=32 IS REQUIRED IN ESKYRM'
      IF (IVIPRI.EQ.2.AND.NDVIOL.NE.56)
     *     STOP 'FOR IVIPRI=2, NDVIOL=56 IS REQUIRED IN ESKYRM'
C=======================================================================
      ALLOCATE(DE_ROJ(NDXHRM,NDYHRM,NDZHRM,NDKART,0:LDPNMX),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DE_ROJ','ESKYRM')
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      ENESKY=0.0D0
      ENREAR=0.0D0
C
      EKESKY=C_ZERO
C
      E3BEVE=C_ZERO
      E3BODD=C_ZERO
C
      E4BEVE=C_ZERO
      E4BODD=C_ZERO
C
      DO NUCOUT=1,NDCOUT
         ZCPALL(NUCOUT)=C_ZERO
      END DO
C
      XSCUET=C_ZERO
      XSCUES=C_ZERO
      XLPSET=C_ZERO
      XLPSES=C_ZERO
      XKISET=C_ZERO
      XKISES=C_ZERO
C
      XSCUOT=C_ZERO
      XSCUOS=C_ZERO
      XLPSOT=C_ZERO
      XLPSOS=C_ZERO
      XKISOT=C_ZERO
      XKISOS=C_ZERO
C
      XSCTET=C_ZERO
      XSCTES=C_ZERO
      XKITET=C_ZERO
      XKITES=C_ZERO
      XSPTET=C_ZERO
      XSPTES=C_ZERO
C
      XSCTOT=C_ZERO
      XSCTOS=C_ZERO
      XKITOT=C_ZERO
      XKITOS=C_ZERO
      XSPTOT=C_ZERO
      XSPTOS=C_ZERO
C
      DO NUVIOL=1,NDVIOL
         VCPALL(NUVIOL)=0.0D0
      END DO
C
      DR_CBR(:,:,0)=C_ZERO
      DS_CBR(:,:,0)=C_ZERO
      DT_CBR(:,:,0)=C_ZERO
      DK_CBR(:,:,0)=C_ZERO
      DL_CBR(:,:,0)=C_ZERO
      DP_CBR(:,:,0)=C_ZERO
      DC_CBR(:,:,0)=C_ZERO
      DJ_CBR(:,:,0)=C_ZERO
C
C=======================================================================
C     TWO-CENTRE BASIS OPTION: EVERY TERM CONTAINS THE PRODUCT OF TWO
C     DENSITIES WICH ARE RELATED TO EACH OTHER DUE TO CHANGES MADE FOR
C     THE QUADRATURE (DIFFERENT COMBINATIONS OF WIDTHS AND CENTRES IN
C     THE GAUSSIANS). HENCE, WE NEED TO SUM THE SIXTEEN COMBINATIONS.
C     THE INDEX OF THE SECOND DENSITY IS OBTAINED SIMPLY SWAPPING THE
C     PAIR IJ <-> KL, WHICH PRESERVES THE SAME GLOBAL GAUSSIAN FACTOR
C
C     ATTENTION: DENSITY-DEPENDENT TERMS NOT PROPERTLY COMPUTED YET :(
C=======================================================================
      DO LTWCEN=1,LDTWCE
C
         INNERI=IND4HI(LTWCEN)
         INNERJ=IND4HJ(LTWCEN)
         INNERK=IND4HK(LTWCEN)
         INNERL=IND4HL(LTWCEN)
C
         LTWCE1=INTWHE(INNERI,INNERJ,INNERK,INNERL)
         LTWCE2=INTWHE(INNERK,INNERL,INNERI,INNERJ)
C
      DO IX=1,NXHERM
         DO IY=1,NYHERM
            DO IZ=1,NZHERM
C
               DENNEU   = DE_RHO(IX,IY,IZ,0,1) * EXPAUX(IX,IY,IZ,1)
               DENPRO   = DE_RHO(IX,IY,IZ,1,1) * EXPAUX(IX,IY,IZ,1)
C
               SPINEU(1)= DE_SPI(IX,IY,IZ,1,0,1)*EXPAUX(IX,IY,IZ,1)
               SPIPRO(1)= DE_SPI(IX,IY,IZ,1,1,1)*EXPAUX(IX,IY,IZ,1)
C
               SPINEU(2)= DE_SPI(IX,IY,IZ,2,0,1)*EXPAUX(IX,IY,IZ,1)
               SPIPRO(2)= DE_SPI(IX,IY,IZ,2,1,1)*EXPAUX(IX,IY,IZ,1)
C
               SPINEU(3)= DE_SPI(IX,IY,IZ,3,0,1)*EXPAUX(IX,IY,IZ,1)
               SPIPRO(3)= DE_SPI(IX,IY,IZ,3,1,1)*EXPAUX(IX,IY,IZ,1)
C
C=======================================================================
C        CALCULATING THE VECTOR PART OF THE SPIN-CURRENT TENSOR
C=======================================================================
C
               DE_ROJ(IX,IY,IZ,1,0)=
     *       DE_SCU(IX,IY,IZ,2,3,0,LTWCE1)-DE_SCU(IX,IY,IZ,3,2,0,LTWCE1)
               DE_ROJ(IX,IY,IZ,2,0)=
     *       DE_SCU(IX,IY,IZ,3,1,0,LTWCE1)-DE_SCU(IX,IY,IZ,1,3,0,LTWCE1)
               DE_ROJ(IX,IY,IZ,3,0)=
     *       DE_SCU(IX,IY,IZ,1,2,0,LTWCE1)-DE_SCU(IX,IY,IZ,2,1,0,LTWCE1)
C
               DE_ROJ(IX,IY,IZ,1,1)=
     *       DE_SCU(IX,IY,IZ,2,3,1,LTWCE1)-DE_SCU(IX,IY,IZ,3,2,1,LTWCE1)
               DE_ROJ(IX,IY,IZ,2,1)=
     *       DE_SCU(IX,IY,IZ,3,1,1,LTWCE1)-DE_SCU(IX,IY,IZ,1,3,1,LTWCE1)
               DE_ROJ(IX,IY,IZ,3,1)=
     *       DE_SCU(IX,IY,IZ,1,2,1,LTWCE1)-DE_SCU(IX,IY,IZ,2,1,1,LTWCE1)
C
C=======================================================================
C        CALCULATING  THE  A U X I L I A R Y   C O N T R A C T I O N S
C=======================================================================
C
            QUNRHO = DE_RHO(IX,IY,IZ,0,LTWCE1)*DE_RHO(IX,IY,IZ,0,LTWCE2)
            QUPRHO = DE_RHO(IX,IY,IZ,1,LTWCE1)*DE_RHO(IX,IY,IZ,1,LTWCE2)
C
           QUTRHO =(DE_RHO(IX,IY,IZ,0,LTWCE1)+DE_RHO(IX,IY,IZ,1,LTWCE1))
     *            *(DE_RHO(IX,IY,IZ,0,LTWCE2)+DE_RHO(IX,IY,IZ,1,LTWCE2))
C
            QUNSPI = C_ZERO
            QUPSPI = C_ZERO
            QUTSPI = C_ZERO
C
            QUNLPR = DE_RHO(IX,IY,IZ,0,LTWCE1)*DE_LPR(IX,IY,IZ,0,LTWCE2)
            QUPLPR = DE_RHO(IX,IY,IZ,1,LTWCE1)*DE_LPR(IX,IY,IZ,1,LTWCE2)
C
           QUTLPR =(DE_RHO(IX,IY,IZ,0,LTWCE1)+DE_RHO(IX,IY,IZ,1,LTWCE1))
     *            *(DE_LPR(IX,IY,IZ,0,LTWCE2)+DE_LPR(IX,IY,IZ,1,LTWCE2))
C
            QUNTAU = DE_RHO(IX,IY,IZ,0,LTWCE1)*DE_TAU(IX,IY,IZ,0,LTWCE2)
            QUPTAU = DE_RHO(IX,IY,IZ,1,LTWCE1)*DE_TAU(IX,IY,IZ,1,LTWCE2)
C
           QUTTAU =(DE_RHO(IX,IY,IZ,0,LTWCE1)+DE_RHO(IX,IY,IZ,1,LTWCE1))
     *            *(DE_TAU(IX,IY,IZ,0,LTWCE2)+DE_TAU(IX,IY,IZ,1,LTWCE2))
C
            QUNLPS=C_ZERO
            QUPLPS=C_ZERO
            QUTLPS=C_ZERO
C
            QUNCUR=C_ZERO
            QUPCUR=C_ZERO
            QUTCUR=C_ZERO
C
            QUNKIS=C_ZERO
            QUPKIS=C_ZERO
            QUTKIS=C_ZERO
C
            QUNSCU=C_ZERO
            QUPSCU=C_ZERO
            QUTSCU=C_ZERO
C
            QUNROT=C_ZERO
            QUPROT=C_ZERO
            QUTROT=C_ZERO
C
            QUNSCT=C_ZERO
            QUPSCT=C_ZERO
            QUTSCT=C_ZERO
C
            QUNKIT=C_ZERO
            QUPKIT=C_ZERO
            QUTKIT=C_ZERO
C
            QUNSPT=C_ZERO
            QUPSPT=C_ZERO
            QUTSPT=C_ZERO
C
            QUNSC0=C_ZERO
            QUPSC0=C_ZERO
            QUTSC0=C_ZERO
C
            QUNDIV = DE_RHO(IX,IY,IZ,0,LTWCE1)
     *              *DE_DIV(IX,IY,IZ,0,LTWCE2)
            QUPDIV = DE_RHO(IX,IY,IZ,1,LTWCE1)
     *              *DE_DIV(IX,IY,IZ,1,LTWCE2)
C
            QUTDIV =(DE_RHO(IX,IY,IZ,0,LTWCE1)
     *              +DE_RHO(IX,IY,IZ,1,LTWCE1))
     *             *(DE_DIV(IX,IY,IZ,0,LTWCE2)
     *              +DE_DIV(IX,IY,IZ,1,LTWCE2))
C
               QPPSCR=C_ZERO
               QMMSCR=C_ZERO
               QPMSCR=C_ZERO
               QMPSCR=C_ZERO
C
               QPPDIS=C_ZERO
               QMMDIS=C_ZERO
               QPMDIS=C_ZERO
               QMPDIS=C_ZERO
C
               QPPDSR=C_ZERO
               QMMDSR=C_ZERO
               QPMDSR=C_ZERO
               QMPDSR=C_ZERO
C
               QPPSCS=C_ZERO
               QMMSCS=C_ZERO
               QPMSCS=C_ZERO
               QMPSCS=C_ZERO
C
               QPPSCJ=C_ZERO
               QMMSCJ=C_ZERO
               QPMSCJ=C_ZERO
               QMPSCJ=C_ZERO
C
               QPPCUS=C_ZERO
               QMMCUS=C_ZERO
               QPMCUS=C_ZERO
               QMPCUS=C_ZERO
C
               QPPROS=C_ZERO
               QMMROS=C_ZERO
               QPMROS=C_ZERO
               QMPROS=C_ZERO
C
               QPPDES=C_ZERO
               QMMDES=C_ZERO
               QPMDES=C_ZERO
               QMPDES=C_ZERO
C
               QUNDIS=C_ZERO
               QUPDIS=C_ZERO
C
               QUNSPT_1=C_ZERO
               QUPSPT_1=C_ZERO
               QUNSPT_2=C_ZERO
               QUPSPT_2=C_ZERO
               QUNSC0_1=C_ZERO
               QUPSC0_1=C_ZERO
               QUNSC0_2=C_ZERO
               QUPSC0_2=C_ZERO
               QUNDIS_1=C_ZERO
               QUPDIS_1=C_ZERO
               QUNDIS_2=C_ZERO
               QUPDIS_2=C_ZERO
C
               DO K=1,NDKART
C
C=======================================================================
C
                  QUNSPI=QUNSPI
     *                  + DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   *DE_SPI(IX,IY,IZ,K,0,LTWCE2)
                  QUPSPI=QUPSPI
     *                  + DE_SPI(IX,IY,IZ,K,1,LTWCE1)
     *                   *DE_SPI(IX,IY,IZ,K,1,LTWCE2)
C
                  QUTSPI=QUTSPI
     *                  +(DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   +DE_SPI(IX,IY,IZ,K,1,LTWCE1))
     *                  *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)
     *                   +DE_SPI(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QUNCUR=QUNCUR
     *                  + DE_CUR(IX,IY,IZ,K,0,LTWCE1)
     *                   *DE_CUR(IX,IY,IZ,K,0,LTWCE2)
                  QUPCUR=QUPCUR
     *                  + DE_CUR(IX,IY,IZ,K,1,LTWCE1)
     *                   *DE_CUR(IX,IY,IZ,K,1,LTWCE2)
C
                  QUTCUR=QUTCUR
     *                  +(DE_CUR(IX,IY,IZ,K,0,LTWCE1)
     *                   +DE_CUR(IX,IY,IZ,K,1,LTWCE1))
     *                  *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)
     *                   +DE_CUR(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QUNLPS=QUNLPS
     *                  + DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   *DE_LPS(IX,IY,IZ,K,0,LTWCE2)
                  QUPLPS=QUPLPS
     *                  + DE_SPI(IX,IY,IZ,K,1,LTWCE1)
     *                   *DE_LPS(IX,IY,IZ,K,1,LTWCE2)
C
                  QUTLPS=QUTLPS
     *                  +(DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   +DE_SPI(IX,IY,IZ,K,1,LTWCE1))
     *                  *(DE_LPS(IX,IY,IZ,K,0,LTWCE2)
     *                   +DE_LPS(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QUNKIS=QUNKIS
     *                  + DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   *DE_KIS(IX,IY,IZ,K,0,LTWCE2)
                  QUPKIS=QUPKIS
     *                  + DE_SPI(IX,IY,IZ,K,1,LTWCE1)
     *                   *DE_KIS(IX,IY,IZ,K,1,LTWCE2)
C
                  QUTKIS=QUTKIS
     *                  +(DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   +DE_SPI(IX,IY,IZ,K,1,LTWCE1))
     *                  *(DE_KIS(IX,IY,IZ,K,0,LTWCE2)
     *                   +DE_KIS(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QUNROT=QUNROT
     *                  + DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   *DE_ROC(IX,IY,IZ,K,0,LTWCE2)
                  QUPROT=QUPROT
     *                  + DE_SPI(IX,IY,IZ,K,1,LTWCE1)
     *                   *DE_ROC(IX,IY,IZ,K,1,LTWCE2)
C
                  QUTROT=QUTROT
     *                  +(DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   +DE_SPI(IX,IY,IZ,K,1,LTWCE1))
     *                  *(DE_ROC(IX,IY,IZ,K,0,LTWCE2)
     *                   +DE_ROC(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QUNKIT=QUNKIT
     *                  + DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   *DE_KIF(IX,IY,IZ,K,0,LTWCE2)
                  QUPKIT=QUPKIT
     *                  + DE_SPI(IX,IY,IZ,K,1,LTWCE1)
     *                   *DE_KIF(IX,IY,IZ,K,1,LTWCE2)
C
                  QUTKIT=QUTKIT
     *                  +(DE_SPI(IX,IY,IZ,K,0,LTWCE1)
     *                   +DE_SPI(IX,IY,IZ,K,1,LTWCE1))
     *                  *(DE_KIF(IX,IY,IZ,K,0,LTWCE2)
     *                   +DE_KIF(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QUNSPT_1=QUNSPT_1+DE_DES(IX,IY,IZ,K,K,0,LTWCE1)
                  QUPSPT_1=QUPSPT_1+DE_DES(IX,IY,IZ,K,K,1,LTWCE1)
C
C=======================================================================
C
                  QUNSC0_1=QUNSC0_1+DE_SCU(IX,IY,IZ,K,K,0,LTWCE1)
                  QUPSC0_1=QUPSC0_1+DE_SCU(IX,IY,IZ,K,K,1,LTWCE1)
c
C=======================================================================
C
                  QUNSPT_2=QUNSPT_2+DE_DES(IX,IY,IZ,K,K,0,LTWCE2)
                  QUPSPT_2=QUPSPT_2+DE_DES(IX,IY,IZ,K,K,1,LTWCE2)
C
C=======================================================================
C
                  QUNSC0_2=QUNSC0_2+DE_SCU(IX,IY,IZ,K,K,0,LTWCE2)
                  QUPSC0_2=QUPSC0_2+DE_SCU(IX,IY,IZ,K,K,1,LTWCE2)
C
C=======================================================================
C                 SYMMETRY-VIOLATING TERMS
C=======================================================================
C
                  QPPSCR=QPPSCR+
     *     (DE_SCU(IX,IY,IZ,K,K,0,LTWCE1)+DE_SCU(IX,IY,IZ,K,K,1,LTWCE1))
     *    *(DE_RHO(IX,IY,IZ    ,0,LTWCE2)+DE_RHO(IX,IY,IZ    ,1,LTWCE2))
                  QMMSCR=QMMSCR+
     *     (DE_SCU(IX,IY,IZ,K,K,0,LTWCE1)-DE_SCU(IX,IY,IZ,K,K,1,LTWCE1))
     *    *(DE_RHO(IX,IY,IZ    ,0,LTWCE2)-DE_RHO(IX,IY,IZ    ,1,LTWCE2))
                  QPMSCR=QPMSCR+
     *     (DE_SCU(IX,IY,IZ,K,K,0,LTWCE1)+DE_SCU(IX,IY,IZ,K,K,1,LTWCE1))
     *    *(DE_RHO(IX,IY,IZ    ,0,LTWCE2)-DE_RHO(IX,IY,IZ    ,1,LTWCE2))
                  QMPSCR=QMPSCR+
     *     (DE_SCU(IX,IY,IZ,K,K,0,LTWCE1)-DE_SCU(IX,IY,IZ,K,K,1,LTWCE1))
     *    *(DE_RHO(IX,IY,IZ    ,0,LTWCE2)+DE_RHO(IX,IY,IZ    ,1,LTWCE2))
C
C=======================================================================
C
                  QUNDIS_1=QUNDIS_1+DE_DES(IX,IY,IZ,K,K,0,LTWCE1)
                  QUPDIS_1=QUPDIS_1+DE_DES(IX,IY,IZ,K,K,1,LTWCE1)
C
C=======================================================================
C
                  QUNDIS_2=QUNDIS_2+DE_DES(IX,IY,IZ,K,K,0,LTWCE2)
                  QUPDIS_2=QUPDIS_2+DE_DES(IX,IY,IZ,K,K,1,LTWCE2)
C
C=======================================================================
C
                  QPPDSR=QPPDSR+
     *     (DE_DES(IX,IY,IZ,K,K,0,LTWCE1)+DE_DES(IX,IY,IZ,K,K,1,LTWCE1))
     *    *(DE_RHO(IX,IY,IZ    ,0,LTWCE2)+DE_RHO(IX,IY,IZ    ,1,LTWCE2))
                  QMMDSR=QMMDSR+
     *     (DE_DES(IX,IY,IZ,K,K,0,LTWCE1)-DE_DES(IX,IY,IZ,K,K,1,LTWCE1))
     *    *(DE_RHO(IX,IY,IZ    ,0,LTWCE2)-DE_RHO(IX,IY,IZ    ,1,LTWCE2))
                  QPMDSR=QPMDSR+
     *     (DE_DES(IX,IY,IZ,K,K,0,LTWCE1)+DE_DES(IX,IY,IZ,K,K,1,LTWCE1))
     *    *(DE_RHO(IX,IY,IZ    ,0,LTWCE2)-DE_RHO(IX,IY,IZ    ,1,LTWCE2))
                  QMPDSR=QMPDSR+
     *     (DE_DES(IX,IY,IZ,K,K,0,LTWCE1)-DE_DES(IX,IY,IZ,K,K,1,LTWCE1))
     *    *(DE_RHO(IX,IY,IZ    ,0,LTWCE2)+DE_RHO(IX,IY,IZ    ,1,LTWCE2))
C
C=======================================================================
C
                  QPPSCS=QPPSCS
     *        +(DE_ROJ(IX,IY,IZ,K,0)+DE_ROJ(IX,IY,IZ,K,1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)+DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QMMSCS=QMMSCS
     *        +(DE_ROJ(IX,IY,IZ,K,0)-DE_ROJ(IX,IY,IZ,K,1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)-DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QPMSCS=QPMSCS
     *        +(DE_ROJ(IX,IY,IZ,K,0)+DE_ROJ(IX,IY,IZ,K,1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)-DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QMPSCS=QMPSCS
     *        +(DE_ROJ(IX,IY,IZ,K,0)-DE_ROJ(IX,IY,IZ,K,1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)+DE_SPI(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QPPSCJ=QPPSCJ
     *        +(DE_ROJ(IX,IY,IZ,K,0)+DE_ROJ(IX,IY,IZ,K,1))
     *        *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)+DE_CUR(IX,IY,IZ,K,1,LTWCE2))
                  QMMSCJ=QMMSCJ
     *        +(DE_ROJ(IX,IY,IZ,K,0)-DE_ROJ(IX,IY,IZ,K,1))
     *        *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)-DE_CUR(IX,IY,IZ,K,1,LTWCE2))
                  QPMSCJ=QPMSCJ
     *        +(DE_ROJ(IX,IY,IZ,K,0)+DE_ROJ(IX,IY,IZ,K,1))
     *        *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)-DE_CUR(IX,IY,IZ,K,1,LTWCE2))
                  QMPSCJ=QMPSCJ
     *        +(DE_ROJ(IX,IY,IZ,K,0)-DE_ROJ(IX,IY,IZ,K,1))
     *        *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)+DE_CUR(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QPPCUS=QPPCUS
     *        +(DE_CUR(IX,IY,IZ,K,0,LTWCE1)+DE_CUR(IX,IY,IZ,K,1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)+DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QMMCUS=QMMCUS
     *        +(DE_CUR(IX,IY,IZ,K,0,LTWCE1)-DE_CUR(IX,IY,IZ,K,1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)-DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QPMCUS=QPMCUS
     *        +(DE_CUR(IX,IY,IZ,K,0,LTWCE1)+DE_CUR(IX,IY,IZ,K,1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)-DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QMPCUS=QMPCUS
     *        +(DE_CUR(IX,IY,IZ,K,0,LTWCE1)-DE_CUR(IX,IY,IZ,K,1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)+DE_SPI(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QPPROS=QPPROS
     *        +(DE_ROS(IX,IY,IZ,K,0,LTWCE1)+DE_ROS(IX,IY,IZ,K,1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)+DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QMMROS=QMMROS
     *        +(DE_ROS(IX,IY,IZ,K,0,LTWCE1)-DE_ROS(IX,IY,IZ,K,1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)-DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QPMROS=QPMROS
     *        +(DE_ROS(IX,IY,IZ,K,0,LTWCE1)+DE_ROS(IX,IY,IZ,K,1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)-DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QMPROS=QMPROS
     *        +(DE_ROS(IX,IY,IZ,K,0,LTWCE1)-DE_ROS(IX,IY,IZ,K,1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)+DE_SPI(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QPPRHS(K)=
     *        +(DE_RHO(IX,IY,IZ,  0,LTWCE1)+DE_RHO(IX,IY,IZ,  1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)+DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QMMRHS(K)=
     *        +(DE_RHO(IX,IY,IZ,  0,LTWCE1)-DE_RHO(IX,IY,IZ,  1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)-DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QPMRHS(K)=
     *        +(DE_RHO(IX,IY,IZ,  0,LTWCE1)+DE_RHO(IX,IY,IZ,  1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)-DE_SPI(IX,IY,IZ,K,1,LTWCE2))
                  QMPRHS(K)=
     *        +(DE_RHO(IX,IY,IZ,  0,LTWCE1)-DE_RHO(IX,IY,IZ,  1,LTWCE1))
     *        *(DE_SPI(IX,IY,IZ,K,0,LTWCE2)+DE_SPI(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  QPPRHC(K)=
     *        +(DE_RHO(IX,IY,IZ,  0,LTWCE1)+DE_RHO(IX,IY,IZ,  1,LTWCE1))
     *        *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)+DE_CUR(IX,IY,IZ,K,1,LTWCE2))
                  QMMRHC(K)=
     *        +(DE_RHO(IX,IY,IZ,  0,LTWCE1)-DE_RHO(IX,IY,IZ,  1,LTWCE1))
     *        *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)-DE_CUR(IX,IY,IZ,K,1,LTWCE2))
                  QPMRHC(K)=
     *        +(DE_RHO(IX,IY,IZ,  0,LTWCE1)+DE_RHO(IX,IY,IZ,  1,LTWCE1))
     *        *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)-DE_CUR(IX,IY,IZ,K,1,LTWCE2))
                  QMPRHC(K)=
     *        +(DE_RHO(IX,IY,IZ,  0,LTWCE1)-DE_RHO(IX,IY,IZ,  1,LTWCE1))
     *        *(DE_CUR(IX,IY,IZ,K,0,LTWCE2)+DE_CUR(IX,IY,IZ,K,1,LTWCE2))
C
C=======================================================================
C
                  DO L=1,NDKART
C
                     QUNSCU=QUNSCU + DE_SCU(IX,IY,IZ,K,L,0,LTWCE1)
     *                             * DE_SCU(IX,IY,IZ,K,L,0,LTWCE2)
                     QUPSCU=QUPSCU + DE_SCU(IX,IY,IZ,K,L,1,LTWCE1)
     *                             * DE_SCU(IX,IY,IZ,K,L,1,LTWCE2)
C
                     QUTSCU=QUTSCU +(DE_SCU(IX,IY,IZ,K,L,0,LTWCE1)
     *                             + DE_SCU(IX,IY,IZ,K,L,1,LTWCE1))
     *
     *                             *(DE_SCU(IX,IY,IZ,K,L,0,LTWCE2)
     *                             + DE_SCU(IX,IY,IZ,K,L,1,LTWCE2))
C
C=======================================================================
C
                     QUNSCT=QUNSCT + DE_SCU(IX,IY,IZ,K,L,0,LTWCE1)
     *                             * DE_SCU(IX,IY,IZ,L,K,0,LTWCE2)
                     QUPSCT=QUPSCT + DE_SCU(IX,IY,IZ,K,L,1,LTWCE1)
     *                             * DE_SCU(IX,IY,IZ,L,K,1,LTWCE2)
C
                     QUTSCT=QUTSCT +(DE_SCU(IX,IY,IZ,K,L,0,LTWCE1)
     *                             + DE_SCU(IX,IY,IZ,K,L,1,LTWCE1))
     *
     *                             *(DE_SCU(IX,IY,IZ,L,K,0,LTWCE2)
     *                             + DE_SCU(IX,IY,IZ,L,K,1,LTWCE2))
C
C=======================================================================
C                 SYMMETRY-VIOLATING TERMS
C=======================================================================
C
                     QPPDES=QPPDES +(DE_DES(IX,IY,IZ,K,L,0,LTWCE1)
     *                             + DE_DES(IX,IY,IZ,K,L,1,LTWCE1))
     *
     *                             *(DE_SCU(IX,IY,IZ,K,L,0,LTWCE2)
     *                             + DE_SCU(IX,IY,IZ,K,L,1,LTWCE2))
C
                     QMMDES=QMMDES +(DE_DES(IX,IY,IZ,K,L,0,LTWCE1)
     *                             - DE_DES(IX,IY,IZ,K,L,1,LTWCE1))
     *
     *                             *(DE_SCU(IX,IY,IZ,K,L,0,LTWCE2)
     *                             - DE_SCU(IX,IY,IZ,K,L,1,LTWCE2))
C
                     QPMDES=QPMDES +(DE_DES(IX,IY,IZ,K,L,0,LTWCE1)
     *                             + DE_DES(IX,IY,IZ,K,L,1,LTWCE1))
     *
     *                             *(DE_SCU(IX,IY,IZ,K,L,0,LTWCE2)
     *                             - DE_SCU(IX,IY,IZ,K,L,1,LTWCE2))
C
                     QMPDES=QMPDES +(DE_DES(IX,IY,IZ,K,L,0,LTWCE1)
     *                             - DE_DES(IX,IY,IZ,K,L,1,LTWCE1))
     *
     *                             *(DE_SCU(IX,IY,IZ,K,L,0,LTWCE2)
     *                             + DE_SCU(IX,IY,IZ,K,L,1,LTWCE2))
C
                  END DO
C
               END DO
C
C=======================================================================
C
               QUTSPT=(QUNSPT_1+QUPSPT_1) * (QUNSPT_2+QUPSPT_2)
               QUNSPT= QUNSPT_1*QUNSPT_2
               QUPSPT= QUPSPT_1*QUPSPT_2
C
C=======================================================================
C
               QUTSC0=(QUNSC0_1+QUPSC0_1) * (QUNSC0_2+QUPSC0_2)
               QUNSC0= QUNSC0_1*QUNSC0_2
               QUPSC0= QUPSC0_1*QUPSC0_2
C
C=======================================================================
C
               QUNSCT=(QUNSCT+QUNSC0)/2
               QUPSCT=(QUPSCT+QUPSC0)/2
               QUTSCT=(QUTSCT+QUTSC0)/2
C
C=======================================================================
C
               QPPDIS=(QUNDIS_1+QUPDIS_1)*(QUNDIS_2+QUPDIS_2)
               QMMDIS=(QUNDIS_1-QUPDIS_1)*(QUNDIS_2-QUPDIS_2)
               QPMDIS=(QUNDIS_1+QUPDIS_1)*(QUNDIS_2-QUPDIS_2)
               QMPDIS=(QUNDIS_1-QUPDIS_1)*(QUNDIS_2+QUPDIS_2)
C
C=======================================================================
C
               IF (LDTWCE.EQ.1) THEN
               W_HERM=FOURWG(IX,1)*FOURWG(IY,2)*FOURWG(IZ,3)
               ELSEIF (LDTWCE.EQ.16) THEN
               W_HERM=WGHERM(IX,1)*WGHERM(IY,2)*WGHERM(IZ,3)*
     *         FACNE4(1,LTWCEN)*FACNE4(2,LTWCEN)*FACNE4(3,LTWCEN)
               ELSE
                STOP 'WRONG LDTWCE IN ESKYRM'
               END IF
C
               DENPOW=DENSIC(IX,IY,IZ,LTWCEN) ** POWER
C
C=======================================================================
C              CALCULATING THE THREE-BODY TERMS
C=======================================================================
C
               E3BEVE = E3BEVE + W_HERM * DENSIC(IX,IY,IZ,1)
     *                                  * DE_RHO(IX,IY,IZ,0,1)
     *                                  * DE_RHO(IX,IY,IZ,1,1)
C
               E3BODD = E3BODD - W_HERM * DENNEU
     *                                  *(DE_SPI(IX,IY,IZ,1,1,1)
     *                                   *DE_SPI(IX,IY,IZ,1,1,1)
     *                                   +DE_SPI(IX,IY,IZ,2,1,1)
     *                                   *DE_SPI(IX,IY,IZ,2,1,1)
     *                                   +DE_SPI(IX,IY,IZ,3,1,1)
     *                                   *DE_SPI(IX,IY,IZ,3,1,1))
C
               E3BODD = E3BODD - W_HERM * DENPRO
     *                                  *(DE_SPI(IX,IY,IZ,1,0,1)
     *                                   *DE_SPI(IX,IY,IZ,1,0,1)
     *                                   +DE_SPI(IX,IY,IZ,2,0,1)
     *                                   *DE_SPI(IX,IY,IZ,2,0,1)
     *                                   +DE_SPI(IX,IY,IZ,3,0,1)
     *                                   *DE_SPI(IX,IY,IZ,3,0,1))
C
C=======================================================================
C              CALCULATING THE FOUR-BODY TERMS
C=======================================================================
C
               E4BEVE = E4BEVE + W_HERM * DENNEU**2
     *                                  * DE_RHO(IX,IY,IZ,1,1)
     *                                  * DE_RHO(IX,IY,IZ,1,1)
C
               E4BEVE = E4BEVE + W_HERM * DENPRO**2
     *                                  * DE_RHO(IX,IY,IZ,0,1)
     *                                  * DE_RHO(IX,IY,IZ,0,1)
C
               E4BODD = E4BODD - W_HERM * 2 * DENNEU**2
     *                                  *(DE_SPI(IX,IY,IZ,1,1,1)
     *                                   *DE_SPI(IX,IY,IZ,1,1,1)
     *                                   +DE_SPI(IX,IY,IZ,2,1,1)
     *                                   *DE_SPI(IX,IY,IZ,2,1,1)
     *                                   +DE_SPI(IX,IY,IZ,3,1,1)
     *                                   *DE_SPI(IX,IY,IZ,3,1,1))
C
               E4BODD = E4BODD - W_HERM * 2 * DENPRO**2
     *                                  *(DE_SPI(IX,IY,IZ,1,0,1)
     *                                   *DE_SPI(IX,IY,IZ,1,0,1)
     *                                   +DE_SPI(IX,IY,IZ,2,0,1)
     *                                   *DE_SPI(IX,IY,IZ,2,0,1)
     *                                   +DE_SPI(IX,IY,IZ,3,0,1)
     *                                   *DE_SPI(IX,IY,IZ,3,0,1))
C
               E4BODD = E4BODD + W_HERM *(SPINEU(1)**2
     *                                   +SPINEU(2)**2
     *                                   +SPINEU(3)**2)
     *                                  *(DE_SPI(IX,IY,IZ,1,1,1)
     *                                   *DE_SPI(IX,IY,IZ,1,1,1)
     *                                   +DE_SPI(IX,IY,IZ,2,1,1)
     *                                   *DE_SPI(IX,IY,IZ,2,1,1)
     *                                   +DE_SPI(IX,IY,IZ,3,1,1)
     *                                   *DE_SPI(IX,IY,IZ,3,1,1))
C
               E4BODD = E4BODD + W_HERM *(SPIPRO(1)**2
     *                                   +SPIPRO(2)**2
     *                                   +SPIPRO(3)**2)
     *                                  *(DE_SPI(IX,IY,IZ,1,0,1)
     *                                   *DE_SPI(IX,IY,IZ,1,0,1)
     *                                   +DE_SPI(IX,IY,IZ,2,0,1)
     *                                   *DE_SPI(IX,IY,IZ,2,0,1)
     *                                   +DE_SPI(IX,IY,IZ,3,0,1)
     *                                   *DE_SPI(IX,IY,IZ,3,0,1))
C
C=======================================================================
C              CALCULATING THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
               DO ICHARG=0,NDISOS
                   DO ICHARP=0,NDISOS
C
                      DR_CBR(ICHARG,ICHARP,0)=
     *                DR_CBR(ICHARG,ICHARP,0)+W_HERM
     *                                       *DE_RHO(IX,IY,IZ,ICHARG,1)
     *                                       *DE_RHO(IX,IY,IZ,ICHARP,1)
C
                      DS_CBR(ICHARG,ICHARP,0)=
     *                DS_CBR(ICHARG,ICHARP,0)+W_HERM *
     *                                      (DE_SPI(IX,IY,IZ,1,ICHARG,1)
     *                                      *DE_SPI(IX,IY,IZ,1,ICHARP,1)
     *                                      +DE_SPI(IX,IY,IZ,2,ICHARG,1)
     *                                      *DE_SPI(IX,IY,IZ,2,ICHARP,1)
     *                                      +DE_SPI(IX,IY,IZ,3,ICHARG,1)
     *                                     *DE_SPI(IX,IY,IZ,3,ICHARP,1))
C
                      DT_CBR(ICHARG,ICHARP,0)=
     *                DT_CBR(ICHARG,ICHARP,0)+W_HERM
     *                                       *DE_RHO(IX,IY,IZ,ICHARG,1)
     *                                       *DE_TAU(IX,IY,IZ,ICHARP,1)
C
                      DK_CBR(ICHARG,ICHARP,0)=
     *                DK_CBR(ICHARG,ICHARP,0)+W_HERM *
     *                                     (DE_SPI(IX,IY,IZ,1,ICHARG,1)
     *                                     *DE_KIS(IX,IY,IZ,1,ICHARP,1)
     *                                     +DE_SPI(IX,IY,IZ,2,ICHARG,1)
     *                                     *DE_KIS(IX,IY,IZ,2,ICHARP,1)
     *                                     +DE_SPI(IX,IY,IZ,3,ICHARG,1)
     *                                     *DE_KIS(IX,IY,IZ,3,ICHARP,1))
C
                      DL_CBR(ICHARG,ICHARP,0)=
     *                DL_CBR(ICHARG,ICHARP,0)+W_HERM
     *                                       *DE_RHO(IX,IY,IZ,ICHARG,1)
     *                                       *DE_LPR(IX,IY,IZ,ICHARP,1)
C
                      DP_CBR(ICHARG,ICHARP,0)=
     *                DP_CBR(ICHARG,ICHARP,0)+W_HERM *
     *                                     (DE_SPI(IX,IY,IZ,1,ICHARG,1)
     *                                     *DE_LPS(IX,IY,IZ,1,ICHARP,1)
     *                                     +DE_SPI(IX,IY,IZ,2,ICHARG,1)
     *                                     *DE_LPS(IX,IY,IZ,2,ICHARP,1)
     *                                     +DE_SPI(IX,IY,IZ,3,ICHARG,1)
     *                                     *DE_LPS(IX,IY,IZ,3,ICHARP,1))
C
                      DC_CBR(ICHARG,ICHARP,0)=
     *                DC_CBR(ICHARG,ICHARP,0)+W_HERM *
     *                                     (DE_CUR(IX,IY,IZ,1,ICHARG,1)
     *                                     *DE_CUR(IX,IY,IZ,1,ICHARP,1)
     *                                     +DE_CUR(IX,IY,IZ,2,ICHARG,1)
     *                                     *DE_CUR(IX,IY,IZ,2,ICHARP,1)
     *                                     +DE_CUR(IX,IY,IZ,3,ICHARG,1)
     *                                     *DE_CUR(IX,IY,IZ,3,ICHARP,1))
C
                      DJ_CBR(ICHARG,ICHARP,0)=
     *                DJ_CBR(ICHARG,ICHARP,0)+W_HERM *
     *                                   (DE_SCU(IX,IY,IZ,1,1,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,1,1,ICHARP,1)
     *                                   +DE_SCU(IX,IY,IZ,1,2,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,1,2,ICHARP,1)
     *                                   +DE_SCU(IX,IY,IZ,1,3,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,1,3,ICHARP,1)
     *                                   +DE_SCU(IX,IY,IZ,2,1,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,2,1,ICHARP,1)
     *                                   +DE_SCU(IX,IY,IZ,2,2,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,2,2,ICHARP,1)
     *                                   +DE_SCU(IX,IY,IZ,2,3,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,2,3,ICHARP,1)
     *                                   +DE_SCU(IX,IY,IZ,3,1,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,3,1,ICHARP,1)
     *                                   +DE_SCU(IX,IY,IZ,3,2,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,3,2,ICHARP,1)
     *                                   +DE_SCU(IX,IY,IZ,3,3,ICHARG,1)
     *                                   *DE_SCU(IX,IY,IZ,3,3,ICHARP,1))
C
                   END DO
               END DO
C
C=======================================================================
C              CALCULATING THE T0-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZRHO_T = ZRHO_T + W_HERM *  QUTRHO
               ZRHO_S = ZRHO_S + W_HERM * (QUNRHO + QUPRHO)
C
               ZSPI_T = ZSPI_T + W_HERM *  QUTSPI
               ZSPI_S = ZSPI_S + W_HERM * (QUNSPI + QUPSPI)
C
C=======================================================================
C              CALCULATING THE T1-T2-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZLPR_T = ZLPR_T + W_HERM *  QUTLPR
               ZLPR_S = ZLPR_S + W_HERM * (QUNLPR + QUPLPR)
C
               ZTAU_T = ZTAU_T + W_HERM *  QUTTAU
               ZTAU_S = ZTAU_S + W_HERM * (QUNTAU + QUPTAU)
C
               ZCUR_T = ZCUR_T + W_HERM *  QUTCUR
               ZCUR_S = ZCUR_S + W_HERM * (QUNCUR + QUPCUR)
C
               ZLPS_T = ZLPS_T + W_HERM *  QUTLPS
               ZLPS_S = ZLPS_S + W_HERM * (QUNLPS + QUPLPS)
C
               ZKIS_T = ZKIS_T + W_HERM *  QUTKIS
               ZKIS_S = ZKIS_S + W_HERM * (QUNKIS + QUPKIS)
C
               ZSCU_T = ZSCU_T + W_HERM *  QUTSCU
               ZSCU_S = ZSCU_S + W_HERM * (QUNSCU + QUPSCU)
C
C              FOR PRINTING, TERMS BELOW ARE CALCULATED SEPARATELY, EVEN
C              THOUGH THEY HAVE ALREADY BE INCLUDED IN THE CENTRAL TERMS
C
               XLPSET = XLPSET + W_HERM *  QUTLPS
               XLPSES = XLPSES + W_HERM * (QUNLPS + QUPLPS)
C
               XKISET = XKISET + W_HERM *  QUTKIS
               XKISES = XKISES + W_HERM * (QUNKIS + QUPKIS)
C
               XSCUET = XSCUET + W_HERM *  QUTSCU
               XSCUES = XSCUES + W_HERM * (QUNSCU + QUPSCU)
C
               XLPSOT = XLPSOT + W_HERM *  QUTLPS
               XLPSOS = XLPSOS + W_HERM * (QUNLPS + QUPLPS)
C
               XKISOT = XKISOT + W_HERM *  QUTKIS
               XKISOS = XKISOS + W_HERM * (QUNKIS + QUPKIS)
C
               XSCUOT = XSCUOT + W_HERM *  QUTSCU
               XSCUOS = XSCUOS + W_HERM * (QUNSCU + QUPSCU)
C
C=======================================================================
C              CALCULATING THE T3-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZRHODT = ZRHODT + W_HERM *  QUTRHO
     *                                  *  DENPOW
               ZRHODS = ZRHODS + W_HERM * (QUNRHO + QUPRHO)
     *                                  *  DENPOW
               ZSPIDT = ZSPIDT + W_HERM *  QUTSPI
     *                                  *  DENPOW
               ZSPIDS = ZSPIDS + W_HERM * (QUNSPI + QUPSPI)
     *                                  *  DENPOW
C
               ENREAR = ENREAR + W_HERM * REAL(
     *                                   (CRHODT * QUTRHO
     *                                  + CRHODS *(QUNRHO + QUPRHO)
     *
     *                                  + CSPIDT * QUTSPI
     *                                  + CSPIDS *(QUNSPI + QUPSPI))
     *
     *                                  * DENPOW * (POWER/2))
C
C=======================================================================
C              CALCULATING THE W0-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZDIV_T = ZDIV_T + W_HERM *  QUTDIV
               ZDIV_S = ZDIV_S + W_HERM * (QUNDIV + QUPDIV)
C
               ZROT_T = ZROT_T + W_HERM *  QUTROT
               ZROT_S = ZROT_S + W_HERM * (QUNROT + QUPROT)
C
C=======================================================================
C              CALCULATING THE TE-TO-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZSCT_T = ZSCT_T + W_HERM *  QUTSCT
               ZSCT_S = ZSCT_S + W_HERM * (QUNSCT + QUPSCT)
C
               ZKIT_T = ZKIT_T + W_HERM *  QUTKIT
               ZKIT_S = ZKIT_S + W_HERM * (QUNKIT + QUPKIT)
C
               ZSPT_T = ZSPT_T + W_HERM *  QUTSPT
               ZSPT_S = ZSPT_S + W_HERM * (QUNSPT + QUPSPT)
C
C              FOR PRINTING, TERMS BELOW ARE CALCULATED SEPARATELY, EVEN
C              THOUGH THEY HAVE ALREADY BE INCLUDED IN THE TENSOR  TERMS
C
               XSCTET = XSCTET + W_HERM *  QUTSCT
               XSCTES = XSCTES + W_HERM * (QUNSCT + QUPSCT)
C
               XKITET = XKITET + W_HERM *  QUTKIT
               XKITES = XKITES + W_HERM * (QUNKIT + QUPKIT)
C
               XSPTET = XSPTET + W_HERM *  QUTSPT
               XSPTES = XSPTES + W_HERM * (QUNSPT + QUPSPT)
C
               XSCTOT = XSCTOT + W_HERM *  QUTSCT
               XSCTOS = XSCTOS + W_HERM * (QUNSCT + QUPSCT)
C
               XKITOT = XKITOT + W_HERM *  QUTKIT
               XKITOS = XKITOS + W_HERM * (QUNKIT + QUPKIT)
C
               XSPTOT = XSPTOT + W_HERM *  QUTSPT
               XSPTOS = XSPTOS + W_HERM * (QUNSPT + QUPSPT)
C
C=======================================================================
C              CALCULATING THE SYMMETRY-VIOLATING TERMS
C=======================================================================
C
               DSCRPP = DSCRPP + W_HERM * REAL(QPPSCR)
               DSCRMM = DSCRMM + W_HERM * REAL(QMMSCR)
               DSCRPM = DSCRPM + W_HERM * REAL(QPMSCR)
               DSCRMP = DSCRMP + W_HERM * REAL(QMPSCR)
C
               DDISPP = DDISPP + W_HERM * REAL(QPPDIS)
               DDISMM = DDISMM + W_HERM * REAL(QMMDIS)
               DDISPM = DDISPM + W_HERM * REAL(QPMDIS)
               DDISMP = DDISMP + W_HERM * REAL(QMPDIS)
C
               DDSRPP = DDSRPP + W_HERM * REAL(QPPDSR)
               DDSRMM = DDSRMM + W_HERM * REAL(QMMDSR)
               DDSRPM = DDSRPM + W_HERM * REAL(QPMDSR)
               DDSRMP = DDSRMP + W_HERM * REAL(QMPDSR)
C
               DSCSPP = DSCSPP + W_HERM * REAL(QPPSCS)
               DSCSMM = DSCSMM + W_HERM * REAL(QMMSCS)
               DSCSPM = DSCSPM + W_HERM * REAL(QPMSCS)
               DSCSMP = DSCSMP + W_HERM * REAL(QMPSCS)
C
               DSCJPP = DSCJPP + W_HERM * REAL(QPPSCJ)
               DSCJMM = DSCJMM + W_HERM * REAL(QMMSCJ)
               DSCJPM = DSCJPM + W_HERM * REAL(QPMSCJ)
               DSCJMP = DSCJMP + W_HERM * REAL(QMPSCJ)
C
               DCUSPP = DCUSPP + W_HERM * REAL(QPPCUS)
               DCUSMM = DCUSMM + W_HERM * REAL(QMMCUS)
               DCUSPM = DCUSPM + W_HERM * REAL(QPMCUS)
               DCUSMP = DCUSMP + W_HERM * REAL(QMPCUS)
C
               DROSPP = DROSPP + W_HERM * REAL(QPPROS)
               DROSMM = DROSMM + W_HERM * REAL(QMMROS)
               DROSPM = DROSPM + W_HERM * REAL(QPMROS)
               DROSMP = DROSMP + W_HERM * REAL(QMPROS)
C
               DDESPP = DDESPP + W_HERM * REAL(QPPDES)
               DDESMM = DDESMM + W_HERM * REAL(QMMDES)
               DDESPM = DDESPM + W_HERM * REAL(QPMDES)
               DDESMP = DDESMP + W_HERM * REAL(QMPDES)
C
               XRHSPP = XRHSPP + W_HERM * REAL(QPPRHS(1))
               XRHSMM = XRHSMM + W_HERM * REAL(QMMRHS(1))
               XRHSPM = XRHSPM + W_HERM * REAL(QPMRHS(1))
               XRHSMP = XRHSMP + W_HERM * REAL(QMPRHS(1))
C
               XRHCPP = XRHCPP + W_HERM * REAL(QPPRHC(1))
               XRHCMM = XRHCMM + W_HERM * REAL(QMMRHC(1))
               XRHCPM = XRHCPM + W_HERM * REAL(QPMRHC(1))
               XRHCMP = XRHCMP + W_HERM * REAL(QMPRHC(1))
C
               YRHSPP = YRHSPP + W_HERM * REAL(QPPRHS(2))
               YRHSMM = YRHSMM + W_HERM * REAL(QMMRHS(2))
               YRHSPM = YRHSPM + W_HERM * REAL(QPMRHS(2))
               YRHSMP = YRHSMP + W_HERM * REAL(QMPRHS(2))
C
               YRHCPP = YRHCPP + W_HERM * REAL(QPPRHC(2))
               YRHCMM = YRHCMM + W_HERM * REAL(QMMRHC(2))
               YRHCPM = YRHCPM + W_HERM * REAL(QPMRHC(2))
               YRHCMP = YRHCMP + W_HERM * REAL(QMPRHC(2))
C
               ZRHSPP = ZRHSPP + W_HERM * REAL(QPPRHS(3))
               ZRHSMM = ZRHSMM + W_HERM * REAL(QMMRHS(3))
               ZRHSPM = ZRHSPM + W_HERM * REAL(QPMRHS(3))
               ZRHSMP = ZRHSMP + W_HERM * REAL(QMPRHS(3))
C
               ZRHCPP = ZRHCPP + W_HERM * REAL(QPPRHC(3))
               ZRHCMM = ZRHCMM + W_HERM * REAL(QMMRHC(3))
               ZRHCPM = ZRHCPM + W_HERM * REAL(QPMRHC(3))
               ZRHCMP = ZRHCMP + W_HERM * REAL(QMPRHC(3))
C
            END DO
         END DO
      END DO
C
C=======================================================================
C     HERE ENDS THE TWO-CENTRE LOOP
C=======================================================================
C
      END DO
C
C=======================================================================
C              PARTIAL SUMMATIONS OF TERMS IN ENERGY
C=======================================================================
C
      DO NUCOUT=1,NDCOUT
         DCPALL(NUCOUT)=REAL(ZCPALL(NUCOUT))
         ECPALL(NUCOUT)=CCPALL(NUCOUT)*DCPALL(NUCOUT)
         ENESKY        =ENESKY        +ECPALL(NUCOUT)
         EKESKY        =EKESKY
     *                 +CCPALL(NUCOUT)*ZCPALL(NUCOUT)
         ECCALL(NUCOUT)=CCPALL(NUCOUT)*ZCPALL(NUCOUT)
      END DO
C
      ENEVEN=0.0D0
      ENEODD=0.0D0
C
      DO NUCOUP=1,NDCOUP/2
C
         ENEVEN=ENEVEN+ECPALL(NUCOUP)
         ENEODD=ENEODD+ECPALL(NUCOUP+NDCOUP/2)
C
      END DO
C
C=======================================================================
C              ADDING TERMS CORRESPONDING TO THE TENSOR COUPLING
C              CONSTANTS "SCT", "KIT", AND "SPT"
C=======================================================================
C
      ENEVEN=ENEVEN+ECPALL(NDCOUP+1)+ECPALL(NDCOUP+2)
      ENEODD=ENEODD+ECPALL(NDCOUP+3)+ECPALL(NDCOUP+4)
     *             +ECPALL(NDCOUP+5)+ECPALL(NDCOUP+6)
C
C=======================================================================
C              FOR PRINTING, CALCULATING TERMS CORRESPONDING TO THE
C              TENSOR COUPLING CONSTANTS "TLPS", "TKIS", AND "TSCU"
C              THAT HAVE ALREADY BEEN INCLUDED IN THE CENTRAL TERMS
C=======================================================================
C
      ETEVEN=TSCUET*REAL(XSCUET)+TSCUES*REAL(XSCUES)
     *      +TSCTET*REAL(XSCTET)+TSCTES*REAL(XSCTES)
      ETEODD=TLPSET*REAL(XLPSET)+TLPSES*REAL(XLPSES)
     *      +TKISET*REAL(XKISET)+TKISES*REAL(XKISES)
     *      +TSPTET*REAL(XSPTET)+TSPTES*REAL(XSPTES)
     *      +TKITET*REAL(XKITET)+TKITES*REAL(XKITES)
C
      ETOVEN=TSCUOT*REAL(XSCUOT)+TSCUOS*REAL(XSCUOS)
     *      +TSCTOT*REAL(XSCTOT)+TSCTOS*REAL(XSCTOS)
      ETOODD=TLPSOT*REAL(XLPSOT)+TLPSOS*REAL(XLPSOS)
     *      +TKISOT*REAL(XKISOT)+TKISOS*REAL(XKISOS)
     *      +TSPTOT*REAL(XSPTOT)+TSPTOS*REAL(XSPTOS)
     *      +TKITOT*REAL(XKITOT)+TKITOS*REAL(XKITOS)
C
C=======================================================================
C              ADDING TERMS CORRESPONDING TO THE SPIN-ORBIT INTERACTION
C=======================================================================
C
      EEVEW0=EDIV_T+EDIV_S
      EODDW0=EROT_T+EROT_S
C
      ENE_W0=EEVEW0+EODDW0
C
C=======================================================================
C        CALCULATING TERMS CORRESPONDING TO THE THREE-BODY CONTACT LO
C=======================================================================
C
      E3BEVE = 3*THREEB/4 * E3BEVE
      E3BODD = 3*THREEB/4 * E3BODD
C
C=======================================================================
C        CALCULATING TERMS CORRESPONDING TO THE THREE-BODY GRADIENTS
C=======================================================================
C        ATTENTION: HERE BOTH PARTICLE-HOLE AND PAIRING ENERGIES ARE
C                   CALCULATED.
C=======================================================================
C
      ETGRAF=0.0D0
      ETGRAP=0.0D0
C
      IF (IGRAIN.EQ.1) CALL ETGRAD(ETGRAF,ETGRAP)
C
C=======================================================================
C        CALCULATING TERMS CORRESPONDING TO THE FOUR-BODY CONTACT LO
C=======================================================================
C
      E4BEVE = 3*FOURBD/8 * E4BEVE
      E4BODD = 3*FOURBD/8 * E4BODD
C
C=======================================================================
C              ADDING THE ISOSPIN-SYMMETRY-BREAKING INTERACTION
C=======================================================================
C
      FR2CBR=C_ZERO
      FS2CBR=C_ZERO
      FT2CBR=C_ZERO
      FK2CBR=C_ZERO
      FL2CBR=C_ZERO
      FP2CBR=C_ZERO
      FC2CBR=C_ZERO
      FJ2CBR=C_ZERO
C
      FR3CBR=C_ZERO
      FS3CBR=C_ZERO
      FT3CBR=C_ZERO
      FK3CBR=C_ZERO
      FL3CBR=C_ZERO
      FP3CBR=C_ZERO
      FC3CBR=C_ZERO
      FJ3CBR=C_ZERO
C
      HR2CBR=0.0D0
      HS2CBR=0.0D0
      HT2CBR=0.0D0
      HK2CBR=0.0D0
      HL2CBR=0.0D0
      HP2CBR=0.0D0
      HC2CBR=0.0D0
      HJ2CBR=0.0D0
C
      HR3CBR=0.0D0
      HS3CBR=0.0D0
      HT3CBR=0.0D0
      HK3CBR=0.0D0
      HL3CBR=0.0D0
      HP3CBR=0.0D0
      HC3CBR=0.0D0
      HJ3CBR=0.0D0
C
      DO ICHARG=0,NDISOS
          DO ICHARP=0,NDISOS
C
             ER2CBR(ICHARG,ICHARP,0)=CR2CBR(ICHARG,ICHARP,0)
     *                              *DR_CBR(ICHARG,ICHARP,0)
             ES2CBR(ICHARG,ICHARP,0)=CS2CBR(ICHARG,ICHARP,0)
     *                              *DS_CBR(ICHARG,ICHARP,0)
             ET2CBR(ICHARG,ICHARP,0)=CT2CBR(ICHARG,ICHARP,0)
     *                              *DT_CBR(ICHARG,ICHARP,0)
             EK2CBR(ICHARG,ICHARP,0)=CK2CBR(ICHARG,ICHARP,0)
     *                              *DK_CBR(ICHARG,ICHARP,0)
             EL2CBR(ICHARG,ICHARP,0)=CL2CBR(ICHARG,ICHARP,0)
     *                              *DL_CBR(ICHARG,ICHARP,0)
             EP2CBR(ICHARG,ICHARP,0)=CP2CBR(ICHARG,ICHARP,0)
     *                              *DP_CBR(ICHARG,ICHARP,0)
             EC2CBR(ICHARG,ICHARP,0)=CC2CBR(ICHARG,ICHARP,0)
     *                              *DC_CBR(ICHARG,ICHARP,0)
             EJ2CBR(ICHARG,ICHARP,0)=CJ2CBR(ICHARG,ICHARP,0)
     *                              *DJ_CBR(ICHARG,ICHARP,0)
C
             ER3CBR(ICHARG,ICHARP,0)=CR3CBR(ICHARG,ICHARP,0)
     *                              *DR_CBR(ICHARG,ICHARP,0)
             ES3CBR(ICHARG,ICHARP,0)=CS3CBR(ICHARG,ICHARP,0)
     *                              *DS_CBR(ICHARG,ICHARP,0)
             ET3CBR(ICHARG,ICHARP,0)=CT3CBR(ICHARG,ICHARP,0)
     *                              *DT_CBR(ICHARG,ICHARP,0)
             EK3CBR(ICHARG,ICHARP,0)=CK3CBR(ICHARG,ICHARP,0)
     *                              *DK_CBR(ICHARG,ICHARP,0)
             EL3CBR(ICHARG,ICHARP,0)=CL3CBR(ICHARG,ICHARP,0)
     *                              *DL_CBR(ICHARG,ICHARP,0)
             EP3CBR(ICHARG,ICHARP,0)=CP3CBR(ICHARG,ICHARP,0)
     *                              *DP_CBR(ICHARG,ICHARP,0)
             EC3CBR(ICHARG,ICHARP,0)=CC3CBR(ICHARG,ICHARP,0)
     *                              *DC_CBR(ICHARG,ICHARP,0)
             EJ3CBR(ICHARG,ICHARP,0)=CJ3CBR(ICHARG,ICHARP,0)
     *                              *DJ_CBR(ICHARG,ICHARP,0)
C
             FR2CBR=FR2CBR+ER2CBR(ICHARG,ICHARP,0)
             FS2CBR=FS2CBR+ES2CBR(ICHARG,ICHARP,0)
             FT2CBR=FT2CBR+ET2CBR(ICHARG,ICHARP,0)
             FK2CBR=FK2CBR+EK2CBR(ICHARG,ICHARP,0)
             FL2CBR=FL2CBR+EL2CBR(ICHARG,ICHARP,0)
             FP2CBR=FP2CBR+EP2CBR(ICHARG,ICHARP,0)
             FC2CBR=FC2CBR+EC2CBR(ICHARG,ICHARP,0)
             FJ2CBR=FJ2CBR+EJ2CBR(ICHARG,ICHARP,0)
C
             FR3CBR=FR3CBR+ER3CBR(ICHARG,ICHARP,0)
             FS3CBR=FS3CBR+ES3CBR(ICHARG,ICHARP,0)
             FT3CBR=FT3CBR+ET3CBR(ICHARG,ICHARP,0)
             FK3CBR=FK3CBR+EK3CBR(ICHARG,ICHARP,0)
             FL3CBR=FL3CBR+EL3CBR(ICHARG,ICHARP,0)
             FP3CBR=FP3CBR+EP3CBR(ICHARG,ICHARP,0)
             FC3CBR=FC3CBR+EC3CBR(ICHARG,ICHARP,0)
             FJ3CBR=FJ3CBR+EJ3CBR(ICHARG,ICHARP,0)
C
             DO IGR=0,2
                HR3CBR(IGR)= HR3CBR(IGR) + GR3CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DR_CBR(ICHARG,ICHARP,0))
                HS3CBR(IGR)= HS3CBR(IGR) + GS3CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DS_CBR(ICHARG,ICHARP,0))
                HT3CBR(IGR)= HT3CBR(IGR) + GT3CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DT_CBR(ICHARG,ICHARP,0))
                HK3CBR(IGR)= HK3CBR(IGR) + GK3CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DK_CBR(ICHARG,ICHARP,0))
                HL3CBR(IGR)= HL3CBR(IGR) + GL3CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DL_CBR(ICHARG,ICHARP,0))
                HP3CBR(IGR)= HP3CBR(IGR) + GP3CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DP_CBR(ICHARG,ICHARP,0))
                HC3CBR(IGR)= HC3CBR(IGR) + GC3CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DC_CBR(ICHARG,ICHARP,0))
                HJ3CBR(IGR)= HJ3CBR(IGR) + GJ3CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DJ_CBR(ICHARG,ICHARP,0))
             END DO
C
              DO IGR=0,2
                HR2CBR(IGR)= HR2CBR(IGR) + GR2CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DR_CBR(ICHARG,ICHARP,0))
                HS2CBR(IGR)= HS2CBR(IGR) + GS2CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DS_CBR(ICHARG,ICHARP,0))
                HT2CBR(IGR)= HT2CBR(IGR) + GT2CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DT_CBR(ICHARG,ICHARP,0))
                HK2CBR(IGR)= HK2CBR(IGR) + GK2CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DK_CBR(ICHARG,ICHARP,0))
                HL2CBR(IGR)= HL2CBR(IGR) + GL2CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DL_CBR(ICHARG,ICHARP,0))
                HP2CBR(IGR)= HP2CBR(IGR) + GP2CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DP_CBR(ICHARG,ICHARP,0))
                HC2CBR(IGR)= HC2CBR(IGR) + GC2CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DC_CBR(ICHARG,ICHARP,0))
                HJ2CBR(IGR)= HJ2CBR(IGR) + GJ2CBR(ICHARG,ICHARP,0,IGR)
     *                                   * REAL(DJ_CBR(ICHARG,ICHARP,0))
              END DO
C
          END DO
      END DO
C
C=======================================================================
      DEALLOCATE(DE_ROJ)
C=======================================================================
C
      CALL CPUTIM('ESKYRM',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ESKYNP(ENESKY,ENEVEN,ENEODD,ENREAR,ENE_W0,EEVEW0,
     *                                       EODDW0,EKESKY,LDPNMX)
C=======================================================================
      USE HE_DEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          CCPALL(NDCOUT)
      COMPLEX
     *          ZCPALL(NDCOUT)
      COMPLEX
     *          EKESKY,C_ZERO
      COMPLEX
     *          ECC_NP
      COMPLEX
     *          DR_CBR,DS_CBR,
     *          DT_CBR,DK_CBR,
     *          DL_CBR,DP_CBR,
     *          DC_CBR,DJ_CBR
      COMPLEX
     *          ER2CBR,ES2CBR,
     *          ET2CBR,EK2CBR,
     *          EL2CBR,EP2CBR,
     *          EC2CBR,EJ2CBR
      COMPLEX
     *          FR2CBR,FS2CBR,FR3CBR,FS3CBR,
     *          FT2CBR,FK2CBR,FT3CBR,FK3CBR,
     *          FL2CBR,FP2CBR,FL3CBR,FP3CBR,
     *          FC2CBR,FJ2CBR,FC3CBR,FJ3CBR
C
      EQUIVALENCE
     *            (CCPALL,CRHO_T)
      EQUIVALENCE
     *            (ZCPALL,ZRHO_J)
C
      COMPLEX
     *          QUNRHO,
     *          QUNLPR,
     *          QUNTAU,
     *          QUNSCU,
     *          QUNDIV,
     *          QUNSPI,
     *          QUNLPS,
     *          QUNCUR,
     *          QUNKIS,
     *          QUNROT
      COMPLEX
     *          ZRHO_J,ZRHO_I,ZRHODJ,ZRHODI,
     *          ZLPR_J,ZLPR_I,
     *          ZTAU_J,ZTAU_I,
     *          ZSCU_J,ZSCU_I,
     *          ZDIV_J,ZDIV_I,
     *          ZSPI_J,ZSPI_I,ZSPIDJ,ZSPIDI,
     *          ZLPS_J,ZLPS_I,
     *          ZCUR_J,ZCUR_I,
     *          ZKIS_J,ZKIS_I,
     *          ZROT_J,ZROT_I,
     *          ZSCT_J,ZSCT_I,
     *          ZKIT_J,ZKIT_I,
     *          ZSPT_J,ZSPT_I
      COMPLEX
     *          DENSIC,DENCHC,DENPOW
C
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
C
      COMMON
     *       /CCPSKY/ CRHO_T,CRHO_S,CRHODT,CRHODS,
     *                CLPR_T,CLPR_S,
     *                CTAU_T,CTAU_S,
     *                CSCU_T,CSCU_S,
     *                CDIV_T,CDIV_S,
     *                CSPI_T,CSPI_S,CSPIDT,CSPIDS,
     *                CLPS_T,CLPS_S,
     *                CCUR_T,CCUR_S,
     *                CKIS_T,CKIS_S,
     *                CROT_T,CROT_S,
     *                CSCT_T,CSCT_S,
     *                CKIT_T,CKIT_S,
     *                CSPT_T,CSPT_S
      COMMON
     *       /ZNPSKY/ ZRHO_J,ZRHO_I,ZRHODJ,ZRHODI,
     *                ZLPR_J,ZLPR_I,
     *                ZTAU_J,ZTAU_I,
     *                ZSCU_J,ZSCU_I,
     *                ZDIV_J,ZDIV_I,
     *                ZSPI_J,ZSPI_I,ZSPIDJ,ZSPIDI,
     *                ZLPS_J,ZLPS_I,
     *                ZCUR_J,ZCUR_I,
     *                ZKIS_J,ZKIS_I,
     *                ZROT_J,ZROT_I,
     *                ZSCT_J,ZSCT_I,
     *                ZKIT_J,ZKIT_I,
     *                ZSPT_J,ZSPT_I
      COMMON
     *       /ECCPNM/ ECC_NP(NDCOUT)
C
      COMMON
     *       /INTSKY/ T0,X0,T1,X1,T2,X2,T3,X3,W0,POWER
C
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /CC2CBR/ CR2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CS2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CT2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CK2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CL2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CP2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CC2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CJ2CBR(0:NDISOS,0:NDISOS,0:1)
     *       /GC2CBR/ GR2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GS2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GT2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GK2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GL2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GP2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GC2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GJ2CBR(0:NDISOS,0:NDISOS,0:1,0:2)
     *       /HC_CBR/ HR2CBR(0:2),HS2CBR(0:2),HR3CBR(0:2),HS3CBR(0:2),
     *                HT2CBR(0:2),HK2CBR(0:2),HT3CBR(0:2),HK3CBR(0:2),
     *                HL2CBR(0:2),HP2CBR(0:2),HL3CBR(0:2),HP3CBR(0:2),
     *                HC2CBR(0:2),HJ2CBR(0:2),HC3CBR(0:2),HJ3CBR(0:2)
      COMMON
     *       /DC_CBR/ DR_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DS_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DT_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DK_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DL_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DP_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DC_CBR(0:NDISOS,0:NDISOS,0:1),
     *                DJ_CBR(0:NDISOS,0:NDISOS,0:1)
      COMMON
     *       /E_2CBR/ ER2CBR(0:NDISOS,0:NDISOS,0:1),
     *                ES2CBR(0:NDISOS,0:NDISOS,0:1),
     *                ET2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EK2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EL2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EP2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EC2CBR(0:NDISOS,0:NDISOS,0:1),
     *                EJ2CBR(0:NDISOS,0:NDISOS,0:1)
      COMMON
     *       /FC_CBR/ FR2CBR,FS2CBR,FR3CBR,FS3CBR,
     *                FT2CBR,FK2CBR,FT3CBR,FK3CBR,
     *                FL2CBR,FP2CBR,FL3CBR,FP3CBR,
     *                FC2CBR,FJ2CBR,FC3CBR,FJ3CBR
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('ESKYNP',1)
C
C=======================================================================
C
      IF (LDPNMX.LT.3)
     *    STOP ' LDPNMX > 2 REQUIRED IN ESKYNP'
C
C=======================================================================
C        THE EFFECTIVE COUPLING CONSTANTS AND THE CORRESPONDING  CONTRI-
C        BUTIONS TO THE ENERGY ARE CODED AS DEFINED IN "ESKYRM"
C=======================================================================
C        ATTENTION: THIS SUBROUTINE CALCULATES INTEGRANDS THAT ARE TWICE
C                   SMALLER THAN THEY SHOULD BE, BECAUSE THEY  ARE  NEXT
C                   MULTIPLIED BY THE "PLUS" COUPLING CONSTANTS THAT ARE
C                   TWICE LARGER THAN THE ISOVECTOR COUPLING CONSTANTS.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      DO NUCOUT=1,NDCOUT
         ZCPALL(NUCOUT)=C_ZERO
      END DO
C
      DR_CBR(:,:,1)=C_ZERO
      DS_CBR(:,:,1)=C_ZERO
      DT_CBR(:,:,1)=C_ZERO
      DK_CBR(:,:,1)=C_ZERO
      DL_CBR(:,:,1)=C_ZERO
      DP_CBR(:,:,1)=C_ZERO
      DC_CBR(:,:,1)=C_ZERO
      DJ_CBR(:,:,1)=C_ZERO
C
      DO IX=1,NXHERM
         DO IY=1,NYHERM
            DO IZ=1,NZHERM
C
C=======================================================================
C        CALCULATING  THE  A U X I L I A R Y   C O N T R A C T I O N S
C=======================================================================
C
               QUNRHO = DE_RHO(IX,IY,IZ,2,1)*DE_RHO(IX,IY,IZ,3,1)*2
C
               QUNSPI = C_ZERO
C
               QUNLPR = DE_RHO(IX,IY,IZ,2,1)*DE_LPR(IX,IY,IZ,3,1)
     *                + DE_RHO(IX,IY,IZ,3,1)*DE_LPR(IX,IY,IZ,2,1)
C
               QUNTAU = DE_RHO(IX,IY,IZ,2,1)*DE_TAU(IX,IY,IZ,3,1)
     *                + DE_RHO(IX,IY,IZ,3,1)*DE_TAU(IX,IY,IZ,2,1)
C
               QUNLPS=C_ZERO
C
               QUNCUR=C_ZERO
C
               QUNKIS=C_ZERO
C
               QUNSCU=C_ZERO
C
               QUNROT=C_ZERO
C
               QUNDIV = DE_RHO(IX,IY,IZ,2,1)*DE_DIV(IX,IY,IZ,3,1)
     *                + DE_RHO(IX,IY,IZ,3,1)*DE_DIV(IX,IY,IZ,2,1)
C
               DO K=1,NDKART
C
C=======================================================================
C
                  QUNSPI=QUNSPI
     *                + DE_SPI(IX,IY,IZ,K,2,1)*DE_SPI(IX,IY,IZ,K,3,1)*2
                  QUNCUR=QUNCUR
     *                + DE_CUR(IX,IY,IZ,K,2,1)*DE_CUR(IX,IY,IZ,K,3,1)*2
                  QUNLPS=QUNLPS
     *                + DE_SPI(IX,IY,IZ,K,2,1)*DE_LPS(IX,IY,IZ,K,3,1)
     *                + DE_SPI(IX,IY,IZ,K,3,1)*DE_LPS(IX,IY,IZ,K,2,1)
                  QUNKIS=QUNKIS
     *                + DE_SPI(IX,IY,IZ,K,2,1)*DE_KIS(IX,IY,IZ,K,3,1)
     *                + DE_SPI(IX,IY,IZ,K,3,1)*DE_KIS(IX,IY,IZ,K,2,1)
                  QUNROT=QUNROT
     *                + DE_SPI(IX,IY,IZ,K,2,1)*DE_ROC(IX,IY,IZ,K,3,1)
     *                + DE_SPI(IX,IY,IZ,K,3,1)*DE_ROC(IX,IY,IZ,K,2,1)
C
C=======================================================================
C
                  DO L=1,NDKART
C
                     QUNSCU=QUNSCU + DE_SCU(IX,IY,IZ,K,L,2,1)
     *                             * DE_SCU(IX,IY,IZ,K,L,3,1)*2
C
                  END DO
               END DO
C
C=======================================================================
C
               W_HERM=FOURWG(IX,1)*FOURWG(IY,2)*FOURWG(IZ,3)
C
               DENPOW=DENSIC(IX,IY,IZ,1) ** POWER
C
C=======================================================================
C              CALCULATING THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C              HERE WE CALCULATE INTEGRALS OF DENSITIES THAT BREAK THE
C              NEUTRON-PROTON SYMMETRY, AND ARE CONTAINED IN  MATRICES
C              DE_RHO AND DE_SPI FOR THE LAST INDICES EQUAL 2 AND 3.
C=======================================================================
C
               DO ICHARG=0,NDISOS
                   DO ICHARP=0,NDISOS
C
                    DR_CBR(ICHARG,ICHARP,1)=
     *              DR_CBR(ICHARG,ICHARP,1)+W_HERM
     *                                     *DE_RHO(IX,IY,IZ,ICHARG+2,1)
     *                                     *DE_RHO(IX,IY,IZ,ICHARP+2,1)
C
                    DS_CBR(ICHARG,ICHARP,1)=
     *              DS_CBR(ICHARG,ICHARP,1)+W_HERM *
     *                                   (DE_SPI(IX,IY,IZ,1,ICHARG+2,1)
     *                                   *DE_SPI(IX,IY,IZ,1,ICHARP+2,1)
     *                                   +DE_SPI(IX,IY,IZ,2,ICHARG+2,1)
     *                                   *DE_SPI(IX,IY,IZ,2,ICHARP+2,1)
     *                                   +DE_SPI(IX,IY,IZ,3,ICHARG+2,1)
     *                                   *DE_SPI(IX,IY,IZ,3,ICHARP+2,1))
C
                    DT_CBR(ICHARG,ICHARP,1)=
     *              DT_CBR(ICHARG,ICHARP,1)+W_HERM
     *                                     *DE_RHO(IX,IY,IZ,ICHARG+2,1)
     *                                     *DE_TAU(IX,IY,IZ,ICHARP+2,1)
C
                    DK_CBR(ICHARG,ICHARP,1)=
     *              DK_CBR(ICHARG,ICHARP,1)+W_HERM *
     *                                   (DE_SPI(IX,IY,IZ,1,ICHARG+2,1)
     *                                   *DE_KIS(IX,IY,IZ,1,ICHARP+2,1)
     *                                   +DE_SPI(IX,IY,IZ,2,ICHARG+2,1)
     *                                   *DE_KIS(IX,IY,IZ,2,ICHARP+2,1)
     *                                   +DE_SPI(IX,IY,IZ,3,ICHARG+2,1)
     *                                   *DE_KIS(IX,IY,IZ,3,ICHARP+2,1))
C
                    DL_CBR(ICHARG,ICHARP,1)=
     *              DL_CBR(ICHARG,ICHARP,1)+W_HERM
     *                                     *DE_RHO(IX,IY,IZ,ICHARG+2,1)
     *                                     *DE_LPR(IX,IY,IZ,ICHARP+2,1)
C
                    DP_CBR(ICHARG,ICHARP,1)=
     *              DP_CBR(ICHARG,ICHARP,1)+W_HERM *
     *                                  (DE_SPI(IX,IY,IZ,1,ICHARG+2,1)
     *                                  *DE_LPS(IX,IY,IZ,1,ICHARP+2,1)
     *                                  +DE_SPI(IX,IY,IZ,2,ICHARG+2,1)
     *                                  *DE_LPS(IX,IY,IZ,2,ICHARP+2,1)
     *                                  +DE_SPI(IX,IY,IZ,3,ICHARG+2,1)
     *                                  *DE_LPS(IX,IY,IZ,3,ICHARP+2,1))
C
                    DC_CBR(ICHARG,ICHARP,1)=
     *              DC_CBR(ICHARG,ICHARP,1)+W_HERM *
     *                                   (DE_CUR(IX,IY,IZ,1,ICHARG+2,1)
     *                                   *DE_CUR(IX,IY,IZ,1,ICHARP+2,1)
     *                                   +DE_CUR(IX,IY,IZ,2,ICHARG+2,1)
     *                                   *DE_CUR(IX,IY,IZ,2,ICHARP+2,1)
     *                                   +DE_CUR(IX,IY,IZ,3,ICHARG+2,1)
     *                                   *DE_CUR(IX,IY,IZ,3,ICHARP+2,1))
C
                    DJ_CBR(ICHARG,ICHARP,1)=
     *              DJ_CBR(ICHARG,ICHARP,1)+W_HERM *
     *                                 (DE_SCU(IX,IY,IZ,1,1,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,1,1,ICHARP+2,1)
     *                                 +DE_SCU(IX,IY,IZ,1,2,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,1,2,ICHARP+2,1)
     *                                 +DE_SCU(IX,IY,IZ,1,3,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,1,3,ICHARP+2,1)
     *                                 +DE_SCU(IX,IY,IZ,2,1,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,2,1,ICHARP+2,1)
     *                                 +DE_SCU(IX,IY,IZ,2,2,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,2,2,ICHARP+2,1)
     *                                 +DE_SCU(IX,IY,IZ,2,3,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,2,3,ICHARP+2,1)
     *                                 +DE_SCU(IX,IY,IZ,3,1,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,3,1,ICHARP+2,1)
     *                                 +DE_SCU(IX,IY,IZ,3,2,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,3,2,ICHARP+2,1)
     *                                 +DE_SCU(IX,IY,IZ,3,3,ICHARG+2,1)
     *                                 *DE_SCU(IX,IY,IZ,3,3,ICHARP+2,1))
C
                   END DO
               END DO
C
C=======================================================================
C              CALCULATING THE T0-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZRHO_I = ZRHO_I + W_HERM * QUNRHO
C
               ZSPI_I = ZSPI_I + W_HERM * QUNSPI
C
C=======================================================================
C              CALCULATING THE T1-T2-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZLPR_I = ZLPR_I + W_HERM * QUNLPR
C
               ZTAU_I = ZTAU_I + W_HERM * QUNTAU
C
               ZCUR_I = ZCUR_I + W_HERM * QUNCUR
C
               ZLPS_I = ZLPS_I + W_HERM * QUNLPS
C
               ZKIS_I = ZKIS_I + W_HERM * QUNKIS
C
               ZSCU_I = ZSCU_I + W_HERM * QUNSCU
C
C=======================================================================
C              CALCULATING THE T3-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZRHODI = ZRHODI + W_HERM * QUNRHO * DENPOW
               ZSPIDI = ZSPIDI + W_HERM * QUNSPI * DENPOW
C
               ENREAR = ENREAR + W_HERM * REAL(
     *                                   (CRHODS * QUNRHO
     *                                  + CSPIDS * QUNSPI)
     *                                  * DENPOW * (POWER/2))
C
C=======================================================================
C              CALCULATING THE W0-TERMS OF THE SKYRME ENERGY DENSITY
C=======================================================================
C
               ZDIV_I = ZDIV_I + W_HERM * QUNDIV
C
               ZROT_I = ZROT_I + W_HERM * QUNROT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C              PARTIAL SUMMATIONS OF TERMS IN ENERGY
C=======================================================================
C
      ECC_NP=C_ZERO
C
      DO NUCOUT=2,NDCOUT,2
         ENESKY        =ENESKY
     *                 +CCPALL(NUCOUT)*REAL(ZCPALL(NUCOUT))
         EKESKY        =EKESKY
     *                 +CCPALL(NUCOUT)*     ZCPALL(NUCOUT)
         ECC_NP(NUCOUT)=CCPALL(NUCOUT)*     ZCPALL(NUCOUT)
      END DO
C
      DO NUCOUP=2,NDCOUP/2,2
C
         ENEVEN=ENEVEN+CCPALL(NUCOUP)*
     *            REAL(ZCPALL(NUCOUP))
         ENEODD=ENEODD+CCPALL(NUCOUP+NDCOUP/2)
     *           *REAL(ZCPALL(NUCOUP+NDCOUP/2))
C
      END DO
C
      ENEVEN=ENEVEN+CCPALL(NDCOUP+2)*REAL(ZCPALL(NDCOUP+2))
      ENEODD=ENEODD+CCPALL(NDCOUP+4)*REAL(ZCPALL(NDCOUP+4))
     *             +CCPALL(NDCOUP+6)*REAL(ZCPALL(NDCOUP+6))
C
      EDIV_I=CCPALL(12)*REAL(ZCPALL(12))
      EROT_I=CCPALL(24)*REAL(ZCPALL(24))
C
      EEVEW0=EEVEW0+EDIV_I
      EODDW0=EODDW0+EROT_I
C
      ENE_W0=ENE_W0+EDIV_I+EROT_I
C
C=======================================================================
C
      DO ICHARG=0,NDISOS
          DO ICHARP=0,NDISOS
C
             ER2CBR(ICHARG,ICHARP,1)=CR2CBR(ICHARG,ICHARP,1)
     *                              *DR_CBR(ICHARG,ICHARP,1)
             ES2CBR(ICHARG,ICHARP,1)=CS2CBR(ICHARG,ICHARP,1)
     *                              *DS_CBR(ICHARG,ICHARP,1)
             ET2CBR(ICHARG,ICHARP,1)=CT2CBR(ICHARG,ICHARP,1)
     *                              *DT_CBR(ICHARG,ICHARP,1)
             EK2CBR(ICHARG,ICHARP,1)=CK2CBR(ICHARG,ICHARP,1)
     *                              *DK_CBR(ICHARG,ICHARP,1)
             EL2CBR(ICHARG,ICHARP,1)=CL2CBR(ICHARG,ICHARP,1)
     *                              *DL_CBR(ICHARG,ICHARP,1)
             EP2CBR(ICHARG,ICHARP,1)=CP2CBR(ICHARG,ICHARP,1)
     *                              *DP_CBR(ICHARG,ICHARP,1)
             EC2CBR(ICHARG,ICHARP,1)=CC2CBR(ICHARG,ICHARP,1)
     *                              *DC_CBR(ICHARG,ICHARP,1)
             EJ2CBR(ICHARG,ICHARP,1)=CJ2CBR(ICHARG,ICHARP,1)
     *                              *DJ_CBR(ICHARG,ICHARP,1)
C
             FR2CBR=FR2CBR+ER2CBR(ICHARG,ICHARP,1)
             FS2CBR=FS2CBR+ES2CBR(ICHARG,ICHARP,1)
             FT2CBR=FT2CBR+ET2CBR(ICHARG,ICHARP,1)
             FK2CBR=FK2CBR+EK2CBR(ICHARG,ICHARP,1)
             FL2CBR=FL2CBR+EL2CBR(ICHARG,ICHARP,1)
             FP2CBR=FP2CBR+EP2CBR(ICHARG,ICHARP,1)
             FC2CBR=FC2CBR+EC2CBR(ICHARG,ICHARP,1)
             FJ2CBR=FJ2CBR+EJ2CBR(ICHARG,ICHARP,1)
C
             DO IGR=0,2
                HR2CBR(IGR)= HR2CBR(IGR) + GR2CBR(ICHARG,ICHARP,1,IGR)
     *                                   * REAL(DR_CBR(ICHARG,ICHARP,1))
                HS2CBR(IGR)= HS2CBR(IGR) + GS2CBR(ICHARG,ICHARP,1,IGR)
     *                                   * REAL(DS_CBR(ICHARG,ICHARP,1))
                HT2CBR(IGR)= HT2CBR(IGR) + GT2CBR(ICHARG,ICHARP,1,IGR)
     *                                   * REAL(DT_CBR(ICHARG,ICHARP,1))
                HK2CBR(IGR)= HK2CBR(IGR) + GK2CBR(ICHARG,ICHARP,1,IGR)
     *                                   * REAL(DK_CBR(ICHARG,ICHARP,1))
                HL2CBR(IGR)= HL2CBR(IGR) + GL2CBR(ICHARG,ICHARP,1,IGR)
     *                                   * REAL(DL_CBR(ICHARG,ICHARP,1))
                HP2CBR(IGR)= HP2CBR(IGR) + GP2CBR(ICHARG,ICHARP,1,IGR)
     *                                   * REAL(DP_CBR(ICHARG,ICHARP,1))
                HC2CBR(IGR)= HC2CBR(IGR) + GC2CBR(ICHARG,ICHARP,1,IGR)
     *                                   * REAL(DC_CBR(ICHARG,ICHARP,1))
                HJ2CBR(IGR)= HJ2CBR(IGR) + GJ2CBR(ICHARG,ICHARP,1,IGR)
     *                                   * REAL(DJ_CBR(ICHARG,ICHARP,1))
             END DO
C
          END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('ESKYNP',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE EPAIRI(IN_FIX,IZ_FIX,ITPNMX,EKEPAI,LDTWCE)
C=======================================================================
      USE HE_DEN
      USE PD_DEN
      USE PP_DEN
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX :: EKEPAI
      COMPLEX :: QUXRHO, QRHO_X, QRHODX, QRHODS, RRHO_X, RRHODX, DENPOW
      COMPLEX :: QUXTA1, QTAU_1, QUXTA2, QTAU_2
      COMPLEX :: QUXLP1, QLPR_1, QUXLP2, QLPR_2
      COMPLEX :: QUXSC1, QSCU_1, QUXSC2, QSCU_2, QUXSC3, QSCU_3
      COMPLEX :: DENRHO, DENSPI(NDKART), PDERHO, PPDRHO
      COMPLEX :: DENSIC, DENCHC
      COMPLEX :: EPAI2B, EPAI3B, EPAI4B, EPA4B1, EPA4B2
      COMPLEX :: DSKPAL
      COMPLEX :: C_ZERO
C=======================================================================
C
      COMMON
     *       /ALLENE/ EKIN_N,EKIN_P,EKIN_T,
     *                EPOT_N,EPOT_P,EPOT_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *                EREA_N,EREA_P,EREA_T,
     *                ELIP_N,ELIP_P,ELIP_T,
     *
     *                ECOULD,ECOULE,ECOULT,
     *                       ECOULS,ECOULV,
     *
     *                EMULCO,EMUSLO,EMUREA,
     *                ESIFCO,ESISLO,ESIREA,
     *                ESPICO,ESPSLO,ESPREA,
     *
     *                ENREAR,ECORCM,ECOR_R,
     *
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /CCPSKP/ PRHO_0,PRHOD0,PTAU_1,PTAU_2,PLPR_0,PSCU_1,
     *                PSCU_2,PSCU_3
      COMMON
     *       /INTSKY/ T0,X0,T1,X1,T2,X2,T3,X3,W0,POWER
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /PAIBOD/ EPAI3N,EPAI3P,EPAI4N,EPAI4P
C
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENTOT/ DENSIT(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHA(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /DSKPAL/ DSKPAL(1:14)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /TWCINT/ WGHERM(1:NDGAUS,1:NDKART),
     *                PTHERM(1:NDGAUS,1:NDKART)
      COMMON
     *       /TWINTF/ FACNE2(1:NDKART,1:NDTWBL),
     *                FACNE4(1:NDKART,1:NDTWHE)
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *      /HERMIN/  INTWHE(1:NDTWCE,1:NDTWCE,1:NDTWCE,1:NDTWCE)
C
      CALL CPUTIM('EPAIRI',1)
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE PAIRING ENERGY AND AVERAGE GAP
C=======================================================================
C         ATTENTION: TO PROPERLY CALCULATE THE DENSITY-DEPENDENT PAIRING
C                    TERM, THIS ROUTINE  MUST  HAVE  THE  TOTAL  DENSITY
C                    DELIVERED IN  ARRAY  "DENSIC".  THEREFORE, IF  THIS
C                    ROUTINE IS CALLED SEPARATELY FOR NEUTRONS  AND  FOR
C                    PROTONS, THE TOTAL DENSITY OF THE PRESENT ITERATION
C                    IS NOT YET KNOWN AND THAT OF THE PREVIOUS ITERATION
C                    IS USED. MOREOVER, FOR THE SYMMETRY RESTORATION  IN
C                    "PROANG" THIS ROUTINE  M U S T  BE CALLED A F T E R
C                    CALCULATIONS FOR NEUTRONS AND PROTONS ARE COMPLETED
C=======================================================================
C
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C         PREPARE THE INPUT DATA
C=======================================================================
C
      IF (ITPNMX.EQ.0) THEN
C
          PRHO_X=PRHO_N
          PRHODX=PRHODN
          POWERX=POWERN
C
          NOPART=IN_FIX
C
      ENDIF
C
      IF (ITPNMX.EQ.1) THEN
C
          PRHO_X=PRHO_P
          PRHODX=PRHODP
          POWERX=POWERP
C
          NOPART=IZ_FIX
C
      ENDIF
C
      IF (ITPNMX.NE.0.AND.ITPNMX.NE.1)
     *                      STOP ' UNALLOWED VALUES OF ITPNMX IN EPAIRI'
C
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS 2.78N AND 2.97D, VARIABLE  "QRHODS"
C                   BELOW WAS NOT SET TO ZERO BEFORE  BEING  SUMMED  UP.
C                   THIS BUG RENDERED THE PAIRING ENERGY COMING FROM THE
C                   DENSITY-DEPENDENT TERM  OF  THE  SKYRME  INTERACTION
C                   INCORRECT. IT AFFECTED ONLY  RESULTS  OBTAINED  WITH
C                   INPUT PARAMETER "KETA_P=1". THE BUG WAS CORRECTED ON
C                   17/07/2020 IN VERSION 2.97E.
C=======================================================================
C
      QRHODS=C_ZERO
C
      QRHO_X=C_ZERO
      QRHODX=C_ZERO
      QTAU_1=C_ZERO
      QTAU_2=C_ZERO
      QLPR_1=C_ZERO
      QLPR_2=C_ZERO
      QSCU_1=C_ZERO
      QSCU_2=C_ZERO
      QSCU_3=C_ZERO
C
      QCEN_X=0.0D0
C
      EPAI2B=0.0D0
      EPAI3B=0.0D0
      EPAI4B=0.0D0
      EPA4B1=0.0D0
      EPA4B2=0.0D0
C
      E_REAR=0.0D0
C
      DO LTWCEN=1,LDTWCE
C
      INNERI=IND4HI(LTWCEN)
      INNERJ=IND4HJ(LTWCEN)
      INNERK=IND4HK(LTWCEN)
      INNERL=IND4HL(LTWCEN)
C
      LTWCE1=INTWHE(INNERI,INNERJ,INNERK,INNERL)
      LTWCE2=INTWHE(INNERK,INNERL,INNERI,INNERJ)
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
C=======================================================================
C        CALCULATING  THE  A U X I L I A R Y   C O N T R A C T I O N S
C=======================================================================
C        ATTENTION: ON 12/09/2020, STARTING WITH VERSION NUMBER (2.99T),
C                   DEFINITIONS OF PAIRING "PRIME" TRANSITION  DENSITIES
C                   "PP_XXX" HAVE CHANGED. NOW THEY CORRESPOND TO  THOSE
C                   CALCULATED FOR LEFT AND RIGHT STATES EXCHANGED  WITH
C                   RESPECT  TO  THE  STANDARD  PAIRING   DENSITIES   IN
C                   "PD_XXX", AND NOT TO THE COMPLEX CONJUGATES THEREOF.
C                   THEREFORE, NOW THE COMPLEX  CONJUGATES  MUST  APPEAR
C                   EXPLICITLY WHEREVER THESE DENSITIES ARE USED,  WHICH
C                   CONFORMS TO THE STANDARDS OF PERLINSKA EQ. (41B).
C=======================================================================
C        ATTENTION: ON 12/09/2020, STARTING WITH VERSION NUMBER (2.99T),
C                   THE TERM IN "QUXLPR" HAS BEEN SPLIT INTO  TWO  TERMS
C                   IN "QUXLP1" AND "QUXLP2".
C=======================================================================
C
               QUXRHO = PD_RHO(IX,IY,IZ,ITPNMX,LTWCE1)
     *           *CONJG(PP_RHO(IX,IY,IZ,ITPNMX,LTWCE2))
C
               QUXTA1 = PD_RHO(IX,IY,IZ,ITPNMX,LTWCE1)
     *           *CONJG(PP_TAU(IX,IY,IZ,ITPNMX,LTWCE2))
C
               QUXTA2 = PD_TAU(IX,IY,IZ,ITPNMX,LTWCE1)
     *           *CONJG(PP_RHO(IX,IY,IZ,ITPNMX,LTWCE2))
C
               QUXLP1 = PD_RHO(IX,IY,IZ,ITPNMX,LTWCE1)
     *           *CONJG(PP_LPR(IX,IY,IZ,ITPNMX,LTWCE2))
C
               QUXLP2 = PD_LPR(IX,IY,IZ,ITPNMX,LTWCE1)
     *           *CONJG(PP_RHO(IX,IY,IZ,ITPNMX,LTWCE2))
C
               QUXSC1 = 0.0D0
C
               QUXSC2 = 0.0D0
C
               QUXSC3 = 0.0D0
C
               DO K=1,NDKART
                  DO L=1,NDKART
C
                   QUXSC1 = QUXSC1 + PD_SCU(IX,IY,IZ,K,L,ITPNMX,LTWCE1)
     *                        *CONJG(PP_SCU(IX,IY,IZ,K,L,ITPNMX,LTWCE2))
C
                   QUXSC2 = QUXSC2 + PD_SCU(IX,IY,IZ,K,K,ITPNMX,LTWCE1)
     *                        *CONJG(PP_SCU(IX,IY,IZ,L,L,ITPNMX,LTWCE2))
C
                   QUXSC3 = QUXSC3 + PD_SCU(IX,IY,IZ,K,L,ITPNMX,LTWCE1)
     *                        *CONJG(PP_SCU(IX,IY,IZ,L,K,ITPNMX,LTWCE2))
C
                  END DO
C
C=======================================================================
C        ATTENTION: AT THE MOMENT TWO-CENTER BASIS DOES NOT USE :
C                   - DENSPI
C                   - DENRHO
C                   - PDERHO
C                   - PPDRHO
C=======================================================================
C
                  DENSPI(K) = DE_SPI(IX,IY,IZ,K,1-ITPNMX,1)
     *                      * EXPAUX(IX,IY,IZ,1)
               END DO
C
               DENRHO=DE_RHO(IX,IY,IZ,1-ITPNMX,1)* EXPAUX(IX,IY,IZ,1)
C
               PDERHO=PD_RHO(IX,IY,IZ,1-ITPNMX,1)* EXPAUX(IX,IY,IZ,1)
C
               PPDRHO=PP_RHO(IX,IY,IZ,1-ITPNMX,1)* EXPAUX(IX,IY,IZ,1)
C
               QUXCEN = REAL(DE_RHO(IX,IY,IZ,ITPNMX,LTWCE1)
     *                *CONJG(WD_CEN(IX,IY,IZ,ITPNMX,LTWCE2))
     *                      +DE_TAU(IX,IY,IZ,ITPNMX,LTWCE1)
     *                *CONJG(WD_TAU(IX,IY,IZ,ITPNMX,LTWCE2)))
C
               DO K=1,NDKART
                  DO L=1,NDKART
C
                      QUXCEN = QUXCEN
     *                    +  REAL(DE_SCU(IX,IY,IZ,K,L,ITPNMX,LTWCE1)
     *                    * CONJG(WD_SOR(IX,IY,IZ,K,L,ITPNMX,LTWCE2)))
C
                  END DO
               END DO
C
               IF (LDTWCE.EQ.1) THEN
               W_HERM=FOURWG(IX,1)*FOURWG(IY,2)*FOURWG(IZ,3)
               ELSEIF (LDTWCE.EQ.16) THEN
               W_HERM=WGHERM(IX,1)*WGHERM(IY,2)*WGHERM(IZ,3)*
     *         FACNE4(1,LTWCEN)*FACNE4(2,LTWCEN)*FACNE4(3,LTWCEN)
               ELSE
                STOP 'WRONG LDTWCE IN EPAIRI'
               END IF
C
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS (2.78N) AND (3.00N), AN UNITIALIZED
C                   VARIABLE "POWER" WAS USED BELOW IN THE DEFINITION OF
C                   "DENPOS", BECAUSE COMMON "INTSKY" WAS  NOT DECLARED.
C                   THIS BUG RENDERED THE PAIRING ENERGY COMING FROM THE
C                   DENSITY-DEPENDENT TERM  OF  THE  SKYRME  INTERACTION
C                   INCORRECT. IT AFFECTED ONLY  RESULTS  OBTAINED  WITH
C                   INPUT PARAMETER "KETA_P=1". THE BUG WAS CORRECTED ON
C                   30/10/2020 IN VERSION (3.00O).
C=======================================================================
C
               DENPOW=    DENSIC(IX,IY,IZ,LTWCEN)  ** POWERX
               DENPOS=ABS(DENSIT(IX,IY,IZ,LTWCEN)) ** POWER
C
C=======================================================================
C              CALCULATING THE T0-TERMS OF THE PAIRING ENERGY DENSITY
C=======================================================================
C
               QRHO_X = QRHO_X + W_HERM * QUXRHO
               QTAU_1 = QTAU_1 + W_HERM * QUXTA1
               QTAU_2 = QTAU_2 + W_HERM * QUXTA2
               QLPR_1 = QLPR_1 + W_HERM * QUXLP1
               QLPR_2 = QLPR_2 + W_HERM * QUXLP2
               QSCU_1 = QSCU_1 + W_HERM * QUXSC1
               QSCU_2 = QSCU_2 + W_HERM * QUXSC2
               QSCU_3 = QSCU_3 + W_HERM * QUXSC3
               EPAI3B = EPAI3B + W_HERM * QUXRHO * DENRHO
               EPA4B1 = EPA4B1 + W_HERM * QUXRHO
     *                                  * ( DENRHO * DENRHO
     *                                    - DENSPI(1) * DENSPI(1)
     *                                    - DENSPI(2) * DENSPI(2)
     *                                    - DENSPI(3) * DENSPI(3))
               EPA4B2 = EPA4B2 + W_HERM * QUXRHO
     *                                  * PDERHO * CONJG(PPDRHO) /2.0
C
               QCEN_X = QCEN_X + W_HERM * QUXCEN
C
C=======================================================================
C              CALCULATING THE T3-TERMS OF THE PAIRING ENERGY DENSITY
C=======================================================================
C
               QRHODX = QRHODX + W_HERM * QUXRHO
     *                                  * DENPOW
C
               E_REAR = E_REAR + W_HERM * PRHODX * REAL(QUXRHO) / 4
     *
     *                                  * REAL(DENPOW * (POWERX/2))
C
               QRHODS = QRHODS + W_HERM * QUXRHO
     *                                  * DENPOS
C
               E_REAR = E_REAR + W_HERM * PRHOD0 * REAL(QUXRHO) / 4
     *
     *                                  * DENPOS * (POWER/2)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         SUMMATIONS OF TERMS IN ENERGY.
C=======================================================================
C         DIVISION BY 4 BELOW CORRESPONDS TO THE FACTOR OF 1/4 WHICH
C         APPEARS IN THE EXPRESSIONS FOR THE PAIRING ENERGY IN TERMS
C         OF THE T0*(1-X0) COUPLING CONSTANT, SEE DFT (A.3B).
C=======================================================================
C
C
C=======================================================================
C     HERE ENDS THE TWO-CENTER LOOP
C=======================================================================
C
      END DO
C
      RRHO_X=PRHO_X * QRHO_X / 4
      RRHODX=PRHODX * QRHODX / 4
C
      EPAI2B = PRHO_0 * QRHO_X
     *       + PRHOD0 * QRHODS
     *       + PTAU_1 * QTAU_1
     *       + PTAU_2 * QTAU_2
     *       + PLPR_0 * QLPR_1/2
     *       + PLPR_0 * QLPR_2/2
     *       + PSCU_1 * QSCU_1
     *       + PSCU_2 * QSCU_2
     *       + PSCU_3 * QSCU_3
C
C     write (*,'(i2,e15.7,9(2x,2e15.7))') ITPNMX, REAL(EPAI2B) ,
C    *         PRHO_0 , REAL(QRHO_X),
C    *         PRHOD0 , REAL(QRHODS),
C    *         PTAU_1 , REAL(QTAU_1),
C    *         PTAU_2 , REAL(QTAU_2),
C    *         PLPR_0 , REAL(QLPR_1)/2,
C    *         PLPR_0 , REAL(QLPR_2)/2,
C    *         PSCU_1 , REAL(QSCU_1),
C    *         PSCU_2 , REAL(QSCU_2),
C    *         PSCU_3 , REAL(QSCU_3)
C
      EPAI3B = 3*THREEB/4. * EPAI3B
      EPAI4B = EPA4B1 + EPA4B2
      EPAI4B = 3*FOURBD/4. * EPAI4B
C      Pairing energy kernel
      EKEPAI= RRHO_X+RRHODX+EPAI2B
C
C     WRITE(*,'(''EPAIRI'',I3,4(2X,2D14.6))')
C    *      ITPNMX,EKEPAI,RRHO_X,RRHODX,EPAI2B
C
      IF (THREEB.NE.0.0)THEN
        EKEPAI = EKEPAI + EPAI3B
        E_REAR = E_REAR + REAL(EPAI3B)/2.
      ENDIF
C
      IF (FOURBD.NE.0.0)THEN
        EKEPAI = EKEPAI + EPAI4B
        E_REAR = E_REAR + 3*FOURBD/4. * REAL(EPA4B1)
      ENDIF
C
C      Real part for SR calculations
      E_PAIR= REAL(EKEPAI)
C
      PDELTA=-QCEN_X/NOPART
C
C=======================================================================
C         THIS ESTIMATE OF THE PAIRING STRENGTH IS BASED ON THE SIMPLE
C         BCS EXPRESSION. IT IS VERY CRUDE.
C=======================================================================
C
      G_PAIR=0.0D0
C
      IF (E_PAIR.NE.0.0D0) G_PAIR = -PDELTA**2/E_PAIR
C
C=======================================================================
C         PREPARE THE OUTPUT DATA
C=======================================================================
C
      IF (ITPNMX.EQ.0) THEN
C
          GPAIRN=G_PAIR
          DELTAN=PDELTA
          EPAI_N=E_PAIR
          EREA_N=E_REAR
          EPAI3N=REAL(EPAI3B)
          EPAI4N=REAL(EPAI4B)
C
          DSKPAL(1) = QRHO_X
          DSKPAL(3) = QTAU_1
          DSKPAL(5) = QTAU_2
          DSKPAL(7) =(QLPR_1+QLPR_2)/2
          DSKPAL(9) = QSCU_1
          DSKPAL(11)= QSCU_2
          DSKPAL(13)= QSCU_3
C
      ENDIF
C
      IF (ITPNMX.EQ.1) THEN
C
          GPAIRP=G_PAIR
          DELTAP=PDELTA
          EPAI_P=E_PAIR
          EREA_P=E_REAR
          EPAI3P=REAL(EPAI3B)
          EPAI4P=REAL(EPAI4B)
C
          DSKPAL(2) = QRHO_X
          DSKPAL(4) = QTAU_1
          DSKPAL(6) = QTAU_2
          DSKPAL(8) =(QLPR_1+QLPR_2)/2
          DSKPAL(10)= QSCU_1
          DSKPAL(12)= QSCU_2
          DSKPAL(14)= QSCU_3
C
      ENDIF
C
C=======================================================================
C
      CALL CPUTIM('EPAIRI',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GINTER(ICHARG,MREVER,PRHO_X,PRHODX,POWERX)
C=======================================================================
      USE WAVSQU
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *           W_HERM(NDXHRM,NDYHRM,NDZHRM),
     *           WAUXIL(NDXHRM,NDYHRM,NDZHRM)
C
      COMMON
     *       /DENTOT/ DENSIT(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHA(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /MATRIG/ GMATRI(1:NDSTAT,1:NDSTAT,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /HALFBO/ IHABOX,IHABOY,IHABOZ
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('GINTER',1)
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE PAIRING MATRIX ELEMENTS BETWEEN
C         PAIRS OF TIME-REVERSED STATES.
C=======================================================================
C
      LSTATE=NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG)
C
      IF (LSTATE.NE.LDSTAT(ICHARG))STOP ' INCONSISTENT LSTATE IN GINTER'
C
C=======================================================================
C        CALCULATING  THE  A U X I L I A R Y   ARRAYS
C=======================================================================
C        DIVISION BY 4 BELOW CORRESPONDS TO THE FACTOR OF 1/4 WHICH
C        APPEARS IN THE EXPRESSIONS FOR THE PAIRING ENERGY IN TERMS
C        OF THE T0*(1-X0) COUPLING CONSTANT, SEE DFT (A.3B).
C=======================================================================
C
      DO IX=1,NXHERM/IHABOX
         DO IY=1,NYHERM/IHABOY
            DO IZ=1,NZHERM/IHABOZ
C
               DENPOW=DENSIT(IX,IY,IZ,1) ** POWERX
C
               W_HERM(IX,IY,IZ)=-(PRHO_X+PRHODX*DENPOW)/4
     *                          * FOURWG(IX,1)*FOURWG(IY,2)*FOURWG(IZ,3)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        CALCULATING MATRIX ELEMENTS
C=======================================================================
C
      DO ISTATE=1,LSTATE
C
         DO IX=1,NXHERM/IHABOX
            DO IY=1,NYHERM/IHABOY
               DO IZ=1,NZHERM/IHABOZ
C
                  WAUXIL(IX,IY,IZ) = W_HERM(IX,IY,IZ)
     *                             * SQUWAV(ISTATE,IX,IY,IZ)
C
               END DO
            END DO
         END DO
C
         DO JSTATE=1,ISTATE
C
            QRHO_X=0.0D0
C
            DO IX=1,NXHERM/IHABOX
               DO IY=1,NYHERM/IHABOY
                  DO IZ=1,NZHERM/IHABOZ
C
                     QRHO_X = QRHO_X + WAUXIL(IX,IY,IZ)
     *                               * SQUWAV(JSTATE,IX,IY,IZ)
C
                  END DO
               END DO
            END DO
C
C=======================================================================
C         ATTENTION: THE SIGNS OF GMATRI WERE INCORRECT IN  VERSIONS  UP
C                    TO 2.37S - THIS BUG HAS BEEN CORRECTED  IN  VERSION
C                    2.37T ON 12/12/08.
C                    AT PRESENT, IN THE HFB AND STATE-DEPENDENT-GAP  BCS
C                    CALCULATIONS, MEANING OF PAIRING COUPLING CONSTANTS
C                    IS THE SAME, I.E., FOR THE ATTRACTIVE PAIRING  THEY
C                    MUST BE NEGATIVE. THEN, ACCORDING TO  THE  STANDARD
C                    CONVENTION, THE MATRIX  ELEMENTS  IN  "GMATRI"  ARE
C                    POSITIVE
C=======================================================================
C
           GMATRI(ISTATE,JSTATE,ICHARG)=QRHO_X*IHABOX*IHABOY*IHABOZ
           GMATRI(JSTATE,ISTATE,ICHARG)=GMATRI(ISTATE,JSTATE,ICHARG)
C
         END DO
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('GINTER',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PAIPRI(NAMEPN,G_PAIR,E_PAIR,EFERMI,PDELTA,
     *                                LIPKIX,EFER2X,ELIP_X,
     *                                IPAHFB,JPABCS,IAVRGG,
     *                         IGOGPA,IREGPA,ISEPPA,ICOUPA)
C
      CHARACTER
     *          NAMEPN*8,BCSHFB*3,STRCAL*26
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE PAIRING DATA
C=======================================================================
C
      IF (IPAHFB.GE.1) THEN
C
          BCSHFB='HFB'
          STRCAL='                          '
C
          IF (IGOGPA.GE.1.OR.IREGPA.GE.1.OR.ISEPPA.GE.1.OR.ICOUPA.GE.1)
     *    STRCAL='(ONLY 2BD CONTACT PAIRING)'
C
      ELSE
C
          IF (JPABCS.GT.0) THEN
C
              BCSHFB='BCS'
              KPABCS=0
C
              IF (JPABCS.EQ.1) THEN
C
                  KPABCS=1
                  IF (IAVRGG.EQ.1) THEN
C
                      STRCAL='(BCS STRENGTH CALCULATED) '
                  ELSE
                      STRCAL='(BCS STRENGTH READ/INPUT) '
C
                  END IF
C
              END IF
C
              IF (JPABCS.EQ.2) THEN
C
                  KPABCS=2
                  STRCAL='(FIXED BCS  PAIRING  GAP) '
C
              END IF
C
              IF (JPABCS.EQ.3) THEN
C
                  KPABCS=3
                  STRCAL='(STATE-DEPENDENT BCS GAP) '
C
              END IF
C
              IF (KPABCS.EQ.0) STOP ' INCORRECT IPABCS IN PAIPRI'
C
          ELSE
C
              STOP ' IPAHFB=0 AND IPABCS=0 IN PAIPRI'
C
          END IF
C
      END IF
C
      WRITE(NFIPRI,'(79(1H*),/,                       1H*,77X,1H*,/,
     *
     *             1H*, 2X,A3,1X,
     *                     ''PAIRING PROPERTIES'',2X,A26,
     *                                               15X,A8,2X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *             1H*, 2X,''STRENGTH='',    F7.4,3X,
     *                     ''GAP='',         F7.4,3X,
     *                     ''FERMI ENERGY='',F8.4,3X,
     *                     ''ENERGY='',      F9.4,          2X,1H*,/,
     *                                                 1H*,77X,1H*)')
     *
     *                BCSHFB,STRCAL,NAMEPN,G_PAIR,PDELTA,EFERMI,E_PAIR
C
      IF (LIPKIX.EQ.1)
     *    WRITE(NFIPRI,'(
     *             1H*, 2X,''LIPKIN-NOGAMI:'',5X,
     *                     ''GAP='',         F7.4,3X,
     *                     ''LAMBDA2 PAR.='',F8.4,3X,
     *                     ''ENERGY='',      F9.4,          2X,1H*,/,
     *                                                 1H*,77X,1H*)')
     *
     *                PDELTA+EFER2X,EFER2X,ELIP_X
C
      WRITE(NFIPRI,'(79(1H*),/)')
     *
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PRIENE(JETACM,KETA_R,IPOTHO,I_YUKA,I_GOGA,IGOGPA,
     *                                              I_REGA,IREGPA,
     *                                              I_SEPA,ISEPPA,
     *                                                     ICOUPA,
     *                                              LIPKIN,LIPKIP,
     *                                                     NEWGOG,
     *                                                     ICOUEX,
     *                                                     JETA_T)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDFSTA=3)
C=======================================================================
C
      CHARACTER
     *          ESTABC*13
      COMPLEX
     *          EGOGSP,EGOGVP
      COMPLEX
     *          EREGSP,EREGVP
      COMPLEX
     *          ESEPSP,ESEPVP
      COMPLEX
     *          EFSOSP,EFTOSP,EFTESP
      COMPLEX
     *          EKPSCA,EKPVEC
      COMPLEX
     *          E3BEVE,E3BODD
      COMPLEX
     *          E4BEVE,E4BODD
      COMPLEX
     *          FR2CBR,FS2CBR,FR3CBR,FS3CBR,
     *          FT2CBR,FK2CBR,FT3CBR,FK3CBR,
     *          FL2CBR,FP2CBR,FL3CBR,FP3CBR,
     *          FC2CBR,FJ2CBR,FC3CBR,FJ3CBR
C
      COMMON
     *       /ALLENE/ EKIN_N,EKIN_P,EKIN_T,
     *                EPOT_N,EPOT_P,EPOT_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *                EREA_N,EREA_P,EREA_T,
     *                ELIP_N,ELIP_P,ELIP_T,
     *
     *                ECOULD,ECOULE,ECOULT,
     *                       ECOULS,ECOULV,
     *
     *                EMULCO,EMUSLO,EMUREA,
     *                ESIFCO,ESISLO,ESIREA,
     *                ESPICO,ESPSLO,ESPREA,
     *
     *                ENREAR,ECORCM,ECOR_R,
     *
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
      COMMON
     *       /E_TENS/ ETEVEN,ETEODD,
     *                ETOVEN,ETOODD
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /ETHREE/ E3BEVE,E3BODD
      COMMON
     *       /EFOURB/ E4BEVE,E4BODD
      COMMON
     *       /ETHRGR/ ETGRAF,ETGRAP
      COMMON
     *       /FC_CBR/ FR2CBR,FS2CBR,FR3CBR,FS3CBR,
     *                FT2CBR,FK2CBR,FT3CBR,FK3CBR,
     *                FL2CBR,FP2CBR,FL3CBR,FP3CBR,
     *                FC2CBR,FJ2CBR,FC3CBR,FJ3CBR
     *       /HC_CBR/ HR2CBR(0:2),HS2CBR(0:2),HR3CBR(0:2),HS3CBR(0:2),
     *                HT2CBR(0:2),HK2CBR(0:2),HT3CBR(0:2),HK3CBR(0:2),
     *                HL2CBR(0:2),HP2CBR(0:2),HL3CBR(0:2),HP3CBR(0:2),
     *                HC2CBR(0:2),HJ2CBR(0:2),HC3CBR(0:2),HJ3CBR(0:2)
      COMMON
     *       /CBRSWI/ I_2CBR,I_3CBR
      COMMON
     *       /ISOENE/ EISOCO,EISSLO,EISREA
      COMMON
     *       /EYUKTT/ EYUKDT,EYUKD0,EYUKD1,EYUKD2,
     *                EYUKET,EYUKE0,EYUKE1,EYUKE2
      COMMON
     *       /EGOGTT/ EGOGDT,EGOGET
      COMMON
     *       /EREGTT/ EREGDT,EREGET
      COMMON
     *       /ESEPTT/ ESEPDT,ESEPET
       COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /EFSOTT/ EFSODT,EFSOET
      COMMON
     *       /EFTOTT/ EFTODT,EFTOET
      COMMON
     *       /EFTETT/ EFTEDT,EFTEET
      COMMON
     *       /PN_GOG/ EGOGSP(0:NDISOS),EGOGVP(0:NDISOS)
      COMMON
     *       /PN_REG/ EREGSP(0:NDISOS),EREGVP(0:NDISOS)
      COMMON
     *       /PN_SEP/ ESEPSP(0:NDISOS),ESEPVP(0:NDISOS)
      COMMON
     *       /PN_FST/ EFSOSP(0:NDISOS),EFTOSP(0:NDISOS),EFTESP(0:NDISOS)
      COMMON
     *       /PN_COU/ EKPSCA,EKPVEC
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE ENERGIES
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                        1H*,77X,1H*,/,
     *             1H*,31X,'' ENERGIES (MEV)'',            31X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                                                     79(1H*),/,
     *                                                 1H*,77X,1H*,/,
     *             1H*, 2X,''KINETIC: (NEU)='',F13.6,4X,
     *                              ''(PRO)='',F13.6,4X,
     *                              ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             EKIN_N,EKIN_P,EKIN_T
C
      IF (IPOTHO.EQ.1)
     *    WRITE(NFIPRI,'(1H*,2X,''EXTEPOT: (NEU)='',F13.6,4X,
     *                                   ''(PRO)='',F13.6,4X,
     *                                   ''(TOT)='',F13.6,1X,1H*)')
     *
     *             EPOT_N,EPOT_P,EPOT_T
C
      WRITE(NFIPRI,'(1H*,2X,''SUM EPS: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*,/,
     *               1H*,2X,''PAIRING: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*,/,
     *               1H*,2X,''P-REARR: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *             ESUM_N,ESUM_P,ESUM_T,
     *             EPAI_N,EPAI_P,EPAI_T,
     *             EREA_N,EREA_P,EREA_T
C
      IF (IGOGPA.GE.1.AND.NEWGOG.EQ.0)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''GOG.PAI: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             REAL(EGOGSP(0)+EGOGVP(0)),
     *             REAL(EGOGSP(1)+EGOGVP(1)),
     *             REAL(EGOGSP(0)+EGOGVP(0)+EGOGSP(1)+EGOGVP(1))
C
      IF (IGOGPA.GE.1.AND.NEWGOG.EQ.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''GOG.PAI: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             REAL(EREGSP(0)+EREGVP(0)),
     *             REAL(EREGSP(1)+EREGVP(1)),
     *             REAL(EREGSP(0)+EREGVP(0)+EREGSP(1)+EREGVP(1))
C
      IF (IREGPA.GE.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''REG.PAI: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             REAL(EREGSP(0)+EREGVP(0)),
     *             REAL(EREGSP(1)+EREGVP(1)),
     *             REAL(EREGSP(0)+EREGVP(0)+EREGSP(1)+EREGVP(1))
C
      IF (MAXVAL(IFSTPA).GE.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      IF (IFSTPA(1).GE.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''FSO.PAI: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             REAL(EFSOSP(0)),
     *             REAL(EFSOSP(1)),
     *             REAL(EFSOSP(0)+EFSOSP(1))
C
      IF (IFSTPA(2).GE.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''FTO.PAI: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             REAL(EFTOSP(0)),
     *             REAL(EFTOSP(1)),
     *             REAL(EFTOSP(0)+EFTOSP(1))
C
      IF (IFSTPA(3).GE.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''FTE.PAI: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             REAL(EFTESP(0)),
     *             REAL(EFTESP(1)),
     *             REAL(EFTESP(0)+EFTESP(1))
C
      IF (ISEPPA.GE.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''SEP.PAI: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             REAL(ESEPSP(0)+ESEPVP(0)),
     *             REAL(ESEPSP(1)+ESEPVP(1)),
     *             REAL(ESEPSP(0)+ESEPVP(0)+ESEPSP(1)+ESEPVP(1))
C
      IF (LIPKIN.EQ.1.OR.LIPKIP.EQ.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''ELIPKIN: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *             ELIP_N,ELIP_P,ELIP_T
C
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''PAIRGAP: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''THIS SPACE IS EMPTY'',1X,1H*,/,
     *               1H*,2X,''E-FERMI: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''AND AWAITS  YOUR AD'',1X,1H*)')
     *
     *                DELTAN,DELTAP,
     *                EFERMN,EFERMP
C
      IF (LIPKIN.EQ.1.OR.LIPKIP.EQ.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''LAMBDA2: (NEU)='',F13.6,4X,
     *                               ''(PRO)='',F13.6,4X,
     *                               ''AS SOON AS  YOU PAY'',1X,1H*)')
     *
     *                EFER2N,EFER2P
C
      IF (ICOUPA.GE.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''COU.PAI: (SCA)='',F13.6,4X,
     *                               ''(VEC)='',F13.6,4X,
     *                               ''AS SOON AS  YOU PAY'',1X,1H*)')
     *
     *                REAL(EKPSCA),REAL(EKPVEC)
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''COULOMB: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                ECOULD,ECOULE,ECOULT
C
      IF (ICOUEX.EQ.2)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''COULEXC: (SCA)='',F13.6,4X,
     *                               ''(VEC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                ECOULS,ECOULV,ECOULE
C
      IF (I_YUKA.GE.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,'' YUKAWA: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                EYUKDT,EYUKET,EYUKDT+EYUKET
C
      IF (I_GOGA.GE.1.AND.NEWGOG.EQ.0)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''  GOGNY: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                EGOGDT,EGOGET,EGOGDT+EGOGET
C
      IF (I_GOGA.GE.1.AND.NEWGOG.EQ.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''  GOGNY: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                EREGDT,EREGET,EREGDT+EREGET
C
      IF (I_REGA.GE.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''  REGUL: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                EREGDT,EREGET,EREGDT+EREGET
C
      IF (I_SEPA.GE.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''  SEPAR: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                ESEPDT,ESEPET,ESEPDT+ESEPET
C
      IF (MAXVAL(I_FSTA).GE.1)
     *
     *    WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      IF (I_FSTA(1).GE.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''FINR-SO: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                EFSODT,EFSOET,EFSODT+EFSOET
C
      IF (I_FSTA(2).GE.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''FINR-TO: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                EFTODT,EFTOET,EFTODT+EFTOET
C
      IF (I_FSTA(3).GE.1)
     *
     *    WRITE(NFIPRI,'(
     *               1H*,2X,''FINR-TE: (DIR)='',F13.6,4X,
     *                               ''(EXC)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,       1X,1H*)')
     *
     *                EFTEDT,EFTEET,EFTEDT+EFTEET
C
      WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *               1H*,2X,''CONSTR. (MULT)='',F13.6,4X,
     *                               ''SLOPE='',F13.6,4X,
     *                               ''CORR.='',F13.6,       1X,1H*,/,
     *               1H*,2X,''CONSTR. (SURF)='',F13.6,4X,
     *                               ''SLOPE='',F13.6,4X,
     *                               ''CORR.='',F13.6,       1X,1H*,/,
     *               1H*,2X,''CONSTR. (SPIN)='',F13.6,4X,
     *                               ''SLOPE='',F13.6,4X,
     *                               ''CORR.='',F13.6,       1X,1H*,/,
     *               1H*,2X,''CONSTR. (ISOS)='',F13.6,4X,
     *                               ''SLOPE='',F13.6,4X,
     *                               ''CORR.='',F13.6,       1X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *               1H*,2X,''REARRANGEMENT ENERGY FROM THE SKYRME '',
     *                      ''DENSITY-DEPENDENT TERMS='',
     *                                          F13.6,       1X,1H*,/,
     *               1H*,2X,''ROUTHIAN= TOTAL ENERGY + MULTIPOLE '',
     *                      ''AND (ISO)SPIN CONSTRAINTS='',
     *                                          F13.6,       1X,1H*,/,
     *                                                  1H*,77X,1H*)')
     *               EMULCO,EMUSLO,EMUREA,
     *               ESIFCO,ESISLO,ESIREA,
     *               ESPICO,ESPSLO,ESPREA,
     *               EISOCO,EISSLO,EISREA,
     *
     *                             ENREAR,
     * ETOTFU+EMULCO+ESIFCO+ESPICO+EISOCO
C
      IF (JETACM.EQ.1)
     *    WRITE(NFIPRI,'(1H*,2X,''TWO-BODY CENTER OF MASS CORR'',
     *                          ''ECTION INCLUDED AFTER VARIATION ='',
     *                                         F13.6,       1X,1H*,/,
     *                                                 1H*,77X,1H*)')
     *
     *               ECORCM
C
      IF (JETACM.EQ.2)
     *    WRITE(NFIPRI,'(1H*,2X,''TWO-BODY CENTER OF MASS CORR'',
     *                          ''ECTION INCLUDED BEFORE VARIATION='',
     *                                         F13.6,       1X,1H*,/,
     *                                                 1H*,77X,1H*)')
     *
     *               ECORCM
C
C=======================================================================
C
      IF (KETA_R.EQ.1)
     *    WRITE(NFIPRI,'(1H*,2X,''TWO-BODY   ROTATIONAL   CORR'',
     *                          ''ECTION INCLUDED AFTER VARIATION ='',
     *                                         F13.6,       1X,1H*,/,
     *                                                 1H*,77X,1H*)')
     *
     *               ECOR_R
C
      IF (KETA_R.EQ.2)
     *    WRITE(NFIPRI,'(1H*,2X,''TWO-BODY   ROTATIONAL   CORR'',
     *                          ''ECTION INCLUDED BEFORE VARIATION='',
     *                                         F13.6,       1X,1H*,/,
     *                                                 1H*,77X,1H*)')
     *
     *               ECOR_R
C
C=======================================================================
C
      IF (ABS(ESTABN).GE.1E-5.AND.ABS(ESTABN).LT.1E+3) THEN
C
          WRITE(ESTABC,'(F13.6)')     ESTABN
      ELSE
          WRITE(ESTABC,'((1PE13.2))') ESTABN
C
      END IF
C
      WRITE(NFIPRI,'(1H*,2X,''SPIN-ORB (EVE)='',F13.6,4X,
     *                               ''(ODD)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,      1X,1H*,/,
     *               1H*,2X,''SKYRME:  (EVE)='',F13.6,4X,
     *                               ''(ODD)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,      1X,1H*)')
     *               EEVEW0,EODDW0,ENE_W0,
     *               ENEVEN,ENEODD,ENESKY
C
      IF (JETA_T.GE.1)
     *WRITE(NFIPRI,'(1H*,2X,''TENS-ODD (EVE)='',F13.6,4X,
     *                               ''(ODD)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,      1X,1H*,/,
     *               1H*,2X,''TENS-EVE (EVE)='',F13.6,4X,
     *                               ''(ODD)='',F13.6,4X,
     *                               ''(TOT)='',F13.6,      1X,1H*)')
     *               ETOVEN,ETOODD,ETOVEN+ETOODD,
     *               ETEVEN,ETEODD,ETEVEN+ETEODD
C
      IF (THREEB.NE.0.0D0)
     *    WRITE(NFIPRI,'(1H*,2X,''3-BODY:  (EVE)='',F13.6,4X,
     *                                   ''(ODD)='',F13.6,4X,
     *                                   ''(TOT)='',F13.6,  1X,1H*)')
     *               REAL(E3BEVE),REAL(E3BODD),
     *               REAL(E3BEVE)+REAL(E3BODD)
C
      IF (FOURBD.NE.0.0D0)
     *    WRITE(NFIPRI,'(1H*,2X,''4-BODY:  (EVE)='',F13.6,4X,
     *                                   ''(ODD)='',F13.6,4X,
     *                                   ''(TOT)='',F13.6,  1X,1H*)')
     *               REAL(E4BEVE),REAL(E4BODD),
     *               REAL(E4BEVE)+REAL(E4BODD)
C
      IF (IGRAIN.EQ.1)
     *    WRITE(NFIPRI,'(1H*,2X,''3B-GRAD: (P-H)='',F13.6,4X,
     *                                   ''(P-P)='',F13.6,4X,
     *                                   ''(TOT)='',F13.6,  1X,1H*)')
     *               ETGRAF,ETGRAP,
     *               ETGRAF+ETGRAP
C
      IF (I_2CBR.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,2X,''CBR II:  (EVE)='',F13.6,4X,
     *                                   ''(ODD)='',F13.6,4X,
     *                                   ''(TOT)='',F13.6,  1X,1H*)')
     *               REAL(FR2CBR+FT2CBR+FL2CBR+FJ2CBR),
     *               REAL(FS2CBR+FK2CBR+FP2CBR+FC2CBR),
     *               REAL(FR2CBR+FT2CBR+FL2CBR+FJ2CBR+
     *                    FS2CBR+FK2CBR+FP2CBR+FC2CBR)
C
          WRITE(NFIPRI,'(1H*,11X,        ''(RHO)='',F13.6,4X,
     *                                   ''(SPI)='',F13.6,4X,
     *                                                      20X,1H*)')
     *               REAL(FR2CBR),REAL(FS2CBR)
C
          WRITE(NFIPRI,'(1H*,11X,        ''(TAU)='',F13.6,4X,
     *                                   ''(KIS)='',F13.6,4X,
     *                                                      20X,1H*)')
     *               REAL(FT2CBR),REAL(FK2CBR)
C
          WRITE(NFIPRI,'(1H*,11X,        ''(LPR)='',F13.6,4X,
     *                                   ''(LPS)='',F13.6,4X,
     *                                                      20X,1H*)')
     *               REAL(FL2CBR),REAL(FP2CBR)
C
          WRITE(NFIPRI,'(1H*,11X,        ''(SCU)='',F13.6,4X,
     *                                   ''(CUR)='',F13.6,4X,
     *                                                      20X,1H*)')
     *               REAL(FJ2CBR),REAL(FC2CBR)
C
          WRITE(NFIPRI,'(1H*,2X,''GRADII: '',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *         (HR2CBR(IGR)+HT2CBR(IGR)+HL2CBR(IGR)+HJ2CBR(IGR)+
     *          HS2CBR(IGR)+HK2CBR(IGR)+HP2CBR(IGR)+HC2CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     RHO'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HR2CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     TAU'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HT2CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     LPR'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HL2CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     SCU'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HJ2CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     SPI'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HS2CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     KIS'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HK2CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     LPS'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HP2CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     CUR'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HC2CBR(IGR),
     *                                                        IGR=0,2)
C
      END IF
C
      IF (I_3CBR.EQ.1) THEN
C
          WRITE(NFIPRI,'(1H*,2X,''CBRIII:  (EVE)='',F13.6,4X,
     *                                   ''(ODD)='',F13.6,4X,
     *                                   ''(TOT)='',F13.6,  1X,1H*)')
     *               REAL(FR3CBR+FT3CBR+FL3CBR+FJ3CBR),
     *               REAL(FS3CBR+FK3CBR+FP3CBR+FC3CBR),
     *               REAL(FR3CBR+FT3CBR+FL3CBR+FJ3CBR+
     *                    FS3CBR+FK3CBR+FP3CBR+FC3CBR)
C
          WRITE(NFIPRI,'(1H*,11X,        ''(RHO)='',F13.6,4X,
     *                                   ''(SPI)='',F13.6,4X,
     *                                                      20X,1H*)')
     *               REAL(FR3CBR),REAL(FS3CBR)
C
          WRITE(NFIPRI,'(1H*,11X,        ''(TAU)='',F13.6,4X,
     *                                   ''(KIS)='',F13.6,4X,
     *                                                      20X,1H*)')
     *               REAL(FT3CBR),REAL(FK3CBR)
C
          WRITE(NFIPRI,'(1H*,11X,        ''(LPR)='',F13.6,4X,
     *                                   ''(LPS)='',F13.6,4X,
     *                                                      20X,1H*)')
     *               REAL(FL3CBR),REAL(FP3CBR)
C
          WRITE(NFIPRI,'(1H*,11X,        ''(SCU)='',F13.6,4X,
     *                                   ''(CUR)='',F13.6,4X,
     *                                                      20X,1H*)')
     *               REAL(FJ3CBR),REAL(FC3CBR)
C
          WRITE(NFIPRI,'(1H*,2X,''GRAIII: '',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *         (HR3CBR(IGR)+HT3CBR(IGR)+HL3CBR(IGR)+HJ3CBR(IGR)+
     *          HS3CBR(IGR)+HK3CBR(IGR)+HP3CBR(IGR)+HC3CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     RHO'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HR3CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     TAU'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HT3CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     LPR'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HL3CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     SCU'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HJ3CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     SPI'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HS3CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     KIS'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HK3CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     LPS'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HP3CBR(IGR),
     *                                                        IGR=0,2)
C
          WRITE(NFIPRI,'(1H*,2X,''     CUR'',       F13.6,   4X,
     *                                              F13.6,   4X,
     *                                              F13.6,  20X,1H*)')
     *                                             (HC3CBR(IGR),
     *                                                        IGR=0,2)
C
      END IF
C
      WRITE(NFIPRI,'(                                  1H*,77X,1H*,/,
     *               1H*,2X,''TOTAL:  (STAB)='',A13  ,4X,
     *                               '' (SP)='',F13.6,4X,
     *                               ''(FUN)='',F13.6,      1X,1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *               ESTABC,ETOTSP,ETOTFU
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PRIFUN(IROTAT,PRIYUK,I_GOGA,IGOGPA,I_REGA,IREGPA,
     *                                       NEWGOG,I_SEPA,ISEPPA,
     *                         JETA_T,JETAPA,IVIPRI,N3LORD,N3SERD)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDFSTA=3)
C=======================================================================
C
      CHARACTER
     *          NCPALL*4,MCPALL*4
      CHARACTER
     *          TYPFST*2
      CHARACTER
     *            NRHO_N*4,NRHODN*4,
     *            NLPR_N*4,
     *            NTAU_N*4,
     *            NSCU_N*4,
     *            NDIV_N*4,
     *            NSPI_N*4,NSPIDN*4,
     *            NLPS_N*4,
     *            NCUR_N*4,
     *            NKIS_N*4,
     *            NROT_N*4,
     *            NSCT_N*4,
     *            NKIT_N*4,
     *            NSPT_N*4
      CHARACTER
     *            NSCR_N*4,
     *            NDIS_N*4,
     *            NDSR_N*4,
     *            NSCS_N*4,
     *            NSCJ_N*4,
     *            NCUS_N*4,
     *            NROS_N*4,
     *            NDES_N*4,
     *            NRHSXN*4,
     *            NRHSYN*4,
     *            NRHSZN*4,
     *            NRHCXN*4,
     *            NRHCYN*4,
     *            NRHCZN*4
C
      LOGICAL
     *          PRIYUK
C
      COMPLEX
     *          EYUK_D,EYUK_E
      COMPLEX
     *          EGOGSD,EGOGVD,EGOGSE,EGOGVE,
     *          EGOTSD,EGOTVD,EGOTSE,EGOTVE,
     *          EGOSSD,EGOSVD,EGOSSE,EGOSVE,
     *          EGOPSD,EGOPVD,EGOPSE,EGOPVE,
     *          EGOMSD,EGOMVD,EGOMSE,EGOMVE
      COMPLEX
     *          EGOGSP,EGOGVP
      COMPLEX
     *          EREGSD,EREGVD,EREGSE,EREGVE
      COMPLEX
     *          ERETSD,ERETVD,ERETSE,ERETVE,
     *          ERESSD,ERESVD,ERESSE,ERESVE,
     *          EREPSD,EREPVD,EREPSE,EREPVE,
     *          EREMSD,EREMVD,EREMSE,EREMVE
      COMPLEX
     *          EREGSP,EREGVP
      COMPLEX
     *          ESEPSD,ESEPVD,ESEPSE,ESEPVE
      COMPLEX
     *          EFSOSP,EFTOSP,EFTESP
      COMPLEX
     *          EFSTSD,EFSTSE
      COMPLEX
     *          ESPTSD,ESPTVD,ESPTSE,ESPTVE,
     *          ESPSSD,ESPSVD,ESPSSE,ESPSVE,
     *          ESPPSD,ESPPVD,ESPPSE,ESPPVE,
     *          ESPMSD,ESPMVD,ESPMSE,ESPMVE
      COMPLEX
     *          ESEPSP,ESEPVP
      COMPLEX
     *          DSKPAL
C
      DIMENSION
     *          CCPALL(NDCOUT), DCPALL(NDCOUT), ECPALL(NDCOUT)
      DIMENSION
     *          VCPALL(NDVIOL)
C
      EQUIVALENCE
     *            (CCPALL,CRHO_T),(DCPALL,DRHO_T),(ECPALL,ERHO_T)
      EQUIVALENCE
     *            (VCPALL,DSCRPP)
      DIMENSION
     *             NCPALL(NDCOUT/2),MCPALL(NDVIOL/4)
      EQUIVALENCE
     *            (NCPALL,NRHO_N),(MCPALL,NSCR_N)
      DIMENSION
     *             EISALL(NDCOUT)
      DIMENSION
     *             TYPFST(NDFSTA)
C
      COMMON
     *       /NCPSKY/ NRHO_N,NRHODN,
     *                NLPR_N,
     *                NTAU_N,
     *                NSCU_N,
     *                NDIV_N,
     *                NSPI_N,NSPIDN,
     *                NLPS_N,
     *                NCUR_N,
     *                NKIS_N,
     *                NROT_N,
     *                NSCT_N,
     *                NKIT_N,
     *                NSPT_N
      COMMON
     *       /CCPSKY/ CRHO_T,CRHO_S,CRHODT,CRHODS,
     *                CLPR_T,CLPR_S,
     *                CTAU_T,CTAU_S,
     *                CSCU_T,CSCU_S,
     *                CDIV_T,CDIV_S,
     *                CSPI_T,CSPI_S,CSPIDT,CSPIDS,
     *                CLPS_T,CLPS_S,
     *                CCUR_T,CCUR_S,
     *                CKIS_T,CKIS_S,
     *                CROT_T,CROT_S,
     *                CSCT_T,CSCT_S,
     *                CKIT_T,CKIT_S,
     *                CSPT_T,CSPT_S
      COMMON
     *       /DCPSKY/ DRHO_T,DRHO_S,DRHODT,DRHODS,
     *                DLPR_T,DLPR_S,
     *                DTAU_T,DTAU_S,
     *                DSCU_T,DSCU_S,
     *                DDIV_T,DDIV_S,
     *                DSPI_T,DSPI_S,DSPIDT,DSPIDS,
     *                DLPS_T,DLPS_S,
     *                DCUR_T,DCUR_S,
     *                DKIS_T,DKIS_S,
     *                DROT_T,DROT_S,
     *                DSCT_T,DSCT_S,
     *                DKIT_T,DKIT_S,
     *                DSPT_T,DSPT_S
      COMMON
     *       /ECPSKY/ ERHO_T,ERHO_S,ERHODT,ERHODS,
     *                ELPR_T,ELPR_S,
     *                ETAU_T,ETAU_S,
     *                ESCU_T,ESCU_S,
     *                EDIV_T,EDIV_S,
     *                ESPI_T,ESPI_S,ESPIDT,ESPIDS,
     *                ELPS_T,ELPS_S,
     *                ECUR_T,ECUR_S,
     *                EKIS_T,EKIS_S,
     *                EROT_T,EROT_S,
     *                ESCT_T,ESCT_S,
     *                EKIT_T,EKIT_S,
     *                ESPT_T,ESPT_S
      COMMON
     *       /VCPSKY/ DSCRPP,DSCRMM,DSCRPM,DSCRMP,
     *                DDISPP,DDISMM,DDISPM,DDISMP,
     *                DDSRPP,DDSRMM,DDSRPM,DDSRMP,
     *                DSCSPP,DSCSMM,DSCSPM,DSCSMP,
     *                DSCJPP,DSCJMM,DSCJPM,DSCJMP,
     *                DCUSPP,DCUSMM,DCUSPM,DCUSMP,
     *                DROSPP,DROSMM,DROSPM,DROSMP,
     *                DDESPP,DDESMM,DDESPM,DDESMP,
     *
     *                XRHSPP,XRHSMM,XRHSPM,XRHSMP,
     *                YRHSPP,YRHSMM,YRHSPM,YRHSMP,
     *                ZRHSPP,ZRHSMM,ZRHSPM,ZRHSMP,
     *
     *                XRHCPP,XRHCMM,XRHCPM,XRHCMP,
     *                YRHCPP,YRHCMM,YRHCPM,YRHCMP,
     *                ZRHCPP,ZRHCMM,ZRHCPM,ZRHCMP
     *
      COMMON
     *       /ENEYUK/ EYUKAD(0:NDISOS,0:NDISOS)
      COMMON
     *       /EN_YUK/ EYUK_D(0:NDISOS,0:NDISOS),
     *                EYUK_E(0:NDISOS,0:NDISOS)
      COMMON
     *       /EYUKTT/ EYUKDT,EYUKD0,EYUKD1,EYUKD2,
     *                EYUKET,EYUKE0,EYUKE1,EYUKE2
      COMMON
     *       /EN_GOG/ EGOGSD(0:NDISOS,0:NDISOS),
     *                EGOGSE(0:NDISOS,0:NDISOS),
     *                EGOGVD(0:NDISOS,0:NDISOS),
     *                EGOGVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_GTS/ EGOTSD,EGOTSE,EGOTVD,EGOTVE,
     *                EGOSSD,EGOSSE,EGOSVD,EGOSVE
     *
     *       /EN_GPM/ EGOPSD,EGOPSE,EGOPVD,EGOPVE,
     *                EGOMSD,EGOMSE,EGOMVD,EGOMVE
      COMMON
     *       /PN_GOG/ EGOGSP(0:NDISOS),EGOGVP(0:NDISOS)
     *
     *       /PGOGTT/ EGOGPT
      COMMON
     *       /PN_REG/ EREGSP(0:NDISOS),EREGVP(0:NDISOS)
     *
     *       /PV_REG/ PREGVP(0:NDKART,0:NDISOS)
      COMMON
     *       /EN_REG/ EREGSD(0:NDISOS,0:NDISOS),
     *                EREGSE(0:NDISOS,0:NDISOS),
     *                EREGVD(0:NDISOS,0:NDISOS),
     *                EREGVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_ROR/ ECEGOR(NDREGA),EREGOR(NDREGA)
     *
     *       /EN_RTS/ ERETSD,ERETSE,ERETVD,ERETVE,
     *                ERESSD,ERESSE,ERESVD,ERESVE
     *
     *       /EN_RPM/ EREPSD,EREPSE,EREPVD,EREPVE,
     *                EREMSD,EREMSE,EREMVD,EREMVE
      COMMON
     *       /EN_SEP/ ESEPSD(0:NDISOS,0:NDISOS),
     *                ESEPSE(0:NDISOS,0:NDISOS),
     *                ESEPVD(0:NDISOS,0:NDISOS),
     *                ESEPVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_SOR/ ESEPOR(NDSEPA)
     *
     *       /EN_STS/ ESPTSD,ESPTSE,ESPTVD,ESPTVE,
     *                ESPSSD,ESPSSE,ESPSVD,ESPSVE
     *
     *       /EN_SPM/ ESPPSD,ESPPSE,ESPPVD,ESPPVE,
     *                ESPMSD,ESPMSE,ESPMVD,ESPMVE
      COMMON
     *       /PN_SEP/ ESEPSP(0:NDISOS),ESEPVP(0:NDISOS)
      COMMON
     *       /PV_SEP/ PSEPVP(0:NDKART,0:NDISOS)
      COMMON
     *       /PN_FST/ EFSOSP(0:NDISOS),EFTOSP(0:NDISOS),EFTESP(0:NDISOS)
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
      COMMON
     *       /ENEFST/ EFSTSD(NDFSTA,0:NDISOS,0:NDISOS),
     *                EFSTSE(NDFSTA,0:NDISOS,0:NDISOS)
      COMMON
     *       /MCPSKY/ NSCR_N,
     *                NDIS_N,
     *                NDSR_N,
     *                NSCS_N,
     *                NSCJ_N,
     *                NCUS_N,
     *                NROS_N,
     *                NDES_N,
     *                NRHSXN,
     *                NRHSYN,
     *                NRHSZN,
     *                NRHCXN,
     *                NRHCYN,
     *                NRHCZN
      COMMON
     *       /DSKPAL/ DSKPAL(1:14)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       (TYPFST(INFSTA),INFSTA=1,NDFSTA)
     *       /'SO','TO','TE'/
C
C=======================================================================
C         THIS SUBROUTINE PRINTS DENSITY INTEGRALS IN THE FUNCTIONAL
C         AND CONTRIBUTIONS TO THE ENERGY DENSITY
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *             1H*,18X,''DENSITY INTEGRALS IN '',
     *                     ''THE SKYRME FUNCTIONAL'',    17X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''      TOTAL(T)'',
     *                     ''        SUM(S)'',4X,
     *                     ''  ISOSCALAR(P)'',
     *                     ''  ISOVECTOR(M)'',4X,            1H*,/,
     *             1H*,13X,''      --------'',
     *                     ''        ------'',4X,
     *                     ''  ------------'',
     *                     ''  ------------'',4X,            1H*,/,
     *           6(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*,/,
     *           6(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('D',NCPALL(I),DCPALL(2*I-1),DCPALL(2*I),
     *                        DCPALL(2*I-1),
     *                       -DCPALL(2*I-1)+2*DCPALL(2*I),I=1,NDCOUP/2)
C
      IF (JETA_T.GE.1)
     *
     *    WRITE(NFIPRI,'(
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('D',NCPALL(I),DCPALL(2*I-1),DCPALL(2*I),
     *                        DCPALL(2*I-1),
     *                       -DCPALL(2*I-1)+2*DCPALL(2*I),
     *                                         I=NDCOUP/2+1,NDCOUP/2+3)
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
      IF (JETAPA.GE.1) WRITE(NFIPRI,'(79(1H*),/,     1H*,77X,1H*,/,
     *             1H*,14X,''PAIRING DENSITY INTEGRALS IN '',
     *                     ''THE SKYRME FUNCTIONAL'',    13X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''     NEUTRONS '',
     *                     ''              '',4X,
     *                     ''      PROTONS '',
     *                     ''              '',4X,            1H*,/,
     *             1H*,13X,''     -------- '',
     *                     ''              '',4X,
     *                     ''      ------- '',
     *                     ''              '',4X,            1H*,/,
     *             1H*,4X,''RRHO'',''  = '',1X,
     *                 2(''('',F13.6,'','',F12.6,'')'',4X),  1H*,/,
     *             1H*,4X,''RTAU'',''  = '',1X,
     *                 2(''('',F13.6,'','',F12.6,'')'',4X),  1H*,/,
     *             1H*,4X,''TAUR'',''  = '',1X,
     *                 2(''('',F13.6,'','',F12.6,'')'',4X),  1H*,/,
     *             1H*,4X,''RLPR'',''  = '',1X,
     *                 2(''('',F13.6,'','',F12.6,'')'',4X),  1H*,/,
     *             1H*,4X,''SCU1'',''  = '',1X,
     *                 2(''('',F13.6,'','',F12.6,'')'',4X),  1H*,/,
     *             1H*,4X,''SCU2'',''  = '',1X,
     *                 2(''('',F13.6,'','',F12.6,'')'',4X),  1H*,/,
     *             1H*,4X,''SCU3'',''  = '',1X,
     *                 2(''('',F13.6,'','',F12.6,'')'',4X),  1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                    79(1H*),/)')
     *
     *         (DSKPAL(2*I-1),DSKPAL(2*I),I=1,7)
C
C=======================================================================
C         PRINTING INTEGRALS OF SYMMETRY-VIOLATING TERMS (PRELIMINARY)
C         SWITCHED OFF STARTING FROM VERSION  2.06B  (20/12/2003). IN
C         THE FUTURE IT SHOULD BE DONE PROPERLY, BECAUSE ONE OF THESE
C         TERMS (DSC) DOES NOT, IN FACT, VIOLATE SYMMETRY AND  SHOULD
C         BE MOVED TO THE REGULAR  TIME-ODD-TERMS  TABLE,  WHERE,  IN
C         ADDITION, THE NEW TERM (F^2) MUST ALSO BE INCLUDED.
C=======================================================================
C
      IF (IROTAT.EQ.1.AND.IVIPRI.GE.1.AND.IVIPRI.LE.2) THEN
C
C=======================================================================
          IF (IVIPRI.EQ.1.AND.NDVIOL.LT.32)
     *        STOP 'FOR IVIPRI=1, NDVIOL=32 IS REQUIRED IN PRIFUN'
          IF (IVIPRI.EQ.2.AND.NDVIOL.LT.56)
     *        STOP 'FOR IVIPRI=2, NDVIOL=56 IS REQUIRED IN PRIFUN'
C=======================================================================
C
          WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *             1H*,1X, ''INTEGRALS OF SYMMETRY-VIOLATING TERMS '',
     *                     ''IN THE ISOSCAL-ISOVECT REPRESENTATION'',
     *                                                    1X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,'' ISOSCALAR(PP)'',
     *                     '' ISOVECTOR(MM)'',4X,
     *                     '' MIXED S-V(PM)'',
     *                     '' MIXED V-S(MP)'',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/)
     *                                               1H*,77X,1H*,/,
     *           4(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/),
     *                                               1H*,77X,1H*,/,
     *           1(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('D',MCPALL(I),VCPALL(4*I-3),VCPALL(4*I-2),
     *                        VCPALL(4*I-1),VCPALL(4*I  ),I=1,8)
C
          IF (IVIPRI.EQ.2) THEN
C
              I9=9
              I14=14
C
              WRITE(NFIPRI,'(
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/),
     *                                               1H*,77X,1H*,/,
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('D',MCPALL(I),VCPALL(4*I-3),VCPALL(4*I-2),
     *                        VCPALL(4*I-1),VCPALL(4*I  ),I=I9,I14)
C
          END IF
C
          WRITE(NFIPRI,'(79(1H*),/)')
C
          WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *             1H*,1X, ''INTEGRALS OF SYMMETRY-VIOLATING TERMS '',
     *                     ''IN THE NEUTRON-PROTON  REPRESENTATION'',
     *                                                    1X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''  NEUTR-NEUTR '',
     *                     ''  PROTO-PROTO '',4X,
     *                     ''  NEUTR-PROTO '',
     *                     ''  PROTO-NEUTR '',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/)
     *                                               1H*,77X,1H*,/,
     *           4(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/),
     *                                               1H*,77X,1H*,/,
     *           1(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/),
     *                                               1H*,77X,1H*)')
     *        ('D',MCPALL(I),
     *        (VCPALL(4*I-3)+VCPALL(4*I-2)+VCPALL(4*I-1)+VCPALL(4*I))/4,
     *        (VCPALL(4*I-3)+VCPALL(4*I-2)-VCPALL(4*I-1)-VCPALL(4*I))/4,
     *        (VCPALL(4*I-3)-VCPALL(4*I-2)-VCPALL(4*I-1)+VCPALL(4*I))/4,
     *        (VCPALL(4*I-3)-VCPALL(4*I-2)+VCPALL(4*I-1)-VCPALL(4*I))/4,
     *                                                            I=1,8)
C
          IF (IVIPRI.EQ.2) THEN
C
              I9=9
              I14=14
C
              WRITE(NFIPRI,'(
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/),
     *                                               1H*,77X,1H*,/,
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2(1PE14.6),4X), 1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *        ('D',MCPALL(I),
     *        (VCPALL(4*I-3)+VCPALL(4*I-2)+VCPALL(4*I-1)+VCPALL(4*I))/4,
     *        (VCPALL(4*I-3)+VCPALL(4*I-2)-VCPALL(4*I-1)-VCPALL(4*I))/4,
     *        (VCPALL(4*I-3)-VCPALL(4*I-2)-VCPALL(4*I-1)+VCPALL(4*I))/4,
     *        (VCPALL(4*I-3)-VCPALL(4*I-2)+VCPALL(4*I-1)-VCPALL(4*I))/4,
     *                                                         I=I9,I14)
C
          END IF
C
          WRITE(NFIPRI,'(79(1H*),/)')
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE ENERGIES OF THE YUKAWA INTERACTION
C=======================================================================
C
      IF (IROTAT.EQ.1.AND.PRIYUK) THEN
C
C=======================================================================
C         ATTENTION: IN ALL VERSIONS AFTER 2.12S AND BEFORE  2.85N,  THE
C                    MINUS  SIGNS  IN  FRONT OF  THE  ZERO-RANGE  DIRECT
C                    YUKAWA ENERGIES BELOW, IN SUBROUTINE "PRIFUN", WERE
C                    MISSING,  WHICH  RESULTED  IN  ALL  THESE  ENERGIES
C                    HAVING THE WRONG SIGNS.
C                    SEE EQ.(10) IN PRC 68, 025501 (2003), WHERE:
C                       1) THE SPIN POTENTIAL IS GIVEN  INSTEAD  OF  THE
C                          NORMAL POTENTIAL AND
C                       2) THE SIGN IN FRONT IS "-" (INCORRECTLY!!!),
C                    AND THUS THE CORRECT NORMAL POTENTIAL, OBTAINED  BY
C                    THE INTEGRATION BY PARTS, SHOULD HAVE THE SIGN "-".
C                    THIS BUG WAS CORRECTED IN VER. 2.85N ON 26/05/2018.
C=======================================================================
C
          EYUKPP=-(DDSRPP-DDSRPM-DDSRMP+DDSRMM)/4
          EYUKNN=-(DDSRPP+DDSRPM+DDSRMP+DDSRMM)/4
          EYUKPN=-(DDSRPP+DDSRPM-DDSRMP-DDSRMM)/4
          EYUKNP=-(DDSRPP-DDSRPM+DDSRMP-DDSRMM)/4
C
          WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *             1H*,13X,''   PROT-PROT  '',
     *                     ''   NEUT-NEUT  '',4X,
     *                     ''   PROT-NEUT  '',
     *                     ''   NEUT-PROT  '',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *              1H*,4X,A1,A4,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'Y','DDSR',EYUKPP,EYUKNN,EYUKPN,EYUKNP
C
          EYUKPP=EYUKAD(1,1)
          EYUKNN=EYUKAD(0,0)
          EYUKPN=EYUKAD(1,0)
          EYUKNP=EYUKAD(0,1)
C
          WRITE(NFIPRI,'(1H*,4X,A1,A4,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'Y','DIR1',EYUKPP,EYUKNN,EYUKPN,EYUKNP
C
          EYUKPP=REAL(EYUK_D(1,1))
          EYUKNN=REAL(EYUK_D(0,0))
          EYUKPN=REAL(EYUK_D(1,0))
          EYUKNP=REAL(EYUK_D(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A1,A4,'' = '',1X,2(2D14.6,4X),    1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          'Y','DIR2',EYUKPP,EYUKNN,EYUKPN,EYUKNP
C
          EYUKPP=(DSCSPP-DSCSPM-DSCSMP+DSCSMM)/4
          EYUKNN=(DSCSPP+DSCSPM+DSCSMP+DSCSMM)/4
          EYUKPN=(DSCSPP+DSCSPM-DSCSMP-DSCSMM)/4
          EYUKNP=(DSCSPP-DSCSPM+DSCSMP-DSCSMM)/4
C
          WRITE(NFIPRI,'(1H*,4X,A1,A4,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'Y','DSCS',EYUKPP,EYUKNN,EYUKPN,EYUKNP
C
          EYUKPP=AIMAG(EYUK_E(1,1))
          EYUKNN=AIMAG(EYUK_E(0,0))
          EYUKPN=AIMAG(EYUK_E(1,0))
          EYUKNP=AIMAG(EYUK_E(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A1,A4,'' = '',1X,2(2D14.6,4X),    1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          'Y','EXC2',EYUKPP,EYUKNN,EYUKPN,EYUKNP
C
          WRITE(NFIPRI,'(                                   79(1H*),/)')
C
      END IF
C
C=======================================================================
C         CALCULATING SUMS OF THE TIME-EVEN AND TIME-ODD CONTRIBUTIONS
C=======================================================================
C
      DO I=1,NDCOUT/2
C
         EISALL(2*I-1)=  DCPALL(2*I-1)*(CCPALL(2*I-1)   +CCPALL(2*I)/2)
         EISALL(2*I  )=(-DCPALL(2*I-1)+ DCPALL(2*I  )*2)*CCPALL(2*I)/2
C
      END DO
C
      EEVE_T=0.0
      EEVE_S=0.0
      EEVE_P=0.0
      EEVE_M=0.0
C
      DO I=1,NDCOUP/4
C
         EEVE_T=EEVE_T+ECPALL(2*I-1)
         EEVE_S=EEVE_S+ECPALL(2*I  )
         EEVE_P=EEVE_P+EISALL(2*I-1)
         EEVE_M=EEVE_M+EISALL(2*I  )
C
      END DO
C
      EEVE_T=EEVE_T+ECPALL(NDCOUP+1)
      EEVE_S=EEVE_S+ECPALL(NDCOUP+2)
      EEVE_P=EEVE_P+EISALL(NDCOUP+1)
      EEVE_M=EEVE_M+EISALL(NDCOUP+2)
C
      EODD_T=0.0
      EODD_S=0.0
      EODD_P=0.0
      EODD_M=0.0
C
      DO I=NDCOUP/4+1,NDCOUP/2
C
         EODD_T=EODD_T+ECPALL(2*I-1)
         EODD_S=EODD_S+ECPALL(2*I  )
         EODD_P=EODD_P+EISALL(2*I-1)
         EODD_M=EODD_M+EISALL(2*I  )
C
      END DO
C
      EODD_T=EODD_T+ECPALL(NDCOUP+3)+ECPALL(NDCOUP+5)
      EODD_S=EODD_S+ECPALL(NDCOUP+4)+ECPALL(NDCOUP+6)
      EODD_P=EODD_P+EISALL(NDCOUP+3)+EISALL(NDCOUP+5)
      EODD_M=EODD_M+EISALL(NDCOUP+4)+EISALL(NDCOUP+6)
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *             1H*,15X,''CONTRIBUTIONS TO ENERGY '',
     *                     ''IN THE SKYRME FUNCTIONAL'', 14X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''    TOTAL(T)  '',
     *                     ''      SUM(S)  '',4X,
     *                     ''  ISOSCALAR(P)'',
     *                     ''  ISOVECTOR(M)'',4X,            1H*,/,
     *             1H*,13X,''    --------  '',
     *                     ''      ------  '',4X,
     *                     ''  ------------'',
     *                     ''  ------------'',4X,            1H*)')
C
      WRITE(NFIPRI,'(  5(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),1H*,/),
     *                   1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),1H*)')
     *         ('E',NCPALL(I),ECPALL(2*I-1),ECPALL(2*I),
     *                        EISALL(2*I-1),EISALL(2*I),I=1,NDCOUP/4)
C
      IF (JETA_T.GE.1)
     *    WRITE(NFIPRI,'(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),1H*)')
     *         ('E',NCPALL(I),ECPALL(2*I-1),ECPALL(2*I),
     *                        EISALL(2*I-1),EISALL(2*I),
     *                                         I=NDCOUP/2+1,NDCOUP/2+1)
C
      WRITE(NFIPRI,'(1H*,13X,2(2(2X,12(1H=)),   4X),          1H*,/,
     *               1H*, 4X,A9,                 2(2F14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *          'SUM EVEN:',EEVE_T,EEVE_S,EEVE_P,EEVE_M
C
      WRITE(NFIPRI,'(  5(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),1H*,/),
     *                   1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),1H*)')
     *         ('E',NCPALL(I),ECPALL(2*I-1),ECPALL(2*I),
     *                        EISALL(2*I-1),EISALL(2*I),I=NDCOUP/4+1,
     *                                                    NDCOUP/2)
C
      IF (JETA_T.GE.1)
     *    WRITE(NFIPRI,'(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),1H*,/,
     *                   1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),1H*)')
     *         ('E',NCPALL(I),ECPALL(2*I-1),ECPALL(2*I),
     *                        EISALL(2*I-1),EISALL(2*I),
     *                                         I=NDCOUP/2+2,NDCOUP/2+3)
C
      WRITE(NFIPRI,'(1H*,13X,2(2(2X,12(1H=)),   4X),          1H*,/,
     *               1H*, 4X,A9,                 2(2F14.6,4X),1H*,/,
     *                                                1H*,77X,1H*,/,
     *                                                     79(1H*))')
     *          'SUM  ODD:',EODD_T,EODD_S,EODD_P,EODD_M
C
C=======================================================================
C
      IF (PRIYUK) THEN
C
          WRITE(NFIPRI,'(                            1H*,77X,1H*,/,
     *             1H*,14X,''CONTRIBUTIONS TO ENERGY '',
     *                     ''OF THE YUKAWA INTERACTION'',14X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''  FACTOR OF G0'',
     *                     ''  FACTOR OF G1'',
     *                     ''  FACTOR OF G2'',4X,
     *                     ''  TOTAL ENERGY'',4X,            1H*,/,
     *             1H*,13X,''  ------------'',
     *                     ''  ------------'',
     *                     ''  ------------'',4X,
     *                     ''  ------------'',4X,            1H*)')
C
          WRITE(NFIPRI,'(
     *            1H*,1X,''  DIRECT = '',1X,2E14.6,2(E14.6,4X),1H*,/,
     *            1H*,1X,''EXCHANGE = '',1X,2E14.6,2(E14.6,4X),1H*,/,
     *            1H*,13X,3(2X,12(1H=)),6X,12(1H=),4X,         1H*,/,
     *            1H*,1X,''   TOTAL = '',1X,2E14.6,2(E14.6,4X),1H*,/,
     *                                                 1H*,77X,1H*,/,
     *                                                      79(1H*))')
     *
     *    EYUKD0,       EYUKD1,       EYUKD2,       EYUKDT,
     *           EYUKE0,       EYUKE1,       EYUKE2,       EYUKET,
     *    EYUKD0+EYUKE0,EYUKD1+EYUKE1,EYUKD2+EYUKE2,EYUKDT+EYUKET
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE ENERGIES OF THE GOGNY INTERACTION
C=======================================================================
C
      IF (I_GOGA.GE.1.AND.NEWGOG.EQ.0) THEN
C
          EGOGPP=REAL(EGOGSD(1,1))
          EGOGNN=REAL(EGOGSD(0,0))
          EGOGPN=REAL(EGOGSD(1,0))
          EGOGNP=REAL(EGOGSD(0,1))
C
          WRITE(NFIPRI,'(                            1H*,77X,1H*,/,
     *             1H*,14X,''CONTRIBUTIONS TO ENERGY '',
     *                     ''OF THE GOGNY INTERACTION'', 15X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''   PROT-PROT  '',
     *                     ''   NEUT-NEUT  '',4X,
     *                     ''   PROT-NEUT  '',
     *                     ''   NEUT-PROT  '',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *              1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','D',EGOGPP,EGOGNN,EGOGPN,EGOGNP
C
          EGOGPP=REAL(EGOGVD(1,1))
          EGOGNN=REAL(EGOGVD(0,0))
          EGOGPN=REAL(EGOGVD(1,0))
          EGOGNP=REAL(EGOGVD(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'VEC_','D',EGOGPP,EGOGNN,EGOGPN,EGOGNP
C
          EGOGPP=REAL(EGOGSE(1,1))
          EGOGNN=REAL(EGOGSE(0,0))
          EGOGPN=REAL(EGOGSE(1,0))
          EGOGNP=REAL(EGOGSE(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','E',EGOGPP,EGOGNN,EGOGPN,EGOGNP
C
          EGOGPP=REAL(EGOGVE(1,1))
          EGOGNN=REAL(EGOGVE(0,0))
          EGOGPN=REAL(EGOGVE(1,0))
          EGOGNP=REAL(EGOGVE(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          'VEC_','E',EGOGPP,EGOGNN,EGOGPN,EGOGNP
C
          WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *             1H*,13X,''    TOTAL(T)  '',
     *                     ''      SUM(S)  '',4X,
     *                     ''  ISOSCALAR(P)'',
     *                     ''  ISOVECTOR(M)'',4X,            1H*,/,
     *             1H*,13X,''    --------  '',
     *                     ''      ------  '',4X,
     *                     ''  ------------'',
     *                     ''  ------------'',4X,            1H*)')
C
          EGOG_T=REAL(EGOTSD)
          EGOG_S=REAL(EGOSSD)
          EGOG_P=REAL(EGOPSD)
          EGOG_M=REAL(EGOMSD)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'SCA_','D',EGOG_T,EGOG_S,EGOG_P,EGOG_M
C
          EGOG_T=REAL(EGOTVD)
          EGOG_S=REAL(EGOSVD)
          EGOG_P=REAL(EGOPVD)
          EGOG_M=REAL(EGOMVD)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'VEC_','D',EGOG_T,EGOG_S,EGOG_P,EGOG_M
C
          EGOG_T=REAL(EGOTSE)
          EGOG_S=REAL(EGOSSE)
          EGOG_P=REAL(EGOPSE)
          EGOG_M=REAL(EGOMSE)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'SCA_','E',EGOG_T,EGOG_S,EGOG_P,EGOG_M
C
          EGOG_T=REAL(EGOTVE)
          EGOG_S=REAL(EGOSVE)
          EGOG_P=REAL(EGOPVE)
          EGOG_M=REAL(EGOMVE)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *          'VEC_','E',EGOG_T,EGOG_S,EGOG_P,EGOG_M
C
          WRITE(NFIPRI,'(                                   79(1H*))')
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE PAIRING ENERGIES OF THE GOGNY INTERACTION
C=======================================================================
C
      IF (IGOGPA.GE.1) THEN
C
          IF (NEWGOG.EQ.0) THEN
C
              PGOGPP=REAL(EGOGSP(1))
              PGOGNN=REAL(EGOGSP(0))
              PGOGPN=0.0D0
              PGOGNP=0.0D0
C
          ELSE
C
              PGOGPP=REAL(EREGSP(1))
              PGOGNN=REAL(EREGSP(0))
              PGOGPN=0.0D0
              PGOGNP=0.0D0
C
          END IF
C
          WRITE(NFIPRI,'(                            1H*,77X,1H*,/,
     *             1H*,14X,''CONTRIBUTIONS TO PAIRING '',
     *                     ''OF THE GOGNY INTERACTION'', 14X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''   PROT-PROT  '',
     *                     ''   NEUT-NEUT  '',4X,
     *                     ''   PROT-NEUT  '',
     *                     ''   NEUT-PROT  '',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *              1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','P',PGOGPP,PGOGNN,PGOGPN,PGOGNP
C
          PGOGPP=REAL(EGOGVP(1))
          PGOGNN=REAL(EGOGVP(0))
          PGOGPN=0.0D0
          PGOGNP=0.0D0
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *          'VEC_','P',PGOGPP,PGOGNN,PGOGPN,PGOGNP
C
          WRITE(NFIPRI,'(                                  79(1H*))')
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE ENERGIES OF THE REGULARIZED SKYRME
C         INTERACTION
C=======================================================================
C
      IF (I_REGA.GE.1.AND.NEWGOG.EQ.0.OR.
     *    I_GOGA.GE.1.AND.NEWGOG.EQ.1) THEN
C
          EREGPP=REAL(EREGSD(1,1))
          EREGNN=REAL(EREGSD(0,0))
          EREGPN=REAL(EREGSD(1,0))
          EREGNP=REAL(EREGSD(0,1))
C
          IF (NEWGOG.EQ.0) THEN
C
              WRITE(NFIPRI,'(                        1H*,77X,1H*,/,
     *             1H*,14X,''CONTRIBUTIONS TO ENERGY '',
     *                     ''OF THE REGULARIZED INTERACTION'',9X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*))')
C
          ELSE IF (NEWGOG.EQ.1) THEN
C
               WRITE(NFIPRI,'(                        1H*,77X,1H*,/,
     *             1H*,14X,''CONTRIBUTIONS TO ENERGY '',
     *                     ''OF THE  G O G N Y  INTERACTION'',9X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*))')
C
          ELSE
C
              STOP ' INCORRCT NEWGOG IN PRIFUN'
C
          END IF
C
          WRITE(NFIPRI,'(                            1H*,77X,1H*,/,
     *             1H*,13X,''   PROT-PROT  '',
     *                     ''   NEUT-NEUT  '',4X,
     *                     ''   PROT-NEUT  '',
     *                     ''   NEUT-PROT  '',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *              1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','D',EREGPP,EREGNN,EREGPN,EREGNP
C
          EREGPP=REAL(EREGVD(1,1))
          EREGNN=REAL(EREGVD(0,0))
          EREGPN=REAL(EREGVD(1,0))
          EREGNP=REAL(EREGVD(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'VEC_','D',EREGPP,EREGNN,EREGPN,EREGNP
C
          EREGPP=REAL(EREGSE(1,1))
          EREGNN=REAL(EREGSE(0,0))
          EREGPN=REAL(EREGSE(1,0))
          EREGNP=REAL(EREGSE(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','E',EREGPP,EREGNN,EREGPN,EREGNP
C
          EREGPP=REAL(EREGVE(1,1))
          EREGNN=REAL(EREGVE(0,0))
          EREGPN=REAL(EREGVE(1,0))
          EREGNP=REAL(EREGVE(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          'VEC_','E',EREGPP,EREGNN,EREGPN,EREGNP
C
          WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *             1H*,13X,''    TOTAL(T)  '',
     *                     ''      SUM(S)  '',4X,
     *                     ''  ISOSCALAR(P)'',
     *                     ''  ISOVECTOR(M)'',4X,            1H*,/,
     *             1H*,13X,''    --------  '',
     *                     ''      ------  '',4X,
     *                     ''  ------------'',
     *                     ''  ------------'',4X,            1H*)')
C
          EREG_T=REAL(ERETSD)
          EREG_S=REAL(ERESSD)
          EREG_P=REAL(EREPSD)
          EREG_M=REAL(EREMSD)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'SCA_','D',EREG_T,EREG_S,EREG_P,EREG_M
C
          EREG_T=REAL(ERETVD)
          EREG_S=REAL(ERESVD)
          EREG_P=REAL(EREPVD)
          EREG_M=REAL(EREMVD)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'VEC_','D',EREG_T,EREG_S,EREG_P,EREG_M
C
          EREG_T=REAL(ERETSE)
          EREG_S=REAL(ERESSE)
          EREG_P=REAL(EREPSE)
          EREG_M=REAL(EREMSE)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'SCA_','E',EREG_T,EREG_S,EREG_P,EREG_M
C
          EREG_T=REAL(ERETVE)
          EREG_S=REAL(ERESVE)
          EREG_P=REAL(EREPVE)
          EREG_M=REAL(EREMVE)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *          'VEC_','E',EREG_T,EREG_S,EREG_P,EREG_M
C
          JDUMMY=0 ! IS USED TO PREVENT THE COMPILER FROM COMPLANING
C
          IF (I_REGA.GE.1) THEN  ! NOT INDENTED
C
          IF (N3LORD.GE.0) THEN
C
              WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *                  1H*,9X,''    ORDER 0     '',
     *                         ''    ORDER 2     '',
     *                         ''    ORDER 4     '',
     *                         ''    0RDER 6     '',4X,          1H*,/,
     *                  1H*,9X,''    -------     '',
     *                         ''    -------     '',
     *                         ''    -------     '',
     *                         ''    -------     '',4X,          1H*)')
C
              WRITE(NFIPRI,'(1H*,1X,A6,'' ='',4(1PE16.8),4X,1H*,/,
     *                       1H*,1X,A6,'' ='',4(1PE16.8),4X,1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *             'EREGOR',(EREGOR(JDUMMY+INREGA),INREGA=1,4),
     *             'ECEGOR',(ECEGOR(JDUMMY+INREGA),INREGA=1,4)
C
              WRITE(NFIPRI,'(                               79(1H*))')
C
          ELSE
C
              IF (N3LORD.LE.-1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,              1H*,77X,1H*,/,
     *                  1H*,9X,''  TERM T0(T00)  '',
     *                         ''  TERM T1(T21)  '',
     *                         ''  TERM T2(T22)  '',
     *                         ''                '',4X,          1H*,/,
     *                  1H*,9X,''  -----------   '',
     *                         ''  -----------   '',
     *                         ''  -----------   '',
     *                         ''                '',4X,          1H*)')
C
              WRITE(NFIPRI,'(1H*,1X,A6,'' ='',3(1PE16.8),20X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *             'EREGOR',(EREGOR(JDUMMY+INREGA),INREGA=1,3)
C
              END IF
C
              IF (N3LORD.LE.-2) THEN
C
                  WRITE(NFIPRI,'(
     *                  1H*,9X,''    TERM T41    '',
     *                         ''    TERM T42    '',
     *                         ''    TERM T43    '',
     *                         ''                '',4X,          1H*,/,
     *                  1H*,9X,''    --------    '',
     *                         ''    --------    '',
     *                         ''    --------    '',
     *                         ''                '',4X,          1H*)')
C
                  WRITE(NFIPRI,'(1H*,1X,A6,'' ='',3(1PE16.8),20X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *                 'EREGOR',(EREGOR(JDUMMY+INREGA),INREGA=4,6)
C
              END IF
C
              IF (N3LORD.LE.-3) THEN
C
                  WRITE(NFIPRI,'(
     *                  1H*,9X,''    TERM T61    '',
     *                         ''    TERM T62    '',
     *                         ''    TERM T63    '',
     *                         ''    TERM T64    '',4X,          1H*,/,
     *                  1H*,9X,''    --------    '',
     *                         ''    --------    '',
     *                         ''    --------    '',
     *                         ''    --------    '',4X,          1H*)')
C
                  WRITE(NFIPRI,'(1H*,1X,A6,'' ='',4(1PE16.8),4X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *                 'EREGOR',(EREGOR(JDUMMY+INREGA),INREGA=7,10)
C
              END IF
C
              WRITE(NFIPRI,'(                           79(1H*))')
C
          END IF   ! NOT INDENTED
C
          END IF
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE ENERGIES OF THE SEPARABLE INTERACTION
C=======================================================================
C
      IF (I_SEPA.GE.1) THEN
C
          ESEPPP=REAL(ESEPSD(1,1))
          ESEPNN=REAL(ESEPSD(0,0))
          ESEPPN=REAL(ESEPSD(1,0))
          ESEPNP=REAL(ESEPSD(0,1))
C
          WRITE(NFIPRI,'(                            1H*,77X,1H*,/,
     *             1H*,14X,''CONTRIBUTIONS TO ENERGY '',
     *                     ''OF THE  SEPARABLE  INTERACTION'',9X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''   PROT-PROT  '',
     *                     ''   NEUT-NEUT  '',4X,
     *                     ''   PROT-NEUT  '',
     *                     ''   NEUT-PROT  '',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *              1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','D',ESEPPP,ESEPNN,ESEPPN,ESEPNP
C
          ESEPPP=REAL(ESEPVD(1,1))
          ESEPNN=REAL(ESEPVD(0,0))
          ESEPPN=REAL(ESEPVD(1,0))
          ESEPNP=REAL(ESEPVD(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'VEC_','D',ESEPPP,ESEPNN,ESEPPN,ESEPNP
C
          ESEPPP=REAL(ESEPSE(1,1))
          ESEPNN=REAL(ESEPSE(0,0))
          ESEPPN=REAL(ESEPSE(1,0))
          ESEPNP=REAL(ESEPSE(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','E',ESEPPP,ESEPNN,ESEPPN,ESEPNP
C
          ESEPPP=REAL(ESEPVE(1,1))
          ESEPNN=REAL(ESEPVE(0,0))
          ESEPPN=REAL(ESEPVE(1,0))
          ESEPNP=REAL(ESEPVE(0,1))
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*,/,
     *                                                    1H*,77X,1H*)')
     *
     *          'VEC_','E',ESEPPP,ESEPNN,ESEPPN,ESEPNP
C
          WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *             1H*,13X,''    TOTAL(T)  '',
     *                     ''      SUM(S)  '',4X,
     *                     ''  ISOSCALAR(P)'',
     *                     ''  ISOVECTOR(M)'',4X,            1H*,/,
     *             1H*,13X,''    --------  '',
     *                     ''      ------  '',4X,
     *                     ''  ------------'',
     *                     ''  ------------'',4X,            1H*)')
C
          ESEP_T=REAL(ESPTSD)
          ESEP_S=REAL(ESPSSD)
          ESEP_P=REAL(ESPPSD)
          ESEP_M=REAL(ESPMSD)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'SCA_','D',ESEP_T,ESEP_S,ESEP_P,ESEP_M
C
          ESEP_T=REAL(ESPTVD)
          ESEP_S=REAL(ESPSVD)
          ESEP_P=REAL(ESPPVD)
          ESEP_M=REAL(ESPMVD)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'VEC_','D',ESEP_T,ESEP_S,ESEP_P,ESEP_M
C
          ESEP_T=REAL(ESPTSE)
          ESEP_S=REAL(ESPSSE)
          ESEP_P=REAL(ESPPSE)
          ESEP_M=REAL(ESPMSE)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*)')
     *
     *          'SCA_','E',ESEP_T,ESEP_S,ESEP_P,ESEP_M
C
          ESEP_T=REAL(ESPTVE)
          ESEP_S=REAL(ESPSVE)
          ESEP_P=REAL(ESPPVE)
          ESEP_M=REAL(ESPMVE)
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2F14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *          'VEC_','E',ESEP_T,ESEP_S,ESEP_P,ESEP_M
C
          JDUMMY=0 ! IS USED TO PREVENT THE COMPILER FROM COMPLANING
C
          IF (N3SERD.GE.0) THEN
C
              NUSEPA=N3SERD+1
C
              WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *                  1H*,9X,''    ORDER 0     '',
     *                         ''    ORDER 2     '',
     *                         ''    ORDER 4     '',
     *                         ''    0RDER 6     '',4X,          1H*,/,
     *                  1H*,9X,''    -------     '',
     *                         ''    -------     '',
     *                         ''    -------     '',
     *                         ''    -------     '',4X,          1H*)')
C
              WRITE(NFIPRI,'(1H*,1X,A6,'' ='',4(1PE16.8),4X,1H*,/,
     *                                          1H*,77X,1H*)')
     *
     *             'ESEPOR',(ESEPOR(JDUMMY+INSEPA),INSEPA=1,4)
C
              WRITE(NFIPRI,'(                               79(1H*))')
C
          ELSE
C
              IF (N3SERD.LE.-1) THEN
C
                  WRITE(NFIPRI,'(79(1H*),/,              1H*,77X,1H*,/,
     *                  1H*,9X,''  TERM T0(T00)  '',
     *                         ''  TERM T1(T21)  '',
     *                         ''  TERM T2(T22)  '',
     *                         ''                '',4X,          1H*,/,
     *                  1H*,9X,''  -----------   '',
     *                         ''  -----------   '',
     *                         ''  -----------   '',
     *                         ''                '',4X,          1H*)')
C
              WRITE(NFIPRI,'(1H*,1X,A6,'' ='',3(1PE16.8),20X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *             'ESEPOR',(ESEPOR(JDUMMY+INSEPA),INSEPA=1,3)
C
              END IF
C
              IF (N3SERD.LE.-2) THEN
C
                  WRITE(NFIPRI,'(
     *                  1H*,9X,''    TERM T41    '',
     *                         ''    TERM T42    '',
     *                         ''    TERM T43    '',
     *                         ''                '',4X,          1H*,/,
     *                  1H*,9X,''    --------    '',
     *                         ''    --------    '',
     *                         ''    --------    '',
     *                         ''                '',4X,          1H*)')
C
                  WRITE(NFIPRI,'(1H*,1X,A6,'' ='',3(1PE16.8),20X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *                 'ESEPOR',(ESEPOR(JDUMMY+INSEPA),INSEPA=4,6)
C
              END IF
C
              IF (N3SERD.LE.-3) THEN
C
                  WRITE(NFIPRI,'(
     *                  1H*,9X,''    TERM T61    '',
     *                         ''    TERM T62    '',
     *                         ''    TERM T63    '',
     *                         ''    TERM T64    '',4X,          1H*,/,
     *                  1H*,9X,''    --------    '',
     *                         ''    --------    '',
     *                         ''    --------    '',
     *                         ''    --------    '',4X,          1H*)')
C
                  WRITE(NFIPRI,'(1H*,1X,A6,'' ='',4(1PE16.8),4X,1H*,/,
     *                                                   1H*,77X,1H*)')
     *
     *                 'ESEPOR',(ESEPOR(JDUMMY+INSEPA),INSEPA=7,10)
C
              END IF
C
              WRITE(NFIPRI,'(                           79(1H*))')
C
          END IF
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE ENERGIES OF THE FINITE-RANGE  SPIN-ORBIT  AND
C         TENSOR INTERACTIONS
C=======================================================================
C
      IF (MAXVAL(I_FSTA).GE.1) THEN
C
          WRITE(NFIPRI,'(                               1H*,77X,1H*,/,
     *             1H*,3X,''CONTRIBUTIONS TO ENERGY OF THE FINITE-'',
     *                    ''RANGE SPIN-ORBIT AND TENSOR TERMS'',
     *                                                       3X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/,
     *                                                  1H*,77X,1H*,/,
     *                    1H*,13X,''   PROT-PROT  '',
     *                            ''   NEUT-NEUT  '',4X,
     *                            ''   PROT-NEUT  '',
     *                            ''   NEUT-PROT  '',4X,        1H*,/,
     *                    1H*,13X,'' -------------'',
     *                            '' -------------'',4X,
     *                            '' -------------'',
     *                            '' -------------'',4X,        1H*)')
C
          DO INFSTA=1,NDFSTA
C
             IF (I_FSTA(INFSTA).GE.1) THEN
C
                 EFSTPP=REAL(EFSTSD(INFSTA,1,1))
                 EFSTNN=REAL(EFSTSD(INFSTA,0,0))
                 EFSTPN=REAL(EFSTSD(INFSTA,1,0))
                 EFSTNP=REAL(EFSTSD(INFSTA,0,1))
C
                 WRITE(NFIPRI,'(
     *           1H*,1X,A2,1X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*)')
     *
     *           TYPFST(INFSTA),'SCA_','D',EFSTPP,EFSTNN,EFSTPN,EFSTNP
C
                 EFSTPP=REAL(EFSTSE(INFSTA,1,1))
                 EFSTNN=REAL(EFSTSE(INFSTA,0,0))
                 EFSTPN=REAL(EFSTSE(INFSTA,1,0))
                 EFSTNP=REAL(EFSTSE(INFSTA,0,1))
C
                 WRITE(NFIPRI,'(
     *           1H*,1X,A2,1X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*)')
     *
     *           TYPFST(INFSTA),'SCA_','E',EFSTPP,EFSTNN,EFSTPN,EFSTNP
C
             END IF
C
          END DO
C
          WRITE(NFIPRI,'(                               1H*,77X,1H*,/,
     *                                                       79(1H*))')
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE PAIRING ENERGIES OF THE REGULARIZED
C         INTERACTION
C=======================================================================
C
      IF (IREGPA.GE.1) THEN
C
          PREGPP=REAL(EREGSP(1))
          PREGNN=REAL(EREGSP(0))
          PREGPN=0.0D0
          PREGNP=0.0D0
C
          WRITE(NFIPRI,'(                            1H*,77X,1H*,/,
     *             1H*,14X,''CONTRIBUTIONS TO PAIRING '',
     *                     ''OF THE REGULARIZED INTERACTION'',8X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''   PROT-PROT  '',
     *                     ''   NEUT-NEUT  '',4X,
     *                     ''   PROT-NEUT  '',
     *                     ''   NEUT-PROT  '',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *              1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','P',PREGPP,PREGNN,PREGPN,PREGNP
C
          PREGPP=REAL(EREGVP(1))
          PREGNN=REAL(EREGVP(0))
          PREGPN=0.0D0
          PREGNP=0.0D0
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *          'VEC_','P',PREGPP,PREGNN,PREGPN,PREGNP
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                   1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                   1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *          'VECX','P',PREGVP(1,1),PREGVP(1,0),PREGPN,PREGNP,
     *          'VECY','P',PREGVP(2,1),PREGVP(2,0),PREGPN,PREGNP,
     *          'VECZ','P',PREGVP(3,1),PREGVP(3,0),PREGPN,PREGNP
C
          WRITE(NFIPRI,'(                                  79(1H*))')
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE PAIRING ENERGIES OF THE SEPARABLE
C         INTERACTION
C=======================================================================
C
      IF (ISEPPA.GE.1) THEN
C
          PSEPPP=REAL(ESEPSP(1))
          PSEPNN=REAL(ESEPSP(0))
          PSEPPN=0.0D0
          PSEPNP=0.0D0
C
          WRITE(NFIPRI,'(                            1H*,77X,1H*,/,
     *             1H*,14X,''CONTRIBUTIONS TO PAIRING '',
     *                     ''OF THE  SEPARABLE  INTERACTION'',8X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''   PROT-PROT  '',
     *                     ''   NEUT-NEUT  '',4X,
     *                     ''   PROT-NEUT  '',
     *                     ''   NEUT-PROT  '',4X,            1H*,/,
     *             1H*,13X,'' -------------'',
     *                     '' -------------'',4X,
     *                     '' -------------'',
     *                     '' -------------'',4X,            1H*,/,
     *              1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),    1H*)')
     *
     *          'SCA_','P',PSEPPP,PSEPNN,PSEPPN,PSEPNP
C
          PSEPPP=REAL(ESEPVP(1))
          PSEPNN=REAL(ESEPVP(0))
          PSEPPN=0.0D0
          PSEPNP=0.0D0
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *          'VEC_','P',PSEPPP,PSEPNN,PSEPPN,PSEPNP
C
          WRITE(NFIPRI,'(1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                   1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                   1H*,4X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*,/,
     *                                                1H*,77X,1H*)')
     *
     *          'VECX','P',PSEPVP(1,1),PSEPVP(1,0),PSEPPN,PSEPNP,
     *          'VECY','P',PSEPVP(2,1),PSEPVP(2,0),PSEPPN,PSEPNP,
     *          'VECZ','P',PSEPVP(3,1),PSEPVP(3,0),PSEPPN,PSEPNP
C
          WRITE(NFIPRI,'(                                  79(1H*))')
C
      END IF
C
C=======================================================================
C         PRINTING AVERAGE ENERGIES OF THE FINITE-RANGE  SPIN-ORBIT  AND
C         TENSOR PAIRING INTERACTIONS
C=======================================================================
C
      IF (MAXVAL(IFSTPA).GE.1) THEN
C
          WRITE(NFIPRI,'(                            1H*,77X,1H*,/,
     *             1H*,10X,''CONTRIBUTIONS TO PAIRING OF THE '',
     *                     ''SPIN-ORBIT AND TENSOR TERMS'',8X,1H*,/,
     *                                                       3X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/,
     *                                                  1H*,77X,1H*,/,
     *                    1H*,13X,''   PROT-PROT  '',
     *                            ''   NEUT-NEUT  '',4X,
     *                            ''   PROT-NEUT  '',
     *                            ''   NEUT-PROT  '',4X,        1H*,/,
     *                    1H*,13X,'' -------------'',
     *                            '' -------------'',4X,
     *                            '' -------------'',
     *                            '' -------------'',4X,        1H*)')
C
          DO INFSTA=1,NDFSTA
C
             IF (IFSTPA(INFSTA).GE.1) THEN
C
                 IF (INFSTA.EQ.1) PFSTPP=REAL(EFSOSP(1))
                 IF (INFSTA.EQ.1) PFSTNN=REAL(EFSOSP(0))
                 IF (INFSTA.EQ.2) PFSTPP=REAL(EFTOSP(1))
                 IF (INFSTA.EQ.2) PFSTNN=REAL(EFTOSP(0))
                 IF (INFSTA.EQ.3) PFSTPP=REAL(EFTESP(1))
                 IF (INFSTA.EQ.3) PFSTNN=REAL(EFTESP(0))
                 PFSTPN=0.0D0
                 PFSTNP=0.0D0
C
                 WRITE(NFIPRI,'(
     *           1H*,1X,A2,1X,A4,A1,'' = '',1X,2(2D14.6,4X),1H*)')
     *
     *           TYPFST(INFSTA),'SCA_','P',PFSTPP,PFSTNN,PFSTPN,PFSTNP
C
             END IF
C
          END DO
C
          WRITE(NFIPRI,'(                               1H*,77X,1H*,/,
     *                                                       79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,*)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE COUMAT(NUMCOU,BOUCOU,ISIMPY,IKERNE)
C=======================================================================
      USE HE_DEN
      USE HCOULO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX)
C
      COMPLEX
     *          SONBAS
C
      COMMON
     *       /HERMEM/ HERONE(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /INTMEM/ TWOWGT(1:NDGAUS,1:NDKART),
     *                TWOPNT(1:NDGAUS,1:NDKART)
      COMMON
     *       /CHARGE/ ECHAR2
C
C=======================================================================
C
      CALL CPUTIM('COUMAT',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(HPPCOU)) THEN
          ALLOCATE (HPPCOU(1:NDBASE,1:NDBASE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HPPCOU','COUMAT')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(HPMCOU)) THEN
          ALLOCATE (HPMCOU(1:NDBASE,1:NDBASE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HPMCOU','COUMAT')
      END IF
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF THE COULOMB
C        POTENTIAL
C=======================================================================
C
      NDEGRE=0
      KFRAGM=0
C
      CALL BEGINC(DE_RHO(1,1,1,1,1),SONBAS,NDEGRE,HERONE,TWOWGT,1,1)
C
      PIOMAS=0.0D0
      ISURFA=1
C
      CALL INTCOU(NUMCOU,BOUCOU,SONBAS,ECHAR2,PIOMAS,ISURFA,
     *                   IKERNE,ISIMPY,KFRAGM,HPPCOU,HPMCOU)
C
C=======================================================================
C
      CALL CPUTIM('COUMAT',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE COULOD(ISIMPY,EKECOD)
C=======================================================================
      USE HCOULO
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          RESULT,EKECOD
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES   DIRECT  CONTRIBUTION  TO  THE
C                      C O U L O M B   E N E R G Y
C        IT ASSUMES THAT THE MATRIX ELEMENTS OF THE COULOMB POTENTIAL
C        HAVE ALREADY BEEN CALCULATED, AND THEN CALCULATES THE  TRACE
C        WITH THE DENSITY MATRIX. IT ASSUMES THAT THE PROTON  DENSITY
C        MATRIX IS PRESENT IN 'BIG_PP' AND 'BIG_PM'
C=======================================================================
C
C=======================================================================
C         CONTRIBUTIONS FORM THE DIAGONAL SIMPLEX BLOCKS
C=======================================================================
C
      RESULT=CMPLX(0.0D0,0.0D0)
C
      DO IBRA=1,LDBASE
         DO IKET=1,LDBASE
C
            RESULT=RESULT+HPPCOU(IBRA,IKET) * (BIG_PP(IKET,IBRA,0)
     *                                        +BIG_PP(IKET,IBRA,1))
C
         END DO
      END DO
C
      EKECOD=RESULT
C
C=======================================================================
C         CONTRIBUTIONS FORM THE OFF-DIAGONAL SIMPLEX BLOCKS
C=======================================================================
C
      IF (ISIMPY.NE.1) THEN
C
          RESULT=CMPLX(0.0D0,0.0D0)
C
          DO IBRA=1,LDBASE
             DO IKET=1,LDBASE
C
                RESULT=RESULT+HPMCOU(IBRA,IKET) * (BIG_PM(IKET,IBRA,1)
     *                                            -BIG_PM(IKET,IBRA,0))
C
             END DO
          END DO
C
          EKECOD=EKECOD+RESULT
C
      END IF
C
      EKECOD=EKECOD/2.0D0
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE YUKMAT(PIMASS,NUMCOU,BOUCOU,ISIMPY)
C=======================================================================
      USE HYUKAW
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DENDIS,SONBAS
C
      DIMENSION
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX)
C
      COMMON
     *       /HERMEM/ HERONE(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /INTMEM/ TWOWGT(1:NDGAUS,1:NDKART),
     *                TWOPNT(1:NDGAUS,1:NDKART)
      COMMON
     *       /DISDEN/ DENDIS(NDXHRM,NDYHRM,NDZHRM,0:NDISOS)
C
C=======================================================================
C
      CALL CPUTIM('YUKMAT',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(HPPYUK)) THEN
          ALLOCATE (HPPYUK(1:NDBASE,1:NDBASE,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HPPYUK','YUKMAT')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(HPMYUK).AND.ISIMPY.NE.1) THEN
          ALLOCATE (HPMYUK(1:NDBASE,1:NDBASE,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HPMYUK','YUKMAT')
      END IF
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF THE YUKAWA
C        POTENTIAL FOR THE "DIV S" DENSITY AS THE SOURCE
C=======================================================================
C
      NDEGRE=0
      ISURFA=0
      IKERNE=0
      KFRAGM=0
C
C=======================================================================
C         ATTENTION: IN ALL VERSIONS AFTER 2.08C AND BEFORE  2.85N,  THE
C                    MINUS SIGN IN FRONT OF THE "FACTOR"  IN  SUBROUTINE
C                    "YUKMAT" WAS MISSING, WHICH RESULTED IN ALL  YUKAWA
C                    DIRECT POTENTIALS AND ENERGIES, CALCULATED  BY  THE
C                    GREEN-FUNCTION  METHOD,  HAVING  THE  WRONG   SIGN.
C                    SEE EQ.(9) IN PRC 68, 025501 (2003), WHERE THE SPIN
C                    POTENTIAL IS GIVEN INSTEAD OF THE NORMAL POTENTIAL,
C                    AND THEREFORE THE SIGN IN FRONT IS "+" (CORRECTLY),
C                    AND THUS THE  NORMAL  POTENTIAL,  OBTAINED  BY  THE
C                    INTEGRATION BY PARTS, SHOULD  HAVE  THE  SIGN  "-".
C                    THIS BUG WAS CORRECTED IN VER. 2.85N ON 25/05/2018.
C=======================================================================
C
      FACTOR=-PIMASS**2/(16.0D0*ATAN(1.0D0))
C
      DO ICHARG=0,NDISOS
C
         CALL BEGINC(DENDIS(1,1,1,ICHARG),
     *               SONBAS,NDEGRE,HERONE,TWOWGT,1,1)
C
         CALL INTCOU(NUMCOU,BOUCOU,SONBAS,FACTOR,PIMASS,ISURFA,
     *                 IKERNE,ISIMPY,KFRAGM,HPPYUK(1,1,ICHARG),
     *                                      HPMYUK(1,1,ICHARG))
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('YUKMAT',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE YUKAWD(ISIMPY,ICHARG)
C=======================================================================
      USE HYUKAW
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          RESULT
C
C=======================================================================
      COMMON
     *       /ENEYUK/ EYUKAD(0:NDISOS,0:NDISOS)
C
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES   DIRECT  CONTRIBUTION  TO  THE
C                      Y U K A W A   E N E R G Y
C        IT ASSUMES THAT THE MATRIX ELEMENTS OF THE YUKAWA POTENTIALS
C        HAVE ALREADY BEEN CALCULATED, AND THEN CALCULATES THE  TRACE
C        WITH THE DENSITY MATRIX. IT ASSUMES THAT THE DENSITY  MATRIX
C        IS PRESENT IN 'BIG_PP' AND 'BIG_PM'
C=======================================================================
C
      DO JCHARG=0,NDISOS
C
C=======================================================================
C         CONTRIBUTIONS FORM THE DIAGONAL SIMPLEX BLOCKS
C=======================================================================
C
         RESULT=CMPLX(0.0D0,0.0D0)
C
         DO IBRA=1,LDBASE
            DO IKET=1,LDBASE
C
               RESULT=RESULT+HPPYUK(IBRA,IKET,JCHARG)
     *                                        *(BIG_PP(IKET,IBRA,0)
     *                                        + BIG_PP(IKET,IBRA,1))
C
            END DO
         END DO
C
         EYUKAD(JCHARG,ICHARG)=REAL(RESULT)
C
C=======================================================================
C         CONTRIBUTIONS FORM THE OFF-DIAGONAL SIMPLEX BLOCKS
C=======================================================================
C
         IF (ISIMPY.NE.1) THEN
C
             RESULT=CMPLX(0.0D0,0.0D0)
C
             DO IBRA=1,LDBASE
                DO IKET=1,LDBASE
C
                   RESULT=RESULT+HPMYUK(IBRA,IKET,JCHARG)
     *                                            *BIG_PM(IKET,IBRA,0)
C
                END DO
             END DO
C
             EYUKAD(JCHARG,ICHARG)=EYUKAD(JCHARG,ICHARG)-2*REAL(RESULT)
C
         END IF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE COULOE(EKECOE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DENSIC,DENCHC,DENHAM,EKECOE
C
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
      COMMON
     *       /EXCHAN/ COULEX
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE EXCHANGE CONTRIBUTION TO THE
C                       C O U L O M B   E N E R G Y
C=======================================================================
C        ATTENTION --->  IN  THIS  SUBROUTINE  THE  INTEGRAND HAS TO
C        BE  CALCULATED  WITHOUT  THE  EXPONENTIAL  FACTOR  SQUARED,
C        BECAUSE SUCH A FACTOR IS INCLUDED  IN THE GAUSS INTEGRATION
C        WEIGHTS.  THEREFORE,  THE  COULOMB  EXCHANGE ENERGY DENSITY
C        IS  BELOW  DIVIDED  BY THE SQUARE OF THE  "EXPAUX"   ARRAY.
C=======================================================================
C
      EKECOE=CMPLX(0.0D0,0.0D0)
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               DENHAM = DENCHC(IX,IY,IZ) ** ( 4./3.)
     *                / EXPAUX(IX,IY,IZ,1) / EXPAUX(IX,IY,IZ,1)
C
               W_HERM=FOURWG(IX,1)*FOURWG(IY,2)*FOURWG(IZ,3)
C
               EKECOE=EKECOE+W_HERM*DENHAM
C
            END DO
         END DO
      END DO
C
      EKECOE = COULEX * EKECOE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE COUENE(ISIMPY,ICOTYP,ICOUDI,
     *                  ICOUEX,IDOTHC,EKECOD,EKESCA,EKEVEC)
C=======================================================================
      USE GAUSTO
      USE COUSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          EKECOD,EKESCA,EKEVEC
      COMPLEX
     *          C_ZERO
C=======================================================================
C
      DIMENSION
     *          COUSTR(ND_COU,NDCOTY),COULAR(ND_COU,NDCOTY)
      DIMENSION
     *          XNODES(ND_COU),WEIGHT(ND_COU)
      DIMENSION
     *          NU_COU(NDCOTY)
C
C=======================================================================
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CHARGE/ ECHAR2
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C           HERE ARE THE FITS OF THE COULOMB POTENTIAL
C=======================================================================
C
      DATA
     *      (COUSTR(INYUKA,2),COULAR(INYUKA,2),INYUKA=1,2)
     *
     *    / 1.78   , 0.84   ,
     *      0.347  , 0.0135 /
      DATA
     *      NU_COU(2)/2/
C
C=======================================================================
C
      DATA
     *      (COUSTR(INYUKA,3),COULAR(INYUKA,3),INYUKA=1,3)
     *
     *    / 1.95   , 2.13   ,
     *      0.637  , 0.170  ,
     *      0.207  , 0.0063 /
      DATA
     *      NU_COU(3)/3/
C
C=======================================================================
C
      DATA
     *      (COUSTR(INYUKA,4),COULAR(INYUKA,4),INYUKA=1,4)
     *
     *    / 1.98   , 3.62   ,
     *      0.818  , 0.547  ,
     *      0.329  , 0.0688 ,
     *      0.156  , 0.00414/
      DATA
     *      NU_COU(4)/4/
C
C=======================================================================
C
      DATA
     *      (COUSTR(INYUKA,5),COULAR(INYUKA,5),INYUKA=1,5)
     *
     *    / 1.951  , 5.12   ,
     *      0.922  , 1.12   ,
     *      0.4423 , 0.227  ,
     *      0.213  , 0.0398 ,
     *      0.1304 , 0.00308/
      DATA
     *      NU_COU(5)/5/
C
C=======================================================================
C
      DATA
     *      (COUSTR(INYUKA,6),COULAR(INYUKA,6),INYUKA=1,6)
     *
     *    / 1.900  , 6.54    ,
     *      0.973  , 1.81    ,
     *      0.526  , 0.493   ,
     *      0.282  , 0.126   ,
     *      0.1592 , 0.0277  ,
     *      0.1147 , 0.00245 /
      DATA
     *      NU_COU(6)/6/
C
C=======================================================================
C
      DATA
     *      (COUSTR(INYUKA,7),COULAR(INYUKA,7),INYUKA=1,7)
     *
     *    / 1.842  , 7.8    ,
     *      0.991  , 2.56   ,
     *      0.580  , 0.850  ,
     *      0.341  , 0.274  ,
     *      0.2015 , 0.0833 ,
     *      0.1298 , 0.0213 ,
     *      0.1036 , 0.00204 /
      DATA
     *      NU_COU(7)/7/
C
C=======================================================================
C
      CALL CPUTIM('COUENE',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(COULSV)) THEN
          ALLOCATE (COULSV(NDBASE,NDBASE,0:NDKART,NDTWBL),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('COULSV','COUENE')
      END IF
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES BY EXPANDING INTO GAUSSIANS:
C        1) THE COULOMB  DIRECT  MEAN-FIELDS AND ENERGIES (FOR ICOUDI=2)
C        2) THE COULOMB EXCHANGE MEAN-FIELDS AND ENERGIES (FOR ICOUEX=2)
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IF (ICOUDI.NE.2.AND.ICOUEX.NE.2)
     *    STOP 'COUENE CALLED WITH INCORECT VALUES OF ICOUDI/ICOUEX'
C
      IF (ICOTYP.EQ.0.OR.ICOTYP.EQ.-1.OR.ICOTYP.LT.-7.OR.
     *    -ICOTYP.GT.NDCOTY.OR.ICOTYP.GT.ND_COU)
     *    STOP 'COUENE CALLED WITH INCORECT VALUE OF ICOTYP'
C
C=======================================================================
C
      IF (ICOTYP.LT.0) THEN
C
          JCOTYP=-ICOTYP
C
      ELSE
C
C=======================================================================
C         HERE WE CALCULATE THE EXPANSION INTO GAUSSIANS BASED ON
C         FORMULA (A14) OF PRC 53-2809 AND NOTES 8-71
C=======================================================================
C
          JCOTYP=1
          NU_COU(1)=ICOTYP
C
          HOMLEN=MAX(1.0D0/HOMSCA(1,1),
     *               1.0D0/HOMSCA(2,1),
     *               1.0D0/HOMSCA(3,1))
C
          CALL GAULEG(0.0D0,1.0D0,XNODES,WEIGHT,NU_COU(1))
C
          DO INCOUL=1,NU_COU(1)
C
             COUSTR(INCOUL,1)=2.0D0/SQRT(PI)*WEIGHT(INCOUL)/HOMLEN
     *                       /(1.0D0-XNODES(INCOUL)**2)**1.5D0
             COULAR(INCOUL,1)=XNODES(INCOUL)**2/HOMLEN**2
     *                       /(1.0D0-XNODES(INCOUL)**2)
C
          END DO
C
      END IF
C
C=======================================================================
C         ATTENTION: UP TO THE VERSION 2.43D, THE COULOMB ENERGIES BELOW
C                    WERE UNCONDITIONALLY SET TO ZERO, WHICH RESULTED IN
C                    - THE  DIRECT  COULOMB ENERGY "EKECOD" BEING  EQUAL
C                      TO ZERO FOR ICOUDI=1 AND ICOUEX=2, AND
C                    - THE EXCHANGE COULOMB ENERGY "EKECOE" BEING  EQUAL
C                      TO ZERO FOR ICOUDI=2 AND ICOUEX=1.
C                    THIS BUG HAS BEEN CORRECTED  IN  VERSION  2.43E  ON
C                    30/10/09.
C=======================================================================
C
      IF (ICOUDI.EQ.2) EKECOD=C_ZERO
      IF (ICOUEX.EQ.2) EKESCA=C_ZERO
      IF (ICOUEX.EQ.2) EKEVEC=C_ZERO
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      COULSV=C_ZERO
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER GAUSSIANS THAT APPROXIMATE THE
C        COULOMB POTENTIAL
C=======================================================================
C
C
      NXMAXX=NXMAXV(1)
      NYMAXX=NYMAXV(1)
      NZMAXX=NZMAXV(1)
C
      DO INCOUL=1,NU_COU(JCOTYP)
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
         GOGWID=1.0D0/SQRT(COULAR(INCOUL,JCOTYP))
C
         IF (IDOTHC.NE.1) THEN
C
            CALL DEFGOG(NXMAXX,NXHERM,1,GOGWID,
     *                 GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                             GAUX41,GAUX42,GAUX43)
            CALL DEFGOG(NYMAXX,NYHERM,2,GOGWID,
     *                 GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                             GAUY41,GAUY42,GAUY43)
            CALL DEFGOG(NZMAXX,NZHERM,3,GOGWID,
     *                 GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                             GAUZ41,GAUZ42,GAUZ43)
C
         ELSE
C
            MORDER=0
            CALL DEVTHC(MORDER,NXMAXX,1)
            CALL DEVTHC(MORDER,NYMAXX,2)
            CALL DEVTHC(MORDER,NZMAXX,3)
C
            CALL DEFTHC(MORDER,NDXMAX,NXMAXX,NXHERM,1,GOGWID)
            CALL DEFTHC(MORDER,NDYMAX,NYMAXX,NYHERM,2,GOGWID)
            CALL DEFTHC(MORDER,NDZMAX,NZMAXX,NZHERM,3,GOGWID)
C
         END IF
C
         IF (ICOUDI.EQ.2) THEN
C
             I_PART=2
C
             IF (IDOTHC.NE.1) THEN
C
                 IDENSI=0
                 CALL GAUOPT(ISIMPY,ICOUDI,I_PART,IDENSI)
C
             ELSE
C
                 CALL GAUTHC(ISIMPY,I_PART)
C
             END IF
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
             EKECOD=EKECOD+COUSTR(INCOUL,JCOTYP)
     *                    *GAUAVR(0,0,0,1,1)*ECHAR2/2
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
             DO IKET=1,LDBASE
                DO IBRA=1,LDBASE
C
                   COULSV(IBRA,IKET,0,1)=
     *             COULSV(IBRA,IKET,0,1)+COUSTR(INCOUL,JCOTYP)
     *                                *GAUFIL(0,IBRA,IKET,0,1)*ECHAR2
C
                END DO
             END DO
C
         END IF
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
         IF (ICOUEX.EQ.2) THEN
C
             I_PART=1
             IF (IDOTHC.NE.1) THEN
C
                 CALL EXCGOG(NXMAXX,
     *                 GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                             GAUX41,GAUX42,GAUX43)
                 CALL EXCGOG(NYMAXX,
     *                 GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                             GAUY41,GAUY42,GAUY43)
                 CALL EXCGOG(NZMAXX,
     *                 GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                             GAUZ41,GAUZ42,GAUZ43)
                 IDENSI=0
                 CALL GAUOPT(ISIMPY,ICOUEX,I_PART,IDENSI)
C
             ELSE
C
                 CALL GAUTHC(ISIMPY,I_PART)
C
             END IF
C
C=======================================================================
C        ATTENTION: ADDITIONAL FACTORS OF 1/2 BELOW RESULT FROM  THE
C                   CONVENTIONS USED  FOR  SPIN  AVERAGING,  NAMELY:
C                       1. THE SCALAR PART OF THE DENSITY MATRIX  IS
C                          DEFINED AS A SUM OF SPIN-UP AND SPIN-DOWN
C                          COMPONENTS, I.E., AS  A  TRACE  WITH  THE
C                          IDENTITY SPIN  MATRIX,  SEE  PRC69-014316
C                          EQ. (15A)
C                       2. THE VECTOR PART OF THE DENSITY MATRIX  IS
C                          DEFINED AS A TRACE WITH  THE  PAULI  SPIN
C                          MATRIX, SEE PRC69-014316 EQ. (15A)
C                       3. THE SCALAR PART  OF  THE  MEAN  FIELD  IS
C                          DEFINED AS A COEFFICIENT OF THE  IDENTITY
C                          SPIN MATRIX, SEE PRC69-014316 EQ. (84B)
C                       4. THE VECTOR PART  OF  THE  MEAN  FIELD  IS
C                          DEFINED AS A  COEFFICIENT  OF  THE  PAULI
C                          SPIN MATRIX, SEE PRC69-014316 EQ. (84A)
C                   AS A RESULT OF THESE DEFINITIONS WE HAVE:
C                      1. THE SCALAR PART OF THE DIRECT  MEAN  FIELD
C                         ABOVE IS THE SPACE SUM OF THE SCALAR  PART
C                         OF THE DENSITY MATRIX
C                      2. THE SCALAR PART OF THE EXCHANGE MEAN FIELD
C                         IS EQUAL TO  O N E   H A L F  OF THE SPACE
C                         SUM OF THE  SCALAR  PART  OF  THE  DENSITY
C                         MATRIX
C                      3. THE VECTOR PART OF THE EXCHANGE MEAN FIELD
C                         IS EQUAL TO  O N E   H A L F  OF THE SPACE
C                         SUM OF THE  VECTOR  PART  OF  THE  DENSITY
C                         MATRIX
C                   SEE DETAILS IN NOTES 8-71
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE EXCHANGE TERM
C=======================================================================
C
             EKESCA=EKESCA-COUSTR(INCOUL,JCOTYP)*ECHAR2/2/2
     *                    * GAUAVR(0,0,0,1,1)
C
             EKEVEC=EKEVEC-COUSTR(INCOUL,JCOTYP)*ECHAR2/2/2
     *                    *(GAUAVR(0,1,1,1,1)
     *                     +GAUAVR(0,2,2,1,1)
     *                     +GAUAVR(0,3,3,1,1))
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
             DO KARTEZ=0,NDKART
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      COULSV(IBRA,IKET,KARTEZ,1)=
     *                COULSV(IBRA,IKET,KARTEZ,1)-COUSTR(INCOUL,JCOTYP)
     *                            *GAUFIL(0,IBRA,IKET,KARTEZ,1)*ECHAR2/2
C
                   END DO
                END DO
             END DO
C
         END IF
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('COUENE',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GENGAU(N_MAXX,NGAUSS,KARTEZ,GOGWID,GAUEL0,LTWCEN)
C
C=======================================================================
      USE hfodd_sizes
      USE GAUNEW
C=======================================================================
      COMMON
     *       /SCALNG/ HOMSCA(1:NDKART,1:NDTWCE)
      COMMON
     *       /CENPOS/ CENCOR(1:NDKART,1:NDTWCE)
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *      /HERMIN/  INTWHE(1:NDTWCE,1:NDTWCE,1:NDTWCE,1:NDTWCE)
      COMMON
     *       /FACHER/ HERFAC(0:ND2MAX)
C=======================================================================
      DIMENSION
     *          P_MATR(2,2)
      DIMENSION
     *          EIGVAL(2)
      DIMENSION
     *          WORK(21),IWORK(13)
      DIMENSION
     *          PHER_I(N_MAXX+1),PHER_J(N_MAXX+1),
     *          PHERIP(N_MAXX+1),PHERJP(N_MAXX+1),
     *          DHERMI(N_MAXX+1)
      DIMENSION
     *          HERP_I(0:N_MAXX,1:NGAUSS,1:NGAUSS),
     *          HERPIP(0:N_MAXX,1:NGAUSS,1:NGAUSS),
     *          HERP_J(0:N_MAXX,1:NGAUSS,1:NGAUSS),
     *          HERPJP(0:N_MAXX,1:NGAUSS,1:NGAUSS)
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          XHERMI(NDGAUS),WHERMI(NDGAUS)
C=======================================================================
C     HERE IS SOME SPACE FOR SOME COMMENTS AFTER THE SUBROUTINE IS DONE
C=======================================================================
C
C      AT THE MOMENT THIS ARRAY IS TOO LARGE :(
C
C      IF (.NOT.ALLOCATED(GENGA0)) THEN
C          ALLOCATE (GENGA0(0:NDBASE,0:NDBASE,0:NDBASE,0:NDBASE,
C     *                              1:NDKART,1:NDTWHE),STAT=IALLOC)
C          IF (IALLOC.NE.0) CALL NOALLO('GENGA0','GENGAU')
C      END IF
C
C=======================================================================
C     HERE WE RECYCLE IND4HK. IKLJ -> IJI'J' IN THE NOTES
C=======================================================================
C
      CALL CPUTIM('GENGAU',1)
C=======================================================================
C
      I  =IND4HI(LTWCEN)
      J  =IND4HK(LTWCEN)
      IP =IND4HL(LTWCEN)
      JP =IND4HJ(LTWCEN)
C
C=======================================================================
C     GIVEN THE QUADRATIC FORM A*X_1^2+B*X_2^2+C*X_1*X_2+D*X_1+E*X_2+F
C     WE DEFINE THE MATRIX OF COEFFICIENTS
C
C                             |  A   C/2 |
C                         P = |          |
C                             | C/2   B  |
C
C     TO ELIMINATE THE TERM PROPORTIONAL TO X_1*X_2. THEN, THE SET OF
C     COEFFICIENTS ARE CHANGED ACCORDING TO THE LINEAR TRANSFORMATION.
C     THE NEW COFFICIENTS ARE USED TO DEFINE:
C         - THE OVERALL FACTOR THAT MULTIPLY THE INTEGRAL OF EVERY
C           GAUSSIAN IN EVERY DIRECTION FOR DIFFERENT CENTRE INDICES
C          (TRACOU)
C         - THE NODES OF INTEGRATION (ARGUMENTS OF HERMITE POLYNOMIALS)
C
C=======================================================================
C     DEFINING THE MATRIX OF THE QUADRATIC TERMS
C=======================================================================
C
      P_MATR(1,1)=0.5D0* (HOMSCA(KARTEZ,I)**2+HOMSCA(KARTEZ,IP)**2
     *                     +2*GOGWID)
C
      P_MATR(1,2)=-GOGWID
      P_MATR(2,1)=-GOGWID
C
      P_MATR(2,2)=0.5D0* (HOMSCA(KARTEZ,J)**2+HOMSCA(KARTEZ,JP)**2
     *                     +2*GOGWID)
C
C=======================================================================
C     DEFINING THE COEFFICIENTS OF THE LINEAR TERMS IN X_1 AND X_2
C=======================================================================
C
      COGA_D=-( CENCOR(KARTEZ,I )*HOMSCA(KARTEZ,I )**2
     *          +  CENCOR(KARTEZ,IP)*HOMSCA(KARTEZ,IP)**2 )
C
      COGA_E=-( CENCOR(KARTEZ,J )*HOMSCA(KARTEZ,J )**2
     *          +  CENCOR(KARTEZ,JP)*HOMSCA(KARTEZ,JP)**2 )
C
C=======================================================================
C     DEFINING THE INDEPENDENT TERM
C=======================================================================
C
      COGA_F= 0.5D0*( CENCOR(KARTEZ,I )**2*HOMSCA(KARTEZ,I )**2
     *             +  CENCOR(KARTEZ,IP)**2*HOMSCA(KARTEZ,IP)**2
     *             +  CENCOR(KARTEZ,J )**2*HOMSCA(KARTEZ,J )**2
     *             +  CENCOR(KARTEZ,JP)**2*HOMSCA(KARTEZ,JP)**2 )
C
C=======================================================================
C     DIAGONALISING P_MATR. EIGENVECTOR MATRIX REPLACES P_MATR
C=======================================================================
C
      CALL DSYEVD('V','L',2,P_MATR,2,EIGVAL,WORK,21,IWORK,13,INFO)
C
C=======================================================================
C     DEFINING TRANSFORMED LINEAR AND INDEPENT TERMS
C=======================================================================
C
      COGADP=COGA_D*P_MATR(1,1)+COGA_E*P_MATR(2,1)
      COGAEP=COGA_D*P_MATR(1,2)+COGA_E*P_MATR(2,2)
C
      COGAFP=COGA_F-COGADP**2/(4*EIGVAL(1))-COGAEP**2/(4*EIGVAL(2))
C
C=======================================================================
C     DEFINING JACOBIAN OVER SQRT OF EIGENVALUES
C=======================================================================
C
      COUFAC=ABS(P_MATR(1,1)*P_MATR(2,2)-P_MATR(2,1)*P_MATR(1,2))
     *             / SQRT(EIGVAL(1)*EIGVAL(2))
C
C=======================================================================
C     DEFINING OVERALL TRANSFORMATION COEFFICIENT
C=======================================================================
C
      TRACOU = COUFAC*EXP(-COGAFP)
     *          * SQRT(HOMSCA(KARTEZ,I)*HOMSCA(KARTEZ,IP)
     *          *      HOMSCA(KARTEZ,J)*HOMSCA(KARTEZ,JP))
C
C=======================================================================
C     DEFINING HERMITE POLYNOMIALS IN THE NODES OF INTEGRATION
C=======================================================================
C
      CALL HERMIT(NGAUSS,XHERMI,WHERMI,NDGAUS)
C
      DO IZERO1=1,NGAUSS
         DO IZERO2=1,NGAUSS
C
            X_1 = P_MATR(1,1)/SQRT(EIGVAL(1))
     *       *       (XHERMI(IZERO1)-0.5D0*COGADP/SQRT(EIGVAL(1)))
     *       +        P_MATR(1,2)/SQRT(EIGVAL(2))
     *       *       (XHERMI(IZERO2)-0.5D0*COGAEP/SQRT(EIGVAL(2)))
C
            X_2 = P_MATR(2,1)/SQRT(EIGVAL(1))
     *       *       (XHERMI(IZERO1)-0.5D0*COGADP/SQRT(EIGVAL(1)))
     *       +        P_MATR(2,2)/SQRT(EIGVAL(2))
     *       *       (XHERMI(IZERO2)-0.5D0*COGAEP/SQRT(EIGVAL(2)))
C
            XZER_I=HOMSCA(KARTEZ,I )*(X_1-CENCOR(KARTEZ,I ))
            XZERIP=HOMSCA(KARTEZ,IP)*(X_1-CENCOR(KARTEZ,IP))
            XZER_J=HOMSCA(KARTEZ,J )*(X_2-CENCOR(KARTEZ,J ))
            XZERJP=HOMSCA(KARTEZ,JP)*(X_2-CENCOR(KARTEZ,JP))
C
            CALL D_HERM(XZER_I,N_MAXX,PHER_I,DHERMI,N_MAXX+1)
            CALL D_HERM(XZERIP,N_MAXX,PHERIP,DHERMI,N_MAXX+1)
            CALL D_HERM(XZER_J,N_MAXX,PHER_J,DHERMI,N_MAXX+1)
            CALL D_HERM(XZERJP,N_MAXX,PHERJP,DHERMI,N_MAXX+1)
C
            DO N=0,N_MAXX
               HERP_I(N,IZERO1,IZERO2)= PHER_I(N+1)/HERFAC(N)
               HERPIP(N,IZERO1,IZERO2)= PHERIP(N+1)/HERFAC(N)
               HERP_J(N,IZERO1,IZERO2)= PHER_J(N+1)/HERFAC(N)
               HERPJP(N,IZERO1,IZERO2)= PHERJP(N+1)/HERFAC(N)
            END DO
C
         END DO
      END DO
C
C=======================================================================
C     DEFINING MATRIX ELEMENTS OF THE GAUSSIAN
C=======================================================================
C
C      GENGA0=0.0D0
C
C      DO N=0,N_MAXX
C         DO M=0,N_MAXX
C            DO NP=0,N_MAXX
C               DO MP=0,N_MAXX
C
C                  DO IZERO1=1,NGAUSS
C                     DO IZERO2=1,NGAUSS
C
C                        GENGA0(NP,MP,N,M,LTWCEN,KARTEZ)=
C     *        +         GENGA0(NP,MP,N,M,LTWCEN,KARTEZ) + TRACOU
C     *        * WHERMI(IZERO1)    *    WHERMI(IZERO2)
C     *        * HERP_I(N ,IZERO1,IZERO2) * HERP_J(M ,IZERO1,IZERO2)
C     *        * HERPIP(NP,IZERO1,IZERO2) * HERPJP(MP,IZERO1,IZERO2)
C
C                     END DO !IZERO2
C                 END DO !IZERO1
C
C               END DO !MP
C            END DO !NP
C         END DO !M
C      END DO !N
C
C=======================================================================
C     DELIVER THE SPECIFIC TERM TO CO2ENE
C=======================================================================
C
C      GAUEL0(:,:,:,:)=GENGA0(:,:,:,:,LTWCEN,KARTEZ)
C
C=======================================================================
C
      GAUEL0=0.0D0
C
      DO N=0,N_MAXX
         DO M=0,N_MAXX
            DO NP=0,N_MAXX
               DO MP=0,N_MAXX
C
                  DO IZERO1=1,NGAUSS
                     DO IZERO2=1,NGAUSS
C
                        GAUEL0(N,M,NP,MP)=
     *        +         GAUEL0(N,M,NP,MP) + TRACOU
     *        * WHERMI(IZERO1)    *    WHERMI(IZERO2)
     *        * HERP_I(N ,IZERO1,IZERO2) * HERP_J(M ,IZERO1,IZERO2)
     *        * HERPIP(NP,IZERO1,IZERO2) * HERPJP(MP,IZERO1,IZERO2)
C
                     END DO !IZERO2
                  END DO !IZERO1
C
               END DO !MP
            END DO !NP
         END DO !M
      END DO !N
C
C=======================================================================
C
      CALL CPUTIM('GENGAU',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CO2ENE(ISIMPY,ICOTYP,ICOUDI,ICOUEX,ICOUPA,
     *                  EKECOD,EKESCA,EKEVEC,ITWCEN,LDTWCE)
C=======================================================================
      USE GAUSTO
      USE COUSTO
      USE CPASTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          EKECOD,EKESCA,EKEVEC,EKPSCA,EKPVEC
      COMPLEX
     *          C_ZERO
C=======================================================================
C
      DIMENSION
     *          COUSTR(ND_COU),COULAR(ND_COU)
      DIMENSION
     *          XNODES(ND_COU),WEIGHT(ND_COU)
C
C=======================================================================
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /PN_COU/ EKPSCA,EKPVEC
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /CHARGE/ ECHAR2
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
C
C=======================================================================
C
      CALL CPUTIM('CO2ENE',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(COULSV)) THEN
          ALLOCATE (COULSV(NDBASE,NDBASE,0:NDKART,NDTWBL),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('COULSV','CO2ENE')
      END IF
C
      IF (.NOT.ALLOCATED(COUPSV).AND.ICOUPA.EQ.2) THEN
          ALLOCATE (COUPSV(NDBASE,NDBASE,0:NDKART),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('COUPSV','CO2ENE')
      END IF
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES BY EXPANDING INTO GAUSSIANS:
C        1) THE COULOMB  DIRECT  MEAN-FIELDS AND ENERGIES (FOR ICOUDI=2)
C        2) THE COULOMB EXCHANGE MEAN-FIELDS AND ENERGIES (FOR ICOUEX=2)
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      IF (ICOUDI.NE.2.AND.ICOUEX.NE.2)
     *    STOP 'CO2ENE CALLED WITH INCORECT VALUES OF ICOUDI/ICOUEX'
C
      IF (ICOTYP.LE.0.OR.ICOTYP.GT.ND_COU)
     *    STOP 'CO2ENE CALLED WITH INCORECT VALUE OF ICOTYP'
C
      IF (ICOUPA.LT.0.OR.ICOUPA.GT.2)
     *    STOP 'CO2ENE CALLED WITH INCORECT VALUE OF ICOUPA'
C
C=======================================================================
C         HERE WE CALCULATE THE EXPANSION INTO GAUSSIANS BASED ON
C         FORMULA (A14) OF PRC 53-2809 AND NOTES 8-71
C=======================================================================
C
      NU_COU=ICOTYP
C
      HOMLEN=MAX(1.0D0/HOMSCA(1,1),
     *           1.0D0/HOMSCA(2,1),
     *           1.0D0/HOMSCA(3,1),
     *           1.0D0/HOMSCA(1,ITWCEN),
     *           1.0D0/HOMSCA(2,ITWCEN),
     *           1.0D0/HOMSCA(3,ITWCEN))
C
      CALL GAULEG(0.0D0,1.0D0,XNODES,WEIGHT,NU_COU)
C
      DO INCOUL=1,NU_COU
C
         COUSTR(INCOUL)=2.0D0/SQRT(PI)*WEIGHT(INCOUL)/HOMLEN
     *                 /(1.0D0-XNODES(INCOUL)**2)**1.5D0
         COULAR(INCOUL)=XNODES(INCOUL)**2/HOMLEN**2
     *                   /(1.0D0-XNODES(INCOUL)**2)
C
      END DO
C
      IF (ICOUDI.EQ.2) EKECOD=C_ZERO
      IF (ICOUEX.EQ.2) EKESCA=C_ZERO
      IF (ICOUEX.EQ.2) EKEVEC=C_ZERO
      IF (ICOUPA.GE.1) EKPSCA=C_ZERO
      IF (ICOUPA.GE.1) EKPVEC=C_ZERO
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
                       COULSV=C_ZERO
      IF (ICOUPA.EQ.2) COUPSV=C_ZERO
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER GAUSSIANS THAT APPROXIMATE THE
C        COULOMB POTENTIAL
C=======================================================================
C
      NXMAXX=MAXVAL(NXMAXV,ITWCEN)
      NYMAXX=MAXVAL(NYMAXV,ITWCEN)
      NZMAXX=MAXVAL(NZMAXV,ITWCEN)
C
      DO INCOUL=1,NU_COU
C
         DO LTWCEN=1,LDTWCE
C
            I  =IND4HI(LTWCEN)
            J  =IND4HK(LTWCEN)
            IP =IND4HL(LTWCEN)
            JP =IND4HJ(LTWCEN)
C
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C        ATTENTION: GENGAU WORKS WITH COEFFICIENTS OF THE GAUSSIAN
C        EXPANSION ASSOCIATED TO THE COULOMB INTERACTION
C
C                    1/R=SUM_K COULSTR_K * EXP(COULAR_K R^2)
C
C        IN THE CASE OF USING ANOTHER INTERACTION, "GOGWID" SHOULD BE
C        OBTAINED AS THE INVERSE OF THE SQUARE ROOT OF THE WIDTH.
C=======================================================================
C
            GOGWID=COULAR(INCOUL)
C
            CALL GENGAU(NXMAXX,NXHERM,1,GOGWID,GAU_X0,LTWCEN)
            CALL GENGAU(NYMAXX,NYHERM,2,GOGWID,GAU_Y0,LTWCEN)
            CALL GENGAU(NZMAXX,NZHERM,3,GOGWID,GAU_Z0,LTWCEN)
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
            IF (ICOUDI.EQ.2) THEN
C
                I_PART=2
C
                IDENSI=0
                CALL GAUENE(ISIMPY,ICOUDI,I_PART,IDENSI,LTWCEN,ITWCEN)
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
                EKECOD=EKECOD+COUSTR(INCOUL)*GAUAVR(0,0,0,1,1)*ECHAR2/2
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
                                        IBLOCK=0
                IF (I.EQ.1.AND.IP.EQ.1) IBLOCK=1 ! C1-C1
                IF (I.EQ.2.AND.IP.EQ.2) IBLOCK=2 ! C2-C2
                IF (I.EQ.2.AND.IP.EQ.1) IBLOCK=3 ! C2-C1
C
                IF (IBLOCK.GT.0) THEN
C
                    DO IKET=1,LDBATW(IND2HR(IBLOCK))
                       DO IBRA=1,LDBATW(IND2HL(IBLOCK))
C
                          COULSV(IBRA,IKET,0,IBLOCK)=
     *                    COULSV(IBRA,IKET,0,IBLOCK)+COUSTR(INCOUL)
     *                             *GAUFIL(0,IBRA,IKET,0,1)*ECHAR2
C
                       END DO
                    END DO
C
                END IF
C
            END IF
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
         IF (ICOUEX.EQ.2) THEN
C
             I_PART=1
C
             CALL EXCGOG(NXMAXX,
     *             GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                         GAUX41,GAUX42,GAUX43)
             CALL EXCGOG(NYMAXX,
     *             GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                         GAUY41,GAUY42,GAUY43)
             CALL EXCGOG(NZMAXX,
     *             GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                         GAUZ41,GAUZ42,GAUZ43)
C
             IDENSI=0
             CALL GAUENE(ISIMPY,ICOUEX,I_PART,IDENSI,LTWCEN,ITWCEN)
C
C=======================================================================
C        ATTENTION: SEE COMMENTS IN COUENE ABOUT ADDITIONAL FACTORS
C=======================================================================
C
             EKESCA=EKESCA-COUSTR(INCOUL)*ECHAR2/2/2
     *                    * GAUAVR(0,0,0,1,1)
C
             EKEVEC=EKEVEC-COUSTR(INCOUL)*ECHAR2/2/2
     *                    *(GAUAVR(0,1,1,1,1)
     *                     +GAUAVR(0,2,2,1,1)
     *                     +GAUAVR(0,3,3,1,1))
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
C
C=======================================================================
C        EXCHANGING CENTER INDEX TO SAVE MATRIX ELEMENTS
C=======================================================================
C
                                     IBLOCK=0
             IF (I.EQ.1.AND.JP.EQ.1) IBLOCK=1
             IF (I.EQ.2.AND.JP.EQ.2) IBLOCK=2
             IF (I.EQ.2.AND.JP.EQ.1) IBLOCK=3
C
             IF (IBLOCK.GT.0) THEN
C
                 DO KARTEZ=0,NDKART
                    DO IKET=1,LDBATW(IND2HR(IBLOCK))
                       DO IBRA=1,LDBATW(IND2HL(IBLOCK))
C
                          COULSV(IBRA,IKET,KARTEZ,IBLOCK)=
     *                    COULSV(IBRA,IKET,KARTEZ,IBLOCK)-COUSTR(INCOUL)
     *                            *GAUFIL(0,IBRA,IKET,KARTEZ,1)*ECHAR2/2
C
                       END DO
                    END DO
                 END DO
C
             END IF
C
         END IF
C
C=======================================================================
C        CALCULATING THE PAIRING TERM
C=======================================================================
C        ATTENTION: TWO-CENTER BASIS IMPLEMENTATION NOT READY
C=======================================================================
C
         IF (ICOUPA.GE.1) THEN
C
             I_PART=2
C
             CALL PAIGOG(NXMAXX,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
             CALL PAIGOG(NYMAXX,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
             CALL PAIGOG(NZMAXX,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
             IDENSI=1
             CALL GAUENE(ISIMPY,ICOUEX,I_PART,IDENSI,LTWCEN,ITWCEN)
C
C=======================================================================
C        CALCULATING THE AVERAGE PAIRING ENERGY
C=======================================================================
C
             EKPSCA=EKPSCA+COUSTR(INCOUL)*GAUAVR(0,0,0,1,1)*ECHAR2/2/2
C
             EKPVEC=EKPVEC+COUSTR(INCOUL)*ECHAR2/2/2
     *                    *(GAUAVR(0,1,1,1,1)
     *                     +GAUAVR(0,2,2,1,1)
     *                     +GAUAVR(0,3,3,1,1))
C
C=======================================================================
C        CALCULATING THE CONTRIBUTION TO THE PAIRING FIELD
C=======================================================================
C
             IF (ICOUPA.EQ.2) THEN
C
                 DO KARTEZ=0,NDKART
C
                    DO IKET=1,LDBATW(IND2HR(IBLOCK))
                       DO IBRA=1,LDBATW(IND2HL(IBLOCK))
C
                          COUPSV(IBRA,IKET,KARTEZ)=
     *                    COUPSV(IBRA,IKET,KARTEZ)+COUSTR(INCOUL)
     *                            *GAUFIL(0,IBRA,IKET,KARTEZ,1)*ECHAR2/2
C
                      END DO
                    END DO
                 END DO
C
             END IF
C
         END IF
C
C=======================================================================
C        END CALCULATING THE PAIRING TERM
C=======================================================================
C
         END DO !LTWCEN
C
      END DO !INCOUL
C
C=======================================================================
C
      CALL CPUTIM('CO2ENE',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE YUKENE(PIMASS,PNMASS,IYUTYP,I_YUKA,YUKAGT,YUKAG0,
     *                                       YUKAG1,YUKAG2,ISIMPY)
C=======================================================================
      USE GAUSTO
      USE YUKSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          EYUK_D,EYUK_E
      COMPLEX
     *          C_ZERO,UNIT_I
C=======================================================================
C
      DIMENSION
     *          YUKSTR(NDYUKA,NDYUTY),YUKWID(NDYUKA,NDYUTY)
      DIMENSION
     *          YUKAAT(0:NDISOS)
      DIMENSION
     *          NUYUKA(NDYUTY)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /EN_YUK/ EYUK_D(0:NDISOS,0:NDISOS),
     *                EYUK_E(0:NDISOS,0:NDISOS)
      COMMON
     *       /EYUKTT/ EYUKDT,EYUKD0,EYUKD1,EYUKD2,
     *                EYUKET,EYUKE0,EYUKE1,EYUKE2
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C           HERE IS THE FIT OF THE SRC FUNCTION TIMES THE GRADIENT
C           OF YUKAWA
C=======================================================================
C
      DATA
     *      (YUKSTR(INYUKA,1),YUKWID(INYUKA,1),INYUKA=1,NDYUKA)
     *
     *    / 1.7500D0, 1.100D0,
     *      0.5300D0, 0.680D0,
     *      0.1100D0, 0.210D0,
     *      0.0040D0, 0.060D0,
     *      0.0000D0, 0.000D0,
     *      0.0000D0, 0.000D0 /
      DATA
     *      NUYUKA(1)/4/
C
C=======================================================================
C           HERE IS THE NEW FIT OF YUKAWA  WITH  THE  NORMALIZATION
C           OF 1.00008. THE LAST LINE CORRECTS THE LAST COEFFICIENT
C           SO AS TO MAKE THE NORMALIZATION EQUAL TO 1.
C=======================================================================
C
      DATA
     *      (YUKSTR(INYUKA,2),YUKWID(INYUKA,2),INYUKA=1,NDYUKA)
     *
     *    / 6.7900D0,34.000D0,
     *      2.4100D0, 6.600D0,
     *      0.7860D0, 1.440D0,
     *      0.2410D0, 0.380D0,
     *     -0.0620D0, 0.150D0,
     *      0.77991050814653D-01, 0.130D0 /
      DATA
     *      NUYUKA(2)/6/
C
C           HERE IS THE OLD FIT OF YUKAWA WITH THE
C           NORMALIZATION OF 0.997
C
C    *    / 6.7900D0,34.000D0,
C    *      2.4000D0, 6.600D0,
C    *      0.7920D0, 1.440D0,
C    *      0.0778D0, 0.130D0,
C    *      0.2400D0, 0.380D0,
C    *     -0.0620D0, 0.150D0 /
C
C=======================================================================
C
      CALL CPUTIM('YUKENE',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(YUKASV).AND.I_YUKA.GE.2) THEN
          ALLOCATE (YUKASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('YUKASV','YUKENE')
      END IF
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES:
C        1) THE AVERAGE VALUES OF THE FINITE-RANGE YUKAWA INTERACTION
C                                                         (FOR I_YUKA>0)
C        2) THE CORRESPONDING  DIRECT   MEAN FIELDS
C                                            (FOR I_YUKA=2 OR  I_YUKA=3)
C        3) THE CORRESPONDING EXCHANAGE MEAN FIELDS
C                                            (FOR I_YUKA=2 OR  I_YUKA=4)
C=======================================================================
C
      IF (ISIMPY.EQ.1.AND.I_YUKA.GE.1)
     *    STOP 'THE RESULT IS ZERO - NOT PROGRAMMED YET'
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      PI=4.0D0*ATAN(1.0D0)
C
      I_PART=0
      IDENSI=0
C
C=======================================================================
C        HERE IS JON'S TEST SUGGESTED IN THE E-MAIL OF 2005.02.07 21:04
C=======================================================================
C
C     DO INYUKA=1,NDYUKA
C
C        b'(i) = b(i)*(.7045)^2 and a'(i) = a(i)*b(i)*2*(.7045)^2.
C
C        YUKSTR(INYUKA)=YUKSTR(INYUKA)*YUKWID(INYUKA)*2*PIMASS**2
C        YUKWID(INYUKA)=YUKWID(INYUKA)*PIMASS**2
C
C     END DO
C
C=======================================================================
C        MODIFYING THE STRENGTH OF THE LAST GAUSSIAN SO AS TO  NORMALIZE
C        THE APPROXIMATION OF THE YUKAWA POTENTIAL TO 1
C=======================================================================
C
      IRENOR=0
      IF (IRENOR.EQ.1) THEN
C
          RESULT=0
C
          DO INYUKA=1,NDYUKA
C
             RESULT=RESULT+YUKSTR(INYUKA,IYUTYP)
     *                    /YUKWID(INYUKA,IYUTYP)**1.5D0
C
          END DO
C
          RESULT=1-RESULT*SQRT(PI)/4
C
          YUKSTR(NDYUKA,IYUTYP)=YUKSTR(NDYUKA,IYUTYP)
     *                  +RESULT*YUKWID(NDYUKA,IYUTYP)**1.5D0*4/SQRT(PI)
C
          PRINT '('' NORM='',D22.14,'' DEVIATION='',D22.14,
     *            '' NEW COEFF='',D22.14)',
     *            1-RESULT,RESULT,YUKSTR(NDYUKA,IYUTYP)
C
C=======================================================================
C        CHECKING THE MODIFIED NORMALIZATION
C=======================================================================
C
          RESULT=0
C
          DO INYUKA=1,NDYUKA
C
             RESULT=RESULT+YUKSTR(INYUKA,IYUTYP)
     *                    /YUKWID(INYUKA,IYUTYP)**1.5D0
C
          END DO
C
          RESULT=1-RESULT*SQRT(PI)/4
C
          YUKSTR(NDYUKA,IYUTYP)=YUKSTR(NDYUKA,IYUTYP)
     *                  +RESULT*YUKWID(NDYUKA,IYUTYP)**1.5D0*4/SQRT(PI)
C
          PRINT '('' NORM='',D22.14,'' DEVIATION='',D22.14,
     *            '' NEW COEFF='',D22.14)',
     *            1-RESULT,RESULT,YUKSTR(NDYUKA,IYUTYP)
C
      END IF
C
C=======================================================================
C        DEFINING THE OVERALL COUPLING CONSTANT
C=======================================================================
C
      CTILDE=YUKAGT*H_BARC/2/PIMASS**2/PNMASS
C
C=======================================================================
C        ZEROING THE ARRAYS THAT WILL COLLECT THE CONTRIBUTIONS COMING
C        FROM INDIVIDUAL GAUSSIANS
C=======================================================================
C
      EYUK_D(:,:)=C_ZERO
      EYUK_E(:,:)=C_ZERO
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      IF (I_YUKA.GE.2) THEN
          YUKASV(:,:,:,:)=C_ZERO
      END IF
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER GAUSSIANS THAT APPROXIMATE THE YUKAWA
C        POTENTIAL
C=======================================================================
C
      NXMAXX=NXMAXV(1)
      NYMAXX=NYMAXV(1)
      NZMAXX=NZMAXV(1)
C
      DO INYUKA=1,NUYUKA(IYUTYP)
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
         IF (IYUTYP.EQ.1)GOGWID=1.0D0/SQRT(YUKWID(INYUKA,IYUTYP))
         IF (IYUTYP.EQ.2)GOGWID=1.0D0/SQRT(YUKWID(INYUKA,IYUTYP))/PIMASS
C
         CALL DEFGOG(NXMAXX,NXHERM,1,GOGWID,
     *               GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                           GAUX41,GAUX42,GAUX43)
         CALL DEFGOG(NYMAXX,NYHERM,2,GOGWID,
     *               GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                           GAUY41,GAUY42,GAUY43)
         CALL DEFGOG(NZMAXX,NZHERM,3,GOGWID,
     *               GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                           GAUZ41,GAUZ42,GAUZ43)
C
         IDENSI=0
         CALL GAUOPT(ISIMPY,I_YUKA,I_PART,IDENSI)
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
         KARTE0=0
C
         DO ICHARG=0,NDISOS
            DO JCHARG=0,NDISOS
C
               DO KARTEZ=1,NDKART
C
C=======================================================================
C              THE FACTORS THAT ARE BELOW ARE AS FOLLOWS:
C
C              FACTOR OF 2 COMES FROM REMOVING THE FACTOR 1/2,  WHICH IS
C                        ABSENT IN THE ZERO-RANGE EXPRESSION IN TERMS OF
C                        RHO*(DIV S) OR J*S
C              FACTOR OF (-2)*PIMASS**5/(4*PI) COMES FROM THE  CONDITION
C                        THAT NORMALIZES THE  GRADIENT  OF  THE  SUM  OF
C                        GAUSSIANS TO THE GRADIENT OF THE DELTA FUNCTION
C              FACTOR OF 1/2 COMES FROM THE EXPRESSION FOR THE  HARTREE-
C                        FOCK ENERGY IN TERMS OF  THE  DENSITY  MATRICES
C
C=======================================================================
C
                  IF (IYUTYP.EQ.1)
     *            EYUK_D(ICHARG,JCHARG)=
     *            EYUK_D(ICHARG,JCHARG)+YUKSTR(INYUKA,IYUTYP)
     *                       *2*(-1)*PIMASS**3/(4*PI)/2
     *                       *GAUAVR(KARTEZ,KARTEZ,KARTE0,ICHARG,JCHARG)
C
                  IF (IYUTYP.EQ.2)
     *            EYUK_D(ICHARG,JCHARG)=
     *            EYUK_D(ICHARG,JCHARG)+YUKWID(INYUKA,IYUTYP)
     *                                 *YUKSTR(INYUKA,IYUTYP)
     *                       *2*(-2)*PIMASS**5/(4*PI)/2
     *                       *GAUAVR(KARTEZ,KARTEZ,KARTE0,ICHARG,JCHARG)
C
               END DO
            END DO
         END DO
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
         FACTOR = (-1)*PIMASS**3/(4*PI)*CTILDE
C
         YUKAAT(0) = FACTOR * (YUKAG0-YUKAG1+2*YUKAG2)
         YUKAAT(1) = FACTOR * (YUKAG0+YUKAG1+2*YUKAG2)
         YUKAAE    = FACTOR * 2.0D0 * (YUKAG0-YUKAG2)
C
         KARTE0=0
C
         IF (I_YUKA.EQ.2.OR.I_YUKA.EQ.3) THEN
C
             DO ICHARG=0,NDISOS
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
                      DO KARTEZ=1,NDKART
C
                         IF (IYUTYP.EQ.1) THEN
C
                                YUKASV(IBRA,IKET,KARTE0,  ICHARG)=
     *                          YUKASV(IBRA,IKET,KARTE0,  ICHARG)+
     *
     *                    YUKSTR(INYUKA,IYUTYP)*(YUKAAT(  ICHARG)*
     *                   GAUFIL(KARTEZ,IBRA,IKET,KARTEZ,1-ICHARG)-
     *                                           YUKAAT(  ICHARG)*
     *                   GAUFIL(KARTEZ,IBRA,IKET,KARTEZ,  ICHARG))
C
                                YUKASV(IBRA,IKET,KARTEZ,  ICHARG)=
     *                          YUKASV(IBRA,IKET,KARTEZ,  ICHARG)+
     *
     *                    YUKSTR(INYUKA,IYUTYP)*(YUKAAT(  ICHARG)*
     *                   GAUFIL(KARTEZ,IBRA,IKET,KARTE0,  ICHARG)-
     *                                           YUKAAT(1-ICHARG)*
     *                   GAUFIL(KARTEZ,IBRA,IKET,KARTE0,1-ICHARG))
C
                         END IF
C
                         IF (IYUTYP.EQ.2) THEN
C
                                YUKASV(IBRA,IKET,KARTE0,  ICHARG)=
     *                          YUKASV(IBRA,IKET,KARTE0,  ICHARG)+
     *
     *                        YUKWID(INYUKA,IYUTYP)*2.0*PIMASS**2*
     *                    YUKSTR(INYUKA,IYUTYP)*(YUKAAT(  ICHARG)*
     *                   GAUFIL(KARTEZ,IBRA,IKET,KARTEZ,1-ICHARG)-
     *                                           YUKAAT(  ICHARG)*
     *                   GAUFIL(KARTEZ,IBRA,IKET,KARTEZ,  ICHARG))
C
                                YUKASV(IBRA,IKET,KARTEZ,  ICHARG)=
     *                          YUKASV(IBRA,IKET,KARTEZ,  ICHARG)+
     *
     *                        YUKWID(INYUKA,IYUTYP)*2.0*PIMASS**2*
     *                    YUKSTR(INYUKA,IYUTYP)*(YUKAAT(  ICHARG)*
     *                   GAUFIL(KARTEZ,IBRA,IKET,KARTE0,  ICHARG)-
     *                                           YUKAAT(1-ICHARG)*
     *                   GAUFIL(KARTEZ,IBRA,IKET,KARTE0,1-ICHARG))
C
                         END IF
C
                      END DO
                   END DO
C
                END DO
             END DO
C
         END IF
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
         CALL EXCGOG(NXMAXX,
     *               GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                           GAUX41,GAUX42,GAUX43)
         CALL EXCGOG(NYMAXX,
     *               GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                           GAUY41,GAUY42,GAUY43)
         CALL EXCGOG(NZMAXX,
     *               GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                           GAUZ41,GAUZ42,GAUZ43)
C
         IDENSI=0
         CALL GAUOPT(ISIMPY,I_YUKA,I_PART,IDENSI)
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE EXCHANGE TERM
C=======================================================================
C
         DO ICHARG=0,NDISOS
            DO JCHARG=0,NDISOS
C
               DO KARTEZ=1,NDKART
C
                  KARTEP=KARTEZ+1
                  IF (KARTEP.GT.NDKART) KARTEP=KARTEP-NDKART
C
                  KARTEM=KARTEZ+2
                  IF (KARTEM.GT.NDKART) KARTEM=KARTEM-NDKART
C
C=======================================================================
C              THE FACTORS THAT ARE BELOW ARE AS FOLLOWS:
C
C              FACTOR OF (-1) COMES FROM CALCULATING THE IMAGINARY PART
C                        OF THE RESULT MULTIPLIED BY THE COMPLEX UNIT
C              FACTOR OF 2 COMES FROM REMOVING THE FACTOR 1/2,  WHICH IS
C                        ABSENT IN THE ZERO-RANGE EXPRESSION IN TERMS OF
C                        RHO*(DIV S) OR J*S
C              FACTOR OF (-2)*PIMASS**5/(4*PI) COMES FROM THE  CONDITION
C                        THAT NORMALIZES THE  GRADIENT  OF  THE  SUM  OF
C                        GAUSSIANS TO THE GRADIENT OF THE DELTA FUNCTION
C              FACTOR OF 1/2 COMES FROM THE EXPRESSION FOR THE  HARTREE-
C                        FOCK ENERGY IN TERMS OF  THE  DENSITY  MATRICES
C
C=======================================================================
C
                  IF (IYUTYP.EQ.1)
     *            EYUK_E(ICHARG,JCHARG)=
     *            EYUK_E(ICHARG,JCHARG)+YUKSTR(INYUKA,IYUTYP)
     *                     *(-1)*2*(-1)*PIMASS**3/(4*PI)/2
     *                     *(GAUAVR(KARTEZ,KARTEP,KARTEM,ICHARG,JCHARG)
     *                      -GAUAVR(KARTEZ,KARTEM,KARTEP,ICHARG,JCHARG))
C
                  IF (IYUTYP.EQ.2)
     *            EYUK_E(ICHARG,JCHARG)=
     *            EYUK_E(ICHARG,JCHARG)+YUKWID(INYUKA,IYUTYP)
     *                                 *YUKSTR(INYUKA,IYUTYP)
     *                     *(-1)*2*(-2)*PIMASS**5/(4*PI)/2
     *                     *(GAUAVR(KARTEZ,KARTEP,KARTEM,ICHARG,JCHARG)
     *                      -GAUAVR(KARTEZ,KARTEM,KARTEP,ICHARG,JCHARG))
C
               END DO
            END DO
         END DO
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
         IF (I_YUKA.EQ.2.OR.I_YUKA.EQ.4) THEN
C
             DO ICHARG=0,NDISOS
                DO KARTEZ=1,NDKART
                   DO IKET=1,LDBASE
                      DO IBRA=1,LDBASE
C
                         KARTEP=KARTEZ+1
                         IF (KARTEP.GT.NDKART) KARTEP=KARTEP-NDKART
C
                         KARTEM=KARTEZ+2
                         IF (KARTEM.GT.NDKART) KARTEM=KARTEM-NDKART
C
                         IF (IYUTYP.EQ.1) THEN
C
                                YUKASV(IBRA,IKET,KARTEZ,  ICHARG)=
     *                          YUKASV(IBRA,IKET,KARTEZ,  ICHARG)+
     *
     *                    YUKSTR(INYUKA,IYUTYP)*(YUKAAT(  ICHARG)*
     *                  (GAUFIL(KARTEM,IBRA,IKET,KARTEP,  ICHARG)
     *                  -GAUFIL(KARTEP,IBRA,IKET,KARTEM,  ICHARG))
     *                                          +YUKAAE          *
     *                  (GAUFIL(KARTEM,IBRA,IKET,KARTEP,1-ICHARG)
     *                  -GAUFIL(KARTEP,IBRA,IKET,KARTEM,1-ICHARG)))
     *                  *UNIT_I
C
                         END IF
C
                         IF (IYUTYP.EQ.2) THEN
C
                                YUKASV(IBRA,IKET,KARTEZ,  ICHARG)=
     *                          YUKASV(IBRA,IKET,KARTEZ,  ICHARG)+
     *
     *                        YUKWID(INYUKA,IYUTYP)*2.0*PIMASS**2*
     *                    YUKSTR(INYUKA,IYUTYP)*(YUKAAT(  ICHARG)*
     *                  (GAUFIL(KARTEM,IBRA,IKET,KARTEP,  ICHARG)
     *                  -GAUFIL(KARTEP,IBRA,IKET,KARTEM,  ICHARG))
     *                                          +YUKAAE          *
     *                  (GAUFIL(KARTEM,IBRA,IKET,KARTEP,1-ICHARG)
     *                  -GAUFIL(KARTEP,IBRA,IKET,KARTEM,1-ICHARG)))
     *                  *UNIT_I
C
                         END IF
C
                      END DO
                   END DO
C
                END DO
             END DO
C
         END IF
C
      END DO
C
C=======================================================================
C        CALCULATING THE TOTAL DIRECT ENERGIES
C=======================================================================
C
      EYUKD0=CTILDE*   REAL(+EYUK_D(1,1)  +EYUK_D(0,0)
     *                      -EYUK_D(1,0)  -EYUK_D(0,1)  )
      EYUKD1=CTILDE*   REAL(+EYUK_D(1,1)  -EYUK_D(0,0)
     *                      +EYUK_D(1,0)  -EYUK_D(0,1)  )
      EYUKD2=CTILDE*2* REAL(+EYUK_D(1,1)  +EYUK_D(0,0)
     *                      -EYUK_D(1,0)  -EYUK_D(0,1)  )
C
      EYUKDT=YUKAG0*EYUKD0+YUKAG1*EYUKD1+YUKAG2*EYUKD2
C
C=======================================================================
C        CALCULATING THE TOTAL EXCHANGE ENERGIES
C=======================================================================
C
      EYUKE0=CTILDE*  AIMAG(+EYUK_E(1,1)  +EYUK_E(0,0)
     *                      +EYUK_E(1,0)*2+EYUK_E(0,1)*2)/2
      EYUKE1=CTILDE*  AIMAG(+EYUK_E(1,1)  -EYUK_E(0,0)
     *                                                  )/2
      EYUKE2=CTILDE*2*AIMAG(+EYUK_E(1,1)  +EYUK_E(0,0)
     *                      -EYUK_E(1,0)  -EYUK_E(0,1)  )/2
C
      EYUKET=YUKAG0*EYUKE0+YUKAG1*EYUKE1+YUKAG2*EYUKE2
C
C=======================================================================
C
      CALL CPUTIM('YUKENE',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PHCHAN(DUMSTR,DUM_SD,DUM_VD,DUM_SE,DUM_VE,
     *                                       NDDUMA,NUDUMA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          DUM_SD(NDDUMA,0:NDISOS,0:NDISOS),
     *          DUM_VD(NDDUMA,0:NDISOS,0:NDISOS),
     *          DUM_SE(NDDUMA,0:NDISOS,0:NDISOS),
     *          DUM_VE(NDDUMA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          DUMSTR(NDDUMA,NDFORC)
C
C=======================================================================
C           THIS SUBROUTINE CALCULATES THE NN, NP, PP, AND PN STRENGTHS
C           DERIVED IN THE NOTES 77-B
C=======================================================================
C
      DUM_SD=0.0D0
      DUM_VD=0.0D0
      DUM_SE=0.0D0
      DUM_VE=0.0D0
C
      DO INDUMA=1,NUDUMA
C
         DUM_SD(INDUMA,0,0)=DUMSTR(INDUMA,1)
     *                     +DUMSTR(INDUMA,2)/2
     *                     -DUMSTR(INDUMA,3)
     *                     -DUMSTR(INDUMA,4)/2
         DUM_SD(INDUMA,0,1)=DUMSTR(INDUMA,1)
     *                     +DUMSTR(INDUMA,2)/2
C
         DUM_SD(INDUMA,1,1)=DUM_SD(INDUMA,0,0)
         DUM_SD(INDUMA,1,0)=DUM_SD(INDUMA,0,1)
C
         DUM_VD(INDUMA,0,0)=DUMSTR(INDUMA,2)/2
     *                     -DUMSTR(INDUMA,4)/2
         DUM_VD(INDUMA,0,1)=DUMSTR(INDUMA,2)/2
C
         DUM_VD(INDUMA,1,1)=DUM_VD(INDUMA,0,0)
         DUM_VD(INDUMA,1,0)=DUM_VD(INDUMA,0,1)
C
         DUM_SE(INDUMA,0,0)=DUMSTR(INDUMA,4)
     *                     +DUMSTR(INDUMA,3)/2
     *                     -DUMSTR(INDUMA,2)
     *                     -DUMSTR(INDUMA,1)/2
         DUM_SE(INDUMA,0,1)=DUMSTR(INDUMA,4)
     *                     +DUMSTR(INDUMA,3)/2
C
         DUM_SE(INDUMA,1,1)=DUM_SE(INDUMA,0,0)
         DUM_SE(INDUMA,1,0)=DUM_SE(INDUMA,0,1)
C
         DUM_VE(INDUMA,0,0)=DUMSTR(INDUMA,3)/2
     *                     -DUMSTR(INDUMA,1)/2
         DUM_VE(INDUMA,0,1)=DUMSTR(INDUMA,3)/2
C
         DUM_VE(INDUMA,1,1)=DUM_VE(INDUMA,0,0)
         DUM_VE(INDUMA,1,0)=DUM_VE(INDUMA,0,1)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PH_FST(DUMSTR,DUM_SD,DUM_SE,NDDUMA,NUDUMA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          DUM_SD(NDDUMA,0:NDISOS,0:NDISOS),
     *          DUM_SE(NDDUMA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          DUMSTR(NDDUMA,NDFORC)
C
C=======================================================================
C           THIS SUBROUTINE CALCULATES THE NN, NP, PP, AND PN STRENGTHS
C           FOR THE FINITE-RANGE SPIN-ORBIT AND TENSOR INTERACTIONS
C=======================================================================
C
      DUM_SD=0.0D0
      DUM_SE=0.0D0
C
      DO INDUMA=1,NUDUMA
C
         DUM_SD(INDUMA,0,0)=DUMSTR(INDUMA,1)
     *                     -DUMSTR(INDUMA,3)
         DUM_SD(INDUMA,0,1)=DUMSTR(INDUMA,1)
C
         DUM_SD(INDUMA,1,1)=DUM_SD(INDUMA,0,0)
         DUM_SD(INDUMA,1,0)=DUM_SD(INDUMA,0,1)
C
         DUM_SE(INDUMA,0,0)=DUMSTR(INDUMA,3)
     *                     -DUMSTR(INDUMA,1)
         DUM_SE(INDUMA,0,1)=DUMSTR(INDUMA,3)
C
         DUM_SE(INDUMA,1,1)=DUM_SE(INDUMA,0,0)
         DUM_SE(INDUMA,1,0)=DUM_SE(INDUMA,0,1)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PHISOC(DUMSTR,DUM00D,DUM01D,DUM10D,DUM11D,
     *                         DUM00E,DUM01E,DUM10E,DUM11E,
     *                                       NDDUMA,NUDUMA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          DUM00D(NDDUMA),DUM01D(NDDUMA),
     *          DUM10D(NDDUMA),DUM11D(NDDUMA),
     *          DUM00E(NDDUMA),DUM01E(NDDUMA),
     *          DUM10E(NDDUMA),DUM11E(NDDUMA)
      DIMENSION
     *          DUMSTR(NDDUMA,NDFORC)
C
C=======================================================================
C           THIS SUBROUTINE CALCULATES THE SCALAR-VECTOR AND
C           ISOSCALAR-ISOVECTOR STRENGTHS IN THE DIRECT AND EXCHANGE
C           CHANNELS DERIVED IN CPC 216
C=======================================================================
C
      DUM00D=0.0D0
      DUM01D=0.0D0
      DUM10D=0.0D0
      DUM11D=0.0D0
C
      DUM00E=0.0D0
      DUM01E=0.0D0
      DUM10E=0.0D0
      DUM11E=0.0D0
C
      DO INDUMA=1,NUDUMA
C
         DUM00D(INDUMA)= DUMSTR(INDUMA,1)
     *                  +DUMSTR(INDUMA,2)/2
     *                  -DUMSTR(INDUMA,3)/2
     *                  -DUMSTR(INDUMA,4)/4
         DUM01D(INDUMA)=-DUMSTR(INDUMA,3)/2
     *                  -DUMSTR(INDUMA,4)/4
         DUM10D(INDUMA)= DUMSTR(INDUMA,2)/2
     *                  -DUMSTR(INDUMA,4)/4
         DUM11D(INDUMA)=-DUMSTR(INDUMA,4)/4
C
         DUM00E(INDUMA)= DUMSTR(INDUMA,4)
     *                  +DUMSTR(INDUMA,3)/2
     *                  -DUMSTR(INDUMA,2)/2
     *                  -DUMSTR(INDUMA,1)/4
         DUM01E(INDUMA)=-DUMSTR(INDUMA,2)/2
     *                  -DUMSTR(INDUMA,1)/4
         DUM10E(INDUMA)= DUMSTR(INDUMA,3)/2
     *                  -DUMSTR(INDUMA,1)/4
         DUM11E(INDUMA)=-DUMSTR(INDUMA,1)/4
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PACHAN(DUMSTR,DUM_SP,DUM_VP,NDDUMA,NUDUMA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          DUM_SP(NDDUMA,0:NDISOS,0:NDISOS),
     *          DUM_VP(NDDUMA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          DUMSTR(NDDUMA,NDFORC)
C
C=======================================================================
C           THIS SUBROUTINE CALCULATES THE NN, NP, PP, AND PN STRENGTHS
C           DERIVED BY NICOLAS SCHUNCK
C=======================================================================
C
      DUM_SP=0.0D0
      DUM_VP=0.0D0
C
      DO INDUMA=1,NUDUMA
C
         DUM_SP(INDUMA,0,0)=DUMSTR(INDUMA,1)
     *                     +DUMSTR(INDUMA,2)/2
     *                     -DUMSTR(INDUMA,3)
     *                     -DUMSTR(INDUMA,4)/2
         DUM_SP(INDUMA,0,1)=0.0D0
C
         DUM_SP(INDUMA,1,1)=DUM_SP(INDUMA,0,0)
         DUM_SP(INDUMA,1,0)=DUM_SP(INDUMA,0,1)
C
         DUM_VP(INDUMA,0,0)=DUMSTR(INDUMA,2)/2
     *                     -DUMSTR(INDUMA,4)/2
         DUM_VP(INDUMA,0,1)=0.0D0
C
         DUM_VP(INDUMA,1,1)=DUM_VP(INDUMA,0,0)
         DUM_VP(INDUMA,1,0)=DUM_VP(INDUMA,0,1)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PPCHAN(DUMSTR,DUM_SP,DUM_VP,NDDUMA,NUDUMA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          DUM_SP(NDDUMA,0:NDISOS,0:NDISOS),
     *          DUM_VP(NDDUMA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          DUMSTR(NDDUMA,NDFORC)
C
C=======================================================================
C           THIS SUBROUTINE CALCULATES THE NN, NP, PP, AND PN STRENGTHS
C           IN THE PAIRING CHANNEL, SEE NOTES 9-90
C=======================================================================
C
      DUM_SP=0.0D0
      DUM_VP=0.0D0
C
      DO INDUMA=1,NUDUMA
C
         DUM_SP(INDUMA,0,0)=(DUMSTR(INDUMA,1)
     *                      -DUMSTR(INDUMA,2)
     *                      -DUMSTR(INDUMA,3)
     *                      +DUMSTR(INDUMA,4))/4
         DUM_SP(INDUMA,0,1)=0.0D0
C
         DUM_SP(INDUMA,1,1)=DUM_SP(INDUMA,0,0)
         DUM_SP(INDUMA,1,0)=DUM_SP(INDUMA,0,1)
C
         DUM_VP(INDUMA,0,0)=(DUMSTR(INDUMA,1)
     *                      +DUMSTR(INDUMA,2)
     *                      -DUMSTR(INDUMA,3)
     *                      -DUMSTR(INDUMA,4))/4
         DUM_VP(INDUMA,0,1)=0.0D0
C
         DUM_VP(INDUMA,1,1)=DUM_VP(INDUMA,0,0)
         DUM_VP(INDUMA,1,0)=DUM_VP(INDUMA,0,1)
C
C=======================================================================
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PP_FST(DUMSTR,DUM_SP,NDDUMA,NUDUMA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          DUM_SP(NDDUMA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          DUMSTR(NDDUMA,NDFORC)
C
C=======================================================================
C           THIS SUBROUTINE CALCULATES THE NN, NP, PP, AND PN  STRENGTHS
C           IN THE PAIRING CHANNEL OF THE  FINITE-RANGE  SPIN-ORBIT  AND
C           TENSOR FORCES, SEE NOTES ......
C=======================================================================
C
      DUM_SP=0.0D0
      DUM_VP=0.0D0
C
      DO INDUMA=1,NUDUMA
C
         DUM_SP(INDUMA,0,0)=(DUMSTR(INDUMA,1)
     *                      -DUMSTR(INDUMA,3))/4
         DUM_SP(INDUMA,0,1)=0.0D0
C
         DUM_SP(INDUMA,1,1)=DUM_SP(INDUMA,0,0)
         DUM_SP(INDUMA,1,0)=DUM_SP(INDUMA,0,1)
C
C=======================================================================
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PPISOC(DUMSTR,DUM00P,DUM01P,DUM10P,DUM11P,
     *                                       NDDUMA,NUDUMA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          DUM00P(NDDUMA),DUM01P(NDDUMA),
     *          DUM10P(NDDUMA),DUM11P(NDDUMA)
      DIMENSION
     *          DUMSTR(NDDUMA,NDFORC)
C
C=======================================================================
C           THIS SUBROUTINE CALCULATES THE SCALAR-VECTOR AND
C           ISOSCALAR-ISOVECTOR STRENGTHS IN THE PAIRING
C           CHANNEL DERIVED IN CPC 216
C=======================================================================
C
      DUM00P=0.0D0
      DUM01P=0.0D0
      DUM10P=0.0D0
      DUM11P=0.0D0
C
      DO INDUMA=1,NUDUMA
C
         DUM00P(INDUMA)=(DUMSTR(INDUMA,1)
     *                  -DUMSTR(INDUMA,2)
     *                  +DUMSTR(INDUMA,3)
     *                  -DUMSTR(INDUMA,4))/4
C
         DUM01P(INDUMA)=(DUMSTR(INDUMA,1)
     *                  -DUMSTR(INDUMA,2)
     *                  -DUMSTR(INDUMA,3)
     *                  +DUMSTR(INDUMA,4))/4
C
         DUM10P(INDUMA)=(DUMSTR(INDUMA,1)
     *                  +DUMSTR(INDUMA,2)
     *                  +DUMSTR(INDUMA,3)
     *                  +DUMSTR(INDUMA,4))/4
C
         DUM11P(INDUMA)=(DUMSTR(INDUMA,1)
     *                  +DUMSTR(INDUMA,2)
     *                  -DUMSTR(INDUMA,3)
     *                  -DUMSTR(INDUMA,4))/4
C
C=======================================================================
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GOGENE(I_SLOW,SLOWEV,ISGOGA,I_GOGA,ISIMPY,EKEGOG)
C=======================================================================
      USE GAUSTO
      USE GOGSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          EGOGSD,EGOGSE,EGOGVD,EGOGVE,
     *          EGOTSD,EGOTSE,EGOTVD,EGOTVE,
     *          EGOSSD,EGOSSE,EGOSVD,EGOSVE,
     *          EGOPSD,EGOPSE,EGOPVD,EGOPVE,
     *          EGOMSD,EGOMSE,EGOMVD,EGOMVE
      COMPLEX
     *          EKEGOG
      COMPLEX
     *          C_ZERO
C=======================================================================
      DIMENSION
     *          GOG_SD(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_VD(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_SE(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_VE(NDGOGA,0:NDISOS,0:NDISOS)
C=======================================================================
      COMMON
     *       /GOGFOR/ GOGSTR(NDGOGA,NDFORC),GOGWID(NDGOGA),NUGOGA
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /EN_GOG/ EGOGSD(0:NDISOS,0:NDISOS),
     *                EGOGSE(0:NDISOS,0:NDISOS),
     *                EGOGVD(0:NDISOS,0:NDISOS),
     *                EGOGVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_GTS/ EGOTSD,EGOTSE,EGOTVD,EGOTVE,
     *                EGOSSD,EGOSSE,EGOSVD,EGOSVE
     *
     *       /EN_GPM/ EGOPSD,EGOPSE,EGOPVD,EGOPVE,
     *                EGOMSD,EGOMSE,EGOMVD,EGOMVE
      COMMON
     *       /EGOGTT/ EGOGDT,EGOGET
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('GOGENE',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES:
C        1) THE AVERAGE VALUES OF THE FINITE-RANGE GOGNY INTERACTION
C                                                         (FOR I_GOGA>0)
C        2) THE CORRESPONDING  DIRECT   MEAN FIELDS
C                                            (FOR I_GOGA=2 OR  I_GOGA=3)
C        3) THE CORRESPONDING EXCHANAGE MEAN FIELDS
C                                            (FOR I_GOGA=2 OR  I_GOGA=4)
C=======================================================================
C
C=======================================================================
C           HERE ARE THE NN, NP, PP, AND PN GOGNY STRENGTHS
C           DERIVED IN THE NOTES 77-B
C=======================================================================
C
      CALL PHCHAN(GOGSTR,GOG_SD,GOG_VD,GOG_SE,GOG_VE,NDGOGA,NUGOGA)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(GOGASV).AND.I_GOGA.GE.2) THEN
          ALLOCATE (GOGASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGASV','GOGENE')
      END IF
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      I_PART=3
C
C=======================================================================
C
      IF (ISGOGA.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDEV=0.0
      ELSE
          XOLDEV=SLOWEV
      END IF
C
      XNEWEV=1.0-XOLDEV
C
C=======================================================================
C        ZEROING THE ARRAYS THAT WILL COLLECT THE CONTRIBUTIONS COMING
C        FROM INDIVIDUAL GAUSSIANS
C=======================================================================
C
      EGOGSD(:,:)=C_ZERO
      EGOGSE(:,:)=C_ZERO
      EGOGVD(:,:)=C_ZERO
      EGOGVE(:,:)=C_ZERO
C
      EGOTSD=C_ZERO
      EGOTSE=C_ZERO
      EGOTVD=C_ZERO
      EGOTVE=C_ZERO
C
      EGOSSD=C_ZERO
      EGOSSE=C_ZERO
      EGOSVD=C_ZERO
      EGOSVE=C_ZERO
C
      EGOPSD=C_ZERO
      EGOPSE=C_ZERO
      EGOPVD=C_ZERO
      EGOPVE=C_ZERO
C
      EGOMSD=C_ZERO
      EGOMSE=C_ZERO
      EGOMVD=C_ZERO
      EGOMVE=C_ZERO
C
C=======================================================================
C        INITIALIZING ARRAYS OF MEAN-FIELDS
C=======================================================================
C
      IF (I_GOGA.GE.2) THEN
C
          IF (ISGOGA.NE.1) THEN
              GOGASV(:,:,:,:)=C_ZERO
          ELSE
              GOGASV(:,:,:,:)=GOGASV(:,:,:,:)*XOLDEV
          END IF
C
      END IF
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER GAUSSIANS THAT CONSTITUTE THE GOGNY
C        FORCE
C=======================================================================
C
      IDENSI=0
C
      NXMAXX=NXMAXV(1)
      NYMAXX=NYMAXV(1)
      NZMAXX=NZMAXV(1)
C
      DO INGOGA=1,NUGOGA
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
         GOGWI0=GOGWID(INGOGA)
C
         CALL DEFGOG(NXMAXX,NXHERM,1,GOGWI0,
     *               GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                           GAUX41,GAUX42,GAUX43)
         CALL DEFGOG(NYMAXX,NYHERM,2,GOGWI0,
     *               GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                           GAUY41,GAUY42,GAUY43)
         CALL DEFGOG(NZMAXX,NZHERM,3,GOGWI0,
     *               GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                           GAUZ41,GAUZ42,GAUZ43)
C
         CALL GAUOPT(ISIMPY,I_GOGA,I_PART,IDENSI)
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
         DO ICHARG=0,NDISOS
            DO JCHARG=0,NDISOS
C
               KARTEZ=0
C
               EGOGSD(ICHARG,JCHARG)=EGOGSD(ICHARG,JCHARG)
     *                       +GOG_SD(INGOGA,ICHARG,JCHARG)
     *              *GAUAVR(0,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               DO KARTEZ=1,NDKART
C
                  EGOGVD(ICHARG,JCHARG)=EGOGVD(ICHARG,JCHARG)
     *                          +GOG_VD(INGOGA,ICHARG,JCHARG)
     *                 *GAUAVR(0,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
            END DO
         END DO
C
C=======================================================================
C        CALCULATING THE BREAK-DOWN OF THE DIRECT TERM
C=======================================================================
C
         KARTEZ=0
C
         EGOTSD=EGOTSD+GOG_SD(INGOGA,0,1)
     *                *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         EGOSSD=EGOSSD+(GOG_SD(INGOGA,0,0)-GOG_SD(INGOGA,0,1))
     *                *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         EGOPSD=EGOPSD+(GOG_SD(INGOGA,0,0)+GOG_SD(INGOGA,0,1))/2
     *                *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         EGOMSD=EGOMSD+(GOG_SD(INGOGA,0,0)-GOG_SD(INGOGA,0,1))/2
     *                *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                 -GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                 -GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         DO KARTEZ=1,NDKART
C
            EGOTVD=EGOTVD+GOG_VD(INGOGA,0,1)
     *                   *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
            EGOSVD=EGOSVD+(GOG_VD(INGOGA,0,0)-GOG_VD(INGOGA,0,1))
     *                   *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
            EGOPVD=EGOPVD+(GOG_VD(INGOGA,0,0)+GOG_VD(INGOGA,0,1))/2
     *                   *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
            EGOMVD=EGOMVD+(GOG_VD(INGOGA,0,0)-GOG_VD(INGOGA,0,1))/2
     *                   *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                    -GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                    -GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         END DO
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
         IF (I_GOGA.EQ.2.OR.I_GOGA.EQ.3) THEN
C
             DO ICHARG=0,NDISOS
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *               =GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *               +GOG_SD(INGOGA,ICHARG,  ICHARG)
     *               *GAUFIL(0,IBRA,IKET,KARTEZ,  ICHARG)*XNEWEV
     *               +GOG_SD(INGOGA,ICHARG,1-ICHARG)
     *               *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)*XNEWEV
C
                      DO KARTEZ=1,NDKART
C
                         GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  +GOG_VD(INGOGA,ICHARG,  ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,  ICHARG)*XNEWEV
     *                  +GOG_VD(INGOGA,ICHARG,1-ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)*XNEWEV
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISGOGA=1
C
         END IF
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
         CALL EXCGOG(NXMAXX,
     *               GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                           GAUX41,GAUX42,GAUX43)
         CALL EXCGOG(NYMAXX,
     *               GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                           GAUY41,GAUY42,GAUY43)
         CALL EXCGOG(NZMAXX,
     *               GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                           GAUZ41,GAUZ42,GAUZ43)
C
         CALL GAUOPT(ISIMPY,I_GOGA,I_PART,IDENSI)
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE EXCHANGE TERM
C=======================================================================
C
         DO ICHARG=0,NDISOS
            DO JCHARG=0,NDISOS
C
               KARTEZ=0
C
               EGOGSE(ICHARG,JCHARG)=EGOGSE(ICHARG,JCHARG)
     *                       +GOG_SE(INGOGA,ICHARG,JCHARG)
     *              *GAUAVR(0,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               DO KARTEZ=1,NDKART
C
                  EGOGVE(ICHARG,JCHARG)=EGOGVE(ICHARG,JCHARG)
     *                          +GOG_VE(INGOGA,ICHARG,JCHARG)
     *                 *GAUAVR(0,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
            END DO
         END DO
C
C=======================================================================
C        CALCULATING THE BREAK-DOWN OF THE EXCHANGE TERM
C=======================================================================
C
         KARTEZ=0
C
         EGOTSE=EGOTSE+GOG_SE(INGOGA,0,1)
     *                *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         EGOSSE=EGOSSE+(GOG_SE(INGOGA,0,0)-GOG_SE(INGOGA,0,1))
     *                *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         EGOPSE=EGOPSE+(GOG_SE(INGOGA,0,0)+GOG_SE(INGOGA,0,1))/2
     *                *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         EGOMSE=EGOMSE+(GOG_SE(INGOGA,0,0)-GOG_SE(INGOGA,0,1))/2
     *                *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                 -GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                 -GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         DO KARTEZ=1,NDKART
C
            EGOTVE=EGOTVE+GOG_VE(INGOGA,0,1)
     *                   *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
            EGOSVE=EGOSVE+(GOG_VE(INGOGA,0,0)-GOG_VE(INGOGA,0,1))
     *                   *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
            EGOPVE=EGOPVE+(GOG_VE(INGOGA,0,0)+GOG_VE(INGOGA,0,1))/2
     *                   *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
            EGOMVE=EGOMVE+(GOG_VE(INGOGA,0,0)-GOG_VE(INGOGA,0,1))/2
     *                   *(GAUAVR(0,KARTEZ,KARTEZ,0,0)
     *                    -GAUAVR(0,KARTEZ,KARTEZ,0,1)
     *                    -GAUAVR(0,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(0,KARTEZ,KARTEZ,1,1))/2
C
         END DO
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
         IF (I_GOGA.EQ.2.OR.I_GOGA.EQ.4) THEN
C
             DO ICHARG=0,NDISOS
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *               =GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *               +GOG_SE(INGOGA,ICHARG,  ICHARG)
     *               *GAUFIL(0,IBRA,IKET,KARTEZ,  ICHARG)*XNEWEV
     *               +GOG_SE(INGOGA,ICHARG,1-ICHARG)
     *               *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)*XNEWEV
C
                      DO KARTEZ=1,NDKART
C
                         GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =GOGASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  +GOG_VE(INGOGA,ICHARG,  ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,  ICHARG)*XNEWEV
     *                  +GOG_VE(INGOGA,ICHARG,1-ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)*XNEWEV
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISGOGA=1
C
         END IF
C
      END DO
C
C=======================================================================
C        CALCULATING THE TOTAL DIRECT AND EXCHANGE ENERGIES
C=======================================================================
C
      EGOGDT=0.0D0
      EGOGET=0.0D0
      EKEGOG=C_ZERO
C
      DO ICHARG=0,NDISOS
         DO JCHARG=0,NDISOS
C
            EGOGDT=EGOGDT+REAL(EGOGSD(ICHARG,JCHARG)
     *                        +EGOGVD(ICHARG,JCHARG))
            EGOGET=EGOGET+REAL(EGOGSE(ICHARG,JCHARG)
     *                        +EGOGVE(ICHARG,JCHARG))
C
            EKEGOG=EKEGOG     +EGOGSD(ICHARG,JCHARG)
     *                        +EGOGVD(ICHARG,JCHARG)
     *                        +EGOGSE(ICHARG,JCHARG)
     *                        +EGOGVE(ICHARG,JCHARG)
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('GOGENE',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PARGOG(I_GOGA,IGOGPA,I_REGA,GOGNAM)
C
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          GOGNAM*4
      COMMON
     *       /GOGFOR/ GOGSTR(NDGOGA,NDFORC),GOGWID(NDGOGA),NUGOGA
      COMMON
     *       /REGBIN/ REGBCC(NDREGA,NDFORC),IREREG
      COMMON
     *       /CFIPRI/ NFIPRI
C=======================================================================
C
      IGOGNY=0
C
      NUGOGA=2
C
      IF (NDGOGA.LT.NUGOGA) STOP ' INCREASE NDGOGA IN PARGOG'
C
C=======================================================================
C
      IF (GOGNAM.EQ.'ZERO') THEN
C
          GOGSTR(1,1)=0.0D0
          GOGSTR(1,2)=0.0D0
          GOGSTR(1,3)=0.0D0
          GOGSTR(1,4)=0.0D0
C
          GOGWID(1  )=1.0D0
C
          GOGSTR(2,1)=0.0D0
          GOGSTR(2,2)=0.0D0
          GOGSTR(2,3)=0.0D0
          GOGSTR(2,4)=0.0D0
C
          GOGWID(2  )=1.0D0
C
          IGOGNY=1
C
      END IF
C
C=======================================================================
C           HERE IS THE D1S PARAMETER SET OF UNKNOWN ORIGIN
C=======================================================================
C
      IF (GOGNAM.EQ.'D1SX') THEN
C
          GOGSTR(1,1)=-1720.30D0
          GOGSTR(1,2)= 1300.00D0
          GOGSTR(1,3)=-1813.53D0
          GOGSTR(1,4)= 1397.60D0
C
          GOGWID(1  )=0.7D0
C
          GOGSTR(2,1)= 103.639D0
          GOGSTR(2,2)=-163.483D0
          GOGSTR(2,3)= 162.812D0
          GOGSTR(2,4)=-223.934D0
C
          GOGWID(2  )=1.2D0
C
          IGOGNY=1
C
      END IF
C
C=======================================================================
C           HERE IS THE D1S PARAMETER SET FROM CPC 63-365
C=======================================================================
C
      IF (GOGNAM.EQ.'D1S ') THEN
C
          GOGSTR(1,1)=-1720.30D0
          GOGSTR(1,2)= 1300.00D0
          GOGSTR(1,3)=-1813.53D0
          GOGSTR(1,4)= 1397.60D0
C
          GOGWID(1  )=0.7D0
C
          GOGSTR(2,1)=  103.64D0
          GOGSTR(2,2)= -163.48D0
          GOGSTR(2,3)=  162.81D0
          GOGSTR(2,4)= -223.93D0
C
          GOGWID(2  )=1.2D0
C
          IGOGNY=1
C
      END IF
C
C=======================================================================
C           HERE IS THE D1N PARAMETER SET FROM PLB 668-420
C=======================================================================
C
      IF (GOGNAM.EQ.'D1N ') THEN
C
          GOGSTR(1,1)=-2047.61D0
          GOGSTR(1,2)= 1700.00D0
          GOGSTR(1,3)=-2414.93D0
          GOGSTR(1,4)= 1519.35D0
C
          GOGWID(1  )=0.8D0
C
          GOGSTR(2,1)=  293.02D0
          GOGSTR(2,2)= -300.78D0
          GOGSTR(2,3)=  414.59D0
          GOGSTR(2,4)= -316.84D0
C
          GOGWID(2  )=1.2D0
C
          IGOGNY=1
C
      END IF
C
C=======================================================================
C         THIS IS THE ONE-GAUSSIAN PARAMETER SET AS IN KARIM'S EMAIL OF
C         2015-05-26 09:59
C=======================================================================
C
      IF (GOGNAM.EQ.'ONEG') THEN
C
          GOGSTR(1,1)=-1948.489000D0
          GOGSTR(1,2)=  274.612246D0
          GOGSTR(1,3)=-1776.546537D0
          GOGSTR(1,4)=  146.013920D0
C
          GOGWID(1  )=0.8D0
C
          FACTOR=(GOGWID(1)*SQRT(4.0D0*ATAN(1.0D0)))**3
C
          GOGSTR(1,1)=GOGSTR(1,1)/FACTOR
          GOGSTR(1,2)=GOGSTR(1,2)/FACTOR
          GOGSTR(1,3)=GOGSTR(1,3)/FACTOR
          GOGSTR(1,4)=GOGSTR(1,4)/FACTOR
C
          GOGSTR(2,1)=0.0D0
          GOGSTR(2,2)=0.0D0
          GOGSTR(2,3)=0.0D0
          GOGSTR(2,4)=0.0D0
C
          GOGWID(2  )=1.0D0
C
          IGOGNY=1
C
      END IF
C
C=======================================================================
C         CHECKING IF THE FORCE PARAMETERS HAVE BEN SET
C=======================================================================
C
      IF (IGOGNY.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' UNDEFINED GOGNY FORCE PARAMETERS'',
     *                                                 4X,20(1H/),/,
     *                 1X,20(1H/),'' FORCE ACRONYM '',A4,'' IS NOT'',
     *                            '' SUPPORTED'',
     *                                                 1X,20(1H/),/)')
     *    GOGNAM
C
          STOP 'UNDEFINED GOGNY FORCE PARAMETERS'
C
      END IF
C
C=======================================================================
C         PRINTING THE GOGNY FORCE PARAMETERS
C=======================================================================
C
      IF (I_GOGA.GT.0.OR.IGOGPA.GT.0.OR.
     *   (I_REGA.GT.0.AND.IREREG.EQ.0))
     *
     *    WRITE(NFIPRI,'(79(1H*),/,      1H*,77X,1H*,/,
     *          1H*,14X,''GOGNY FORCE DEFINITION '',
     *                 ''FOR THE PARAMETER SET '',A4  ,14X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *              79(1H*),/,                     1H*,77X,1H*,/,
     *          1H*,  '' G11 ='',F8.2,''   G12 ='',F8.2,
     *              ''   G13 ='',F8.2,''   G14 ='',F8.2,
     *             ''   WID1 ='',F5.2,                  1X,1H*,/,
     *          1H*,  '' G21 ='',F8.2,''   G22 ='',F8.2,
     *              ''   G23 ='',F8.2,''   G24 ='',F8.2,
     *             ''   WID2 ='',F5.2,                  1X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/)')
     *
     *          GOGNAM,((GOGSTR(INGOGA,INFORC),INFORC=1,NDFORC),
     *                   GOGWID(INGOGA       ),INGOGA=1,NUGOGA)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE REGENE(I_SLOW,SLOWEV,SLOWPA,
     *                  I_REGA,IREGPA,ISREGA,ISREGP,
     *                  I_GOGA,IGOGPA,ISGOGA,ISGOGP,
     *                  N3LORD,ISIMPY,IN_FIX,IZ_FIX,EKEREG,NEWGOG)
C=======================================================================
      USE GAUSTO
      USE REGSTO
      USE RPASTO
      USE MAD_PP
      USE MAD_PM
      USE MAP_PP
      USE MAP_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDOSC2=(NDOSCI+1)*(NDOSCI+1))
C=======================================================================
      COMPLEX
     *          EREGSD,EREGVD,EREGSE,EREGVE,EREGSP,EREGVP,
     *          ERETSD,ERETVD,ERETSE,ERETVE,
     *          ERESSD,ERESVD,ERESSE,ERESVE,
     *          EREPSD,EREPVD,EREPSE,EREPVE,
     *          EREMSD,EREMVD,EREMSE,EREMVE
      COMPLEX
     *          HREGSD,HREGVD,HREGSE,HREGVE
      COMPLEX
     *          HCEGSD,HCEGVD,HCEGSE,HCEGVE
      COMPLEX
     *          ECEGSD,ECEGVD,ECEGSE,ECEGVE
      COMPLEX
     *          EKEREG
      COMPLEX
     *          C_ZERO
      COMPLEX
     *          DELTAY,DELTAX(0:NDKART),EPAIRX(0:NDKART)
      COMPLEX
     *          HPAIMP,HPAIPM,HPAIPP,HPAIMM
      COMPLEX
     *          PHACOM
      COMPLEX
     *          GAXVEC,GAYVEC,GAZVEC,
     *          GAXVEI,GAYVEI,GAZVEI
C=======================================================================
      ALLOCATABLE :: HPAIMP(:,:),HPAIPM(:,:),HPAIPP(:,:),HPAIMM(:,:)
C=======================================================================
C
      DIMENSION
     *          CEG_SD(NDREGA,0:NDISOS,0:NDISOS),
     *          CEG_VD(NDREGA,0:NDISOS,0:NDISOS),
     *          CEG_SE(NDREGA,0:NDISOS,0:NDISOS),
     *          CEG_VE(NDREGA,0:NDISOS,0:NDISOS),
     *          CEG_SP(NDREGA,0:NDISOS,0:NDISOS),
     *          CEG_VP(NDREGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          REG_SD(NDREGA,0:NDISOS,0:NDISOS),
     *          REG_VD(NDREGA,0:NDISOS,0:NDISOS),
     *          REG_SE(NDREGA,0:NDISOS,0:NDISOS),
     *          REG_VE(NDREGA,0:NDISOS,0:NDISOS),
     *          REG_SP(NDREGA,0:NDISOS,0:NDISOS),
     *          REG_VP(NDREGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          GOG_SD(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_VD(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_SE(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_VE(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_SP(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_VP(NDGOGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *        GOR_SD(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        GOR_VD(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        GOR_SE(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        GOR_VE(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        GOR_SP(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        GOR_VP(NDREGA,NDGOGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *        COR_SD(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        COR_VD(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        COR_SE(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        COR_VE(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        COR_SP(NDREGA,NDGOGA,0:NDISOS,0:NDISOS),
     *        COR_VP(NDREGA,NDGOGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          HCEGSD(NDREGA,0:NDISOS,0:NDISOS),
     *          HCEGVD(NDREGA,0:NDISOS,0:NDISOS),
     *          HCEGSE(NDREGA,0:NDISOS,0:NDISOS),
     *          HCEGVE(NDREGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          HREGSD(NDREGA,0:NDISOS,0:NDISOS),
     *          HREGVD(NDREGA,0:NDISOS,0:NDISOS),
     *          HREGSE(NDREGA,0:NDISOS,0:NDISOS),
     *          HREGVE(NDREGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          ECEGSD(0:NDISOS,0:NDISOS),
     *          ECEGVD(0:NDISOS,0:NDISOS),
     *          ECEGSE(0:NDISOS,0:NDISOS),
     *          ECEGVE(0:NDISOS,0:NDISOS)
     *
      DIMENSION
     *          FACTOR(NDREGA)
C=======================================================================
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /GA_DIQ/ GAXEIG(NDOSC2),GAYEIG(NDOSC2),GAZEIG(NDOSC2),
     *
     *                GAXVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAYVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAZVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *
     *                GAXVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAYVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAZVEI(NDOSC2,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /EN_REG/ EREGSD(0:NDISOS,0:NDISOS),
     *                EREGSE(0:NDISOS,0:NDISOS),
     *                EREGVD(0:NDISOS,0:NDISOS),
     *                EREGVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_ROR/ ECEGOR(NDREGA),EREGOR(NDREGA)
     *
     *       /EN_RTS/ ERETSD,ERETSE,ERETVD,ERETVE,
     *                ERESSD,ERESSE,ERESVD,ERESVE
     *
     *       /EN_RPM/ EREPSD,EREPSE,EREPVD,EREPVE,
     *                EREMSD,EREMSE,EREMVD,EREMVE
      COMMON
     *       /PN_REG/ EREGSP(0:NDISOS),EREGVP(0:NDISOS)
     *
     *       /PV_REG/ PREGVP(0:NDKART,0:NDISOS)
      COMMON
     *       /PREGTT/ EREGPT
      COMMON
     *       /EREGTT/ EREGDT,EREGET
      COMMON
     *       /REGPAR/ REGWID
      COMMON
     *       /REGINT/ CEGSTR(NDREGA,NDFORC)
      COMMON
     *       /REGFOR/ REGSTR(NDREGA,NDFORC)
      COMMON
     *       /GOGFOR/ GOGSTR(NDGOGA,NDFORC),GOGWID(NDGOGA),NUGOGA
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /B_PHAS/ JPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIQ_GA/ DIQCOD,DIQCOE,DIQCOP,IDIQGA
      COMMON
     *       /MNDDIQ/ KXDDIQ(0:NDOSCI,0:NDOSCI),LXDDIQ(NDOSC2,2),NXDDIQ,
     *                KYDDIQ(0:NDOSCI,0:NDOSCI),LYDDIQ(NDOSC2,2),NYDDIQ,
     *                KZDDIQ(0:NDOSCI,0:NDOSCI),LZDDIQ(NDOSC2,2),NZDDIQ
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('REGENE',1)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      SQRTPI=SQRT(4.0D0*ATAN(1.0D0))
C
C=======================================================================
C        FOR NEWGOG=0, THIS SUBROUTINE:
C
C        1) FOR I_REGA>0 CALCULATES THE AVERAGE VALUES OF THE
C           FINITE-RANGE REGULARIZED FORCE
C           GIVEN BY LOCAL SKYRME PSEUDOPOTENTIAL T2=-T1 (FOR N3LORD>=0)
C        OR GIVEN BY FULL  SKYRME PSEUDOPOTENTIAL        (FOR N3LORD< 0)
C        2) FOR I_REGA=2 OR I_REGA=3 IT CALCULATES IN ADDITION
C           THE CORRESPONDING  DIRECT  MEAN FIELDS
C        3) FOR I_REGA=2 OR I_REGA=4 IT CALCULATES IN ADDITION
C           THE CORRESPONDING EXCHANAGE MEAN FIELDS
C        4) FOR IREGPA>0 CALCULATES THE AVERAGE VALUES OF THE PAIRING
C           FINITE-RANGE REGULARIZED FORCE
C           GIVEN BY LOCAL SKYRME PSEUDOPOTENTIAL T2=-T1 (FOR N3LORD>=0)
C        OR GIVEN BY FULL  SKYRME PSEUDOPOTENTIAL        (FOR N3LORD< 0)
C        5) FOR IREGPA=2 IT CALCULATES IN ADDITION
C           THE CORRESPONDING PAIRING MEAN FIELDS
C
C        NOTE THAT THE NUMBER OF TERMS IS THEN EQUAL TO MUREGA=NUREGA
C              AND THE NUMBER OF GAUSSIANS IS  EQUAL TO MUGOGA=1
C
C=======================================================================
C
C        FOR NEWGOG=1, THIS SUBROUTINE:
C        1) FOR I_GOGA>0 CALCULATES THE AVERAGE VALUES OF THE
C           FINITE-RANGE GOGNY FORCE
C        2) FOR I_GOGA=2 OR I_GOGA=3 IT CALCULATES IN ADDITION
C           THE CORRESPONDING  DIRECT  MEAN FIELDS
C        3) FOR I_GOGA=2 OR I_GOGA=4 IT CALCULATES IN ADDITION
C           THE CORRESPONDING EXCHANAGE MEAN FIELDS
C        4) FOR IGOGPA>0 CALCULATES THE AVERAGE VALUES OF THE PAIRING
C           FINITE-RANGE GOGNY FORCE
C        5) FOR IGOGPA=2 IT CALCULATES IN ADDITION
C           THE CORRESPONDING PAIRING MEAN FIELDS
C
C        NOTE THAT THE NUMBER OF TERMS IS THEN EQUAL TO MUREGA=1
C              AND THE NUMBER OF GAUSSIANS IS  EQUAL TO MUGOGA=NUGOGA
C
C=======================================================================
C
      IF (NEWGOG.EQ.0) THEN
C
          IF (N3LORD.LT.-2) STOP 'N3LORD < -2 NOT READY IN REGENE'
          IF (N3LORD.GT. 3) STOP 'N3LORD > 3 NOT READY IN REGENE'
C
          IF (N3LORD.GE.0) THEN
C
              NUREGA=N3LORD+1
          ELSE
              NUREGA=((IABS(N3LORD)+1)*(IABS(N3LORD)+2))/2
C
          END IF
C
      ELSE
C
          NUREGA=1
C
      END IF
C
C=======================================================================
C           HERE ARE THE NN, NP, PP, AND PN STRENGTHS
C           DERIVED IN THE NOTES 77-B AND BY NICOLAS SCHUNCK
C=======================================================================
C
      IF (NEWGOG.EQ.0) THEN
C
          CALL PHCHAN(REGSTR,REG_SD,REG_VD,REG_SE,REG_VE,NDREGA,NUREGA)
C
          CALL PHCHAN(CEGSTR,CEG_SD,CEG_VD,CEG_SE,CEG_VE,NDREGA,NUREGA)
C
          CALL PPCHAN(REGSTR,REG_SP,REG_VP,NDREGA,NUREGA)
C
          CALL PPCHAN(CEGSTR,CEG_SP,CEG_VP,NDREGA,NUREGA)
C
      ELSE
C
C=======================================================================
C           HERE ARE THE NN, NP, PP, AND PN GOGNY STRENGTHS
C           DERIVED IN THE NOTES 77-B
C=======================================================================
C
          CALL PHCHAN(GOGSTR,GOG_SD,GOG_VD,GOG_SE,GOG_VE,NDGOGA,NUGOGA)
C
          CALL PPCHAN(GOGSTR,GOG_SP,GOG_VP,NDGOGA,NUGOGA)
C
      END IF
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(REGASV).AND.(I_REGA.GE.2.OR.I_GOGA.GE.2)) THEN
          ALLOCATE (REGASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REGASV','REGENE')
      END IF
      IF (.NOT.ALLOCATED(REGPSV).AND.(IREGPA.GE.2.OR.IGOGPA.GE.2)) THEN
          ALLOCATE (REGPSV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('REGPSV','REGENE')
      END IF
C=======================================================================
C
      IF (NEWGOG.EQ.0) THEN
C
          IF (N3LORD.GE.0) THEN
C
              I_PART=4+N3LORD
          ELSE
              I_PART=IABS(N3LORD)+7
C
          END IF
C
      ELSE
C
          I_PART=3
C
      END IF
C
C=======================================================================
C        ZEROING THE ARRAYS THAT WILL COLLECT THE CONTRIBUTIONS COMING
C        FROM INDIVIDUAL TERMS AND INDIVIDUAL GAUSSIANS
C=======================================================================
C
      ERETSD=C_ZERO
      ERETVD=C_ZERO
      ERETSE=C_ZERO
      ERETVE=C_ZERO
C
      ERESSD=C_ZERO
      ERESVD=C_ZERO
      ERESSE=C_ZERO
      ERESVE=C_ZERO
C
      EREPSD=C_ZERO
      EREPVD=C_ZERO
      EREPSE=C_ZERO
      EREPVE=C_ZERO
C
      EREMSD=C_ZERO
      EREMVD=C_ZERO
      EREMSE=C_ZERO
      EREMVE=C_ZERO
C
      ECEGSD=C_ZERO
      ECEGVD=C_ZERO
C
      ECEGSE=C_ZERO
      ECEGVE=C_ZERO
C
      EREGSP=C_ZERO
      EREGVP=C_ZERO
C
C=======================================================================
C        ZEROING THE ARRAYS OF UNIFIED COUPLING CONSTANTS
C=======================================================================
C
      GOR_SD=0.0D0
      GOR_VD=0.0D0
      GOR_SE=0.0D0
      GOR_VE=0.0D0
C
      GOR_SP=0.0D0
      GOR_VP=0.0D0
C
      COR_SD=0.0D0
      COR_VD=0.0D0
      COR_SE=0.0D0
      COR_VE=0.0D0
C
      COR_SP=0.0D0
      COR_VP=0.0D0
C
C=======================================================================
C        UNIFYING THE GOGNY AND REGULARIZED SWITCHES AND LIMITS
C=======================================================================
C
      IF (NEWGOG.EQ.0) THEN
C
          I_GORA=I_REGA
          IGORPA=IREGPA
          ISGORA=ISREGA
          ISGORP=ISREGP
C
          MUREGA=NUREGA
          MUGOGA=1
      ELSE
          I_GORA=I_GOGA
          IGORPA=IGOGPA
          ISGORA=ISGOGA
          ISGORP=ISGOGP
C
          MUREGA=1
          MUGOGA=NUGOGA
C
      END IF
C
C=======================================================================
C        INITIALIZING THE SLOW-DOWN FACTORS
C=======================================================================
C
      IF (ISGORA.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDEV=0.0
      ELSE
          XOLDEV=SLOWEV
      END IF
C
      XNEWEV=1.0-XOLDEV
C
      IF (ISGORP.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDPA=0.0
      ELSE
          XOLDPA=SLOWPA
      END IF
C
      XNEWPA=1.0-XOLDPA
C
C=======================================================================
C        INITIALIZING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      IF (I_GORA.GE.2) THEN
C
          IF (ISGORA.NE.1) THEN
C
              REGASV=C_ZERO
          ELSE
              REGASV=REGASV*XOLDEV
C
          END IF
C
      END IF
C
      IF (IGORPA.GE.2) THEN
C
          IF (ISGORP.NE.1) THEN
C
              REGPSV=C_ZERO
          ELSE
              REGPSV=REGPSV*XOLDPA
C
          END IF
C
      END IF
C
C=======================================================================
C        HERE STARTS THE LOOP OVER DIFFERENT GAUSSIANS
C=======================================================================
C
      DO INGOGA=1,MUGOGA
C
         IF (NEWGOG.EQ.0) THEN
C
             GOGWI0=REGWID
C
             GOR_SD(:,1,:,:)=REG_SD(:,:,:)
             GOR_VD(:,1,:,:)=REG_VD(:,:,:)
             GOR_SE(:,1,:,:)=REG_SE(:,:,:)
             GOR_VE(:,1,:,:)=REG_VE(:,:,:)
C
             GOR_SP(:,1,:,:)=REG_SP(:,:,:)
             GOR_VP(:,1,:,:)=REG_VP(:,:,:)
C
             IF (N3LORD.LT.0) THEN
C
                 COR_SD(:,1,:,:)=REG_SD(:,:,:)
                 COR_VD(:,1,:,:)=REG_VD(:,:,:)
                 COR_SE(:,1,:,:)=REG_SE(:,:,:)
                 COR_VE(:,1,:,:)=REG_VE(:,:,:)
C
                 COR_SP(:,1,:,:)=REG_SP(:,:,:)
                 COR_VP(:,1,:,:)=REG_VP(:,:,:)
C
             ELSE
C
                 COR_SD(:,1,:,:)=CEG_SD(:,:,:)
                 COR_VD(:,1,:,:)=CEG_VD(:,:,:)
                 COR_SE(:,1,:,:)=CEG_SE(:,:,:)
                 COR_VE(:,1,:,:)=CEG_VE(:,:,:)
C
                 COR_SP(:,1,:,:)=CEG_SP(:,:,:)
                 COR_VP(:,1,:,:)=CEG_VP(:,:,:)
C
             END IF
C
         ELSE
C
             GOGWI0=GOGWID(INGOGA)
C
             GOR_SD(1,INGOGA,:,:)=GOG_SD(INGOGA,:,:)
             GOR_VD(1,INGOGA,:,:)=GOG_VD(INGOGA,:,:)
             GOR_SE(1,INGOGA,:,:)=GOG_SE(INGOGA,:,:)
             GOR_VE(1,INGOGA,:,:)=GOG_VE(INGOGA,:,:)
C
             GOR_SP(1,INGOGA,:,:)=GOG_SP(INGOGA,:,:)
             GOR_VP(1,INGOGA,:,:)=GOG_VP(INGOGA,:,:)
C
C            FACGOG=(GOGWID(INGOGA)*SQRTPI)**3
C
             COR_SD(1,INGOGA,:,:)=GOG_SD(INGOGA,:,:)
             COR_VD(1,INGOGA,:,:)=GOG_VD(INGOGA,:,:)
             COR_SE(1,INGOGA,:,:)=GOG_SE(INGOGA,:,:)
             COR_VE(1,INGOGA,:,:)=GOG_VE(INGOGA,:,:)
C
             COR_SP(1,INGOGA,:,:)=GOG_SP(INGOGA,:,:)
             COR_VP(1,INGOGA,:,:)=GOG_VP(INGOGA,:,:)
C
         END IF
C
C=======================================================================
C           FOR N3LORD>=0 (LOCAL  PSEUDOPOTENTIAL),  CALCULATIONS  ARE
C                         FIRST PERFORMED FOR THE GAUSSIAN FORMFACTORS
C                         MULTIPLIED BY POWERS OF X,Y, AND Z POSITIONS
C                         (THE "CE" ARRAYS), AND THEN THE RESULTS  ARE
C                         TRANSFORMED   INTO  THOSE  CORRESPONDING  TO
C                         THE X,Y, AND Z DERIVATIVES OF  THE  GAUSSIAN
C                         FORMFACTORS (THE "RE" ARRAYS)
C           FOR N3LORD< 0 (NONLOCAL PSEUDOPOTENTIAL), CALCULATIONS ARE
C                         FROM THE ONSET PERFORMED FOR THE X,Y, AND  Z
C                         DERIVATIVES  OF  THE  GAUSSIAN  FORMFACTORS,
C                         WHEREUPON THE  "CE"  ARRAYS  ARE  IDENTIFIED
C                         WITH THE "RE" ARRAYS.
C           NOTE THAT THESE DIFFERENCES IN TREATING THE TWO  CASES  OF
C           N3LORD>=0 AND N3LORD<0 MATTER ONLY FOR THE  RESULTS  SPLIT
C           INTO DIFFERENT ORDERS (THE "EREGOR" AND "ECEGOR"  ARRAYS).
C           OTHERWISE, THE SUMMATIONS OF THE FINAL RESULTS OVER ORDERS
C           ARE DONE IN BOTH CASES AUTOMATICALLY.
C=======================================================================
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
         NXMAXX=NXMAXV(1)
         NYMAXX=NYMAXV(1)
         NZMAXX=NZMAXV(1)
C
         CALL DEFGOG(NXMAXX,NXHERM,1,GOGWI0,
     *               GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                           GAUX41,GAUX42,GAUX43)
         CALL DEFGOG(NYMAXX,NYHERM,2,GOGWI0,
     *               GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                           GAUY41,GAUY42,GAUY43)
         CALL DEFGOG(NZMAXX,NZHERM,3,GOGWI0,
     *               GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                           GAUZ41,GAUZ42,GAUZ43)
C
         IDENSI=0
C
         IF (IDIQGA.EQ.1) THEN
C
C=======================================================================
C        DIAGONALIZE THE GAUSSIAN FORMFACTORS AND EVALUATE THE
C        CORRESPONDING ENERGIES AND FIELDS USING THE DIAGONAL
C        APPROXIMATION
C=======================================================================
C
C             PRINT *, 'THIS IS RELATIVE TO THE DIRECT X DIR'
C
             CALL DEFDIQ(NXMAXX,GAU_X0,GAXEIG,GAXVEC,GAXVEI,
     *                                 KXDDIQ,LXDDIQ,NXDDIQ)
C
C             PRINT *, 'THIS IS RELATIVE TO THE DIRECT Y DIR'
C
             CALL DEFDIQ(NYMAXX,GAU_Y0,GAYEIG,GAYVEC,GAYVEI,
     *                                 KYDDIQ,LYDDIQ,NYDDIQ)
C
C             PRINT *, 'THIS IS RELATIVE TO THE DIRECT Z DIR'
C
             CALL DEFDIQ(NZMAXX,GAU_Z0,GAZEIG,GAZVEC,GAZVEI,
     *                                 KZDDIQ,LZDDIQ,NZDDIQ)
C
             CALL GAUDIQ(ISIMPY,I_GORA,I_PART,IDENSI,DIQCOD)
C
         ELSE
C
             CALL GAUENE(ISIMPY,I_GORA,I_PART,IDENSI,1,1)
C
         END IF
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE REGULARIZED
C        SKYRME FORCE
C=======================================================================
C
         DO INREGA=1,MUREGA
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
            DO ICHARG=0,NDISOS
               DO JCHARG=0,NDISOS
C
                  KARTEZ=0
C
                  HCEGSD(INREGA,ICHARG,JCHARG)=
     *            GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
                  HCEGVD(INREGA,ICHARG,JCHARG)=C_ZERO
C
                  DO KARTEZ=1,NDKART
C
                     HCEGVD(INREGA,ICHARG,JCHARG)=
     *               HCEGVD(INREGA,ICHARG,JCHARG)+
     *               GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
                  END DO
C
               END DO
            END DO
C
            DO ICHARG=0,NDISOS
               DO JCHARG=0,NDISOS
C
                  ECEGSD(ICHARG,JCHARG)=ECEGSD(       ICHARG,JCHARG)+
     *                           COR_SD(INREGA,INGOGA,ICHARG,JCHARG)*
     *                           HCEGSD(INREGA,       ICHARG,JCHARG)
C
                  ECEGVD(ICHARG,JCHARG)=ECEGVD(       ICHARG,JCHARG)+
     *                           COR_VD(INREGA,INGOGA,ICHARG,JCHARG)*
     *                           HCEGVD(INREGA,       ICHARG,JCHARG)
C
               END DO
            END DO
C
            KARTEZ=0
C
            ERETSD=ERETSD+COR_SD(INREGA,INGOGA,0,1)
     *                   *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            ERESSD=ERESSD+(COR_SD(INREGA,INGOGA,0,0)
     *                    -COR_SD(INREGA,INGOGA,0,1))
     *                   *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            EREPSD=EREPSD+(COR_SD(INREGA,INGOGA,0,0)
     *                    +COR_SD(INREGA,INGOGA,0,1))/2
     *                   *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            EREMSD=EREMSD+(COR_SD(INREGA,INGOGA,0,0)
     *                    -COR_SD(INREGA,INGOGA,0,1))/2
     *                   *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                    -GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                    -GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            DO KARTEZ=1,NDKART
C
               ERETVD=ERETVD+COR_VD(INREGA,INGOGA,0,1)
     *                      *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
               ERESVD=ERESVD+(COR_VD(INREGA,INGOGA,0,0)
     *                       -COR_VD(INREGA,INGOGA,0,1))
     *                      *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
               EREPVD=EREPVD+(COR_VD(INREGA,INGOGA,0,0)
     *                       +COR_VD(INREGA,INGOGA,0,1))/2
     *                      *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
               EREMVD=EREMVD+(COR_VD(INREGA,INGOGA,0,0)
     *                       -COR_VD(INREGA,INGOGA,0,1))/2
     *                      *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                       -GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                       -GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            END DO
C
C=======================================================================
C           CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
            IF (I_GORA.EQ.2.OR.I_GORA.EQ.3) THEN
C
                DO ICHARG=0,NDISOS
C
                   DO IKET=1,LDBASE
                      DO IBRA=1,LDBASE
C
                         KARTEZ=0
C
                         REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                      +COR_SD(INREGA,INGOGA,ICHARG,ICHARG)
     *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,ICHARG)
     *                                                           *XNEWEV
     *                      +COR_SD(INREGA,INGOGA,ICHARG,1-ICHARG)
     *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                           *XNEWEV
C
                         DO KARTEZ=1,NDKART
C
                            REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                     =REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                         +COR_VD(INREGA,INGOGA,ICHARG,ICHARG)
     *                         *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,ICHARG)
     *                                                           *XNEWEV
     *                         +COR_VD(INREGA,INGOGA,ICHARG,1-ICHARG)
     *                         *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,
     *                                                  1-ICHARG)*XNEWEV
C
                         END DO
C
                      END DO
                   END DO
C
                END DO
C
                IF (NEWGOG.EQ.0) THEN
C
                    ISREGA=1
                ELSE
                    ISGOGA=1
C
                END IF
C
            END IF
C
         END DO
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
         CALL EXCGOG(NXMAXX,
     *               GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                           GAUX41,GAUX42,GAUX43)
         CALL EXCGOG(NYMAXX,
     *               GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                           GAUY41,GAUY42,GAUY43)
         CALL EXCGOG(NZMAXX,
     *               GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                           GAUZ41,GAUZ42,GAUZ43)
C
         IDENSI=0
C
         IF (IDIQGA.EQ.1) THEN
C
C=======================================================================
C            DIAGONALIZE THE GAUSSIAN FORMFACTORS AND EVALUATE THE
C            CORRESPONDING ENERGIES AND FIELDS USING THE DIAGONAL
C            APPROXIMATION
C=======================================================================
C
C             PRINT *, 'THIS IS RELATIVE TO THE EXCHANGE X DIR'
C
             CALL DEFDIQ(NXMAXX,GAU_X0,GAXEIG,GAXVEC,GAXVEI,
     *                                 KXDDIQ,LXDDIQ,NXDDIQ)
C
C             PRINT *, 'THIS IS RELATIVE TO THE EXCHANGE Y DIR'
C
             CALL DEFDIQ(NYMAXX,GAU_Y0,GAYEIG,GAYVEC,GAYVEI,
     *                                 KYDDIQ,LYDDIQ,NYDDIQ)
C
C             PRINT *, 'THIS IS RELATIVE TO THE EXCHANGE Z DIR'
C
             CALL DEFDIQ(NZMAXX,GAU_Z0,GAZEIG,GAZVEC,GAZVEI,
     *                                 KZDDIQ,LZDDIQ,NZDDIQ)
C
             CALL GAUDIQ(ISIMPY,I_GORA,I_PART,IDENSI,DIQCOE)
C
         ELSE
C
             CALL GAUENE(ISIMPY,I_GORA,I_PART,IDENSI,1,1)
C
         END IF
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE REGULARIZED
C        SKYRME FORCE
C=======================================================================
C
         DO INREGA=1,MUREGA
C
C=======================================================================
C
            DO ICHARG=0,NDISOS
               DO JCHARG=0,NDISOS
C
                  KARTEZ=0
C
                  HCEGSE(INREGA,ICHARG,JCHARG)=
     *            GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
                  HCEGVE(INREGA,ICHARG,JCHARG)=C_ZERO
C
                  DO KARTEZ=1,NDKART
C
                     HCEGVE(INREGA,ICHARG,JCHARG)=
     *               HCEGVE(INREGA,ICHARG,JCHARG)+
     *               GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
                  END DO
C
               END DO
            END DO
C
            DO ICHARG=0,NDISOS
               DO JCHARG=0,NDISOS
C
                  ECEGSE(ICHARG,JCHARG)=ECEGSE(       ICHARG,JCHARG)+
     *                           COR_SE(INREGA,INGOGA,ICHARG,JCHARG)*
     *                           HCEGSE(INREGA,       ICHARG,JCHARG)
C
                  ECEGVE(ICHARG,JCHARG)=ECEGVE(       ICHARG,JCHARG)+
     *                           COR_VE(INREGA,INGOGA,ICHARG,JCHARG)*
     *                           HCEGVE(INREGA,       ICHARG,JCHARG)
C
               END DO
            END DO
C
            KARTEZ=0
C
            ERETSE=ERETSE+COR_SE(INREGA,INGOGA,0,1)
     *                   *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            ERESSE=ERESSE+(COR_SE(INREGA,INGOGA,0,0)
     *                    -COR_SE(INREGA,INGOGA,0,1))
     *                   *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            EREPSE=EREPSE+(COR_SE(INREGA,INGOGA,0,0)
     *                    +COR_SE(INREGA,INGOGA,0,1))/2
     *                   *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            EREMSE=EREMSE+(COR_SE(INREGA,INGOGA,0,0)
     *                    -COR_SE(INREGA,INGOGA,0,1))/2
     *                   *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                    -GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                    -GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            DO KARTEZ=1,NDKART
C
               ERETVE=ERETVE+COR_VE(INREGA,INGOGA,0,1)
     *                      *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
               ERESVE=ERESVE+(COR_VE(INREGA,INGOGA,0,0)
     *                       -COR_VE(INREGA,INGOGA,0,1))
     *                      *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
               EREPVE=EREPVE+(COR_VE(INREGA,INGOGA,0,0)
     *                       +COR_VE(INREGA,INGOGA,0,1))/2
     *                      *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
               EREMVE=EREMVE+(COR_VE(INREGA,INGOGA,0,0)
     *                       -COR_VE(INREGA,INGOGA,0,1))/2
     *                      *(GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,0)
     *                       -GAUAVR(INREGA-1,KARTEZ,KARTEZ,0,1)
     *                       -GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,0)
     *                       +GAUAVR(INREGA-1,KARTEZ,KARTEZ,1,1))/2
C
            END DO
C
C=======================================================================
C           CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
            IF (I_GORA.EQ.2.OR.I_GORA.EQ.4) THEN
C
                DO ICHARG=0,NDISOS
C
                   DO IKET=1,LDBASE
                      DO IBRA=1,LDBASE
C
                         KARTEZ=0
C
                         REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                      +COR_SE(INREGA,INGOGA,ICHARG,ICHARG)
     *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,ICHARG)
     *                                                           *XNEWEV
     *                      +COR_SE(INREGA,INGOGA,ICHARG,1-ICHARG)
     *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                           *XNEWEV
C
                         DO KARTEZ=1,NDKART
C
                            REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *                     =REGASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                         +COR_VE(INREGA,INGOGA,ICHARG,ICHARG)
     *                         *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,ICHARG)
     *                                                           *XNEWEV
     *                         +COR_VE(INREGA,INGOGA,ICHARG,1-ICHARG)
     *                         *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,
     *                                                  1-ICHARG)*XNEWEV
C
                         END DO
C
                      END DO
                   END DO
C
                END DO
C
                IF (NEWGOG.EQ.0) THEN
C
                    ISREGA=1
                ELSE
                    ISGOGA=1
C
                END IF
C
            END IF
C
         END DO
C
C=======================================================================
C        CALCULATING THE PAIRING TERM
C=======================================================================
C
         IF (IGORPA.GE.1) THEN
C
C=======================================================================
C        HERE WE PUT THE  PARTICLE-PARTICLE  MATRIX  ELEMENTS  INTO  THE
C        PARTICLE-HOLE LOCATIONS, SO AS  THE  SAME  SUBROUTINE  "GAUENE"
C        CAN BE USED TO EVALUATE THE PAIRING TERM. NOTE THAT  THIS  MUST
C        BE DONE  A_F_T_E_R  CALCULATING THE EXCHANGE MATRIX ELEMENTS BY
C        CALLING "EXCGOG" ABOVE
C=======================================================================
C
             CALL PAIGOG(NXMAXX,
     *                 GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                             GAUX41,GAUX42,GAUX43)
             CALL PAIGOG(NYMAXX,
     *                 GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                             GAUY41,GAUY42,GAUY43)
             CALL PAIGOG(NZMAXX,
     *                 GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                             GAUZ41,GAUZ42,GAUZ43)
C
             IDENSI=1
C
             IF (IDIQGA.EQ.1) THEN
C
C=======================================================================
C            DIAGONALIZE THE GAUSSIAN FORMFACTORS AND EVALUATE THE
C            CORRESPONDING ENERGIES AND FIELDS USING THE DIAGONAL
C            APPROXIMATION
C=======================================================================
C
C                 PRINT *, 'THIS IS RELATIVE TO THE PAIRING X DIR'
C
                 CALL DEFDIQ(NXMAXX,GAU_X0,GAXEIG,GAXVEC,GAXVEI,
     *                                     KXDDIQ,LXDDIQ,NXDDIQ)
C
C                 PRINT *, 'THIS IS RELATIVE TO THE PAIRING Y DIR'
C
                 CALL DEFDIQ(NYMAXX,GAU_Y0,GAYEIG,GAYVEC,GAYVEI,
     *                                     KYDDIQ,LYDDIQ,NYDDIQ)
C
C                 PRINT *, 'THIS IS RELATIVE TO THE PAIRING Z DIR'
C
                 CALL DEFDIQ(NZMAXX,GAU_Z0,GAZEIG,GAZVEC,GAZVEI,
     *                                     KZDDIQ,LZDDIQ,NZDDIQ)
C
                 CALL GAUDIQ(ISIMPY,IGORPA,I_PART,IDENSI,DIQCOP)
C
             ELSE
C
                 CALL GAUENE(ISIMPY,IGORPA,I_PART,IDENSI,1,1)
C
             END IF
C
C=======================================================================
C            HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE
C            REGULARIZED SKYRME FORCE
C=======================================================================
C
             DO INREGA=1,MUREGA
C
C=======================================================================
C            CALCULATING THE AVERAGE PAIRING ENERGY
C=======================================================================
C
                DO ICHARG=0,NDISOS
C
                   KARTEZ=0
C
                   EREGSP(ICHARG)=EREGSP(ICHARG)
     *                           +COR_SP(INREGA,INGOGA,ICHARG,ICHARG)
     *                  *GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,ICHARG)
C
                   DO KARTEZ=1,NDKART
C
                      EREGVP(ICHARG)=EREGVP(ICHARG)
     *                              +COR_VP(INREGA,INGOGA,ICHARG,ICHARG)
     *                     *GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,ICHARG)
C
                   END DO
C
                END DO
C
C=======================================================================
C               CALCULATING THE CONTRIBUTION TO THE PAIRING FIELD
C=======================================================================
C
                IF (IGORPA.EQ.2) THEN
C
C=======================================================================
C           FACTORS OF 2 BELOW STEM FROM THE DIFFERENT  FACTORS  IN  THE
C           ENERGIES IN THE DIRECT OR EXCHANGE PH CHANNELS AND  THAT  IN
C           THE PP CHANNEL, SEE EQS. (61)-(63) IN THE DRAFT OF THE HFODD
C           PAPER (hfodd2013-20.lat) OF 31.08.2015. BY THE  SAME  TOKEN,
C           IN THE PAIRING ENERGIES ABOVE THERE IS NO FACTOR 1/2.
C=======================================================================
C
                    DO ICHARG=0,NDISOS
C
                       DO IKET=1,LDBASE
                          DO IBRA=1,LDBASE
C
                             KARTEZ=0
C
                             REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                      =REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                      +COR_SP(INREGA,INGOGA,ICHARG,ICHARG)*2
     *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,ICHARG)
     *                                                           *XNEWPA
C
                             DO KARTEZ=1,NDKART
C
C=======================================================================
C             ATTENTION! THE CHANGE OF SIGN BELOW IS NOT  BASED  ON  ANY
C                        DERIVATION, BUT IT RESULTS FROM THE  COMPARISON
C                        WITH  THE  HFODD  IMPLEMENTATIONS  BY   NICOLAS
C                        SCHUNCK AND FINRES4 TESTS BY  KARIM  BENNACEUR.
C                        IT HAS BEEN INTRODUCED ON 14.03.2016.
C                        MOREOVER, FROM VERSION  (277D) TO (277O),  THIS
C                        CHANGE OF SIGN WAS INADVERTENTLY REMOVED.
C=======================================================================
C
                                REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                         =REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                         -COR_VP(INREGA,INGOGA,ICHARG,ICHARG)*2
     *                         *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,ICHARG)
     *                                                           *XNEWPA
C
                             END DO
C
                          END DO
                       END DO
C
                    END DO
C
                    IF (NEWGOG.EQ.0) THEN
C
                        ISREGP=1
                    ELSE
                        ISGOGP=1
C
                    END IF
C
C
                END IF
C
             END DO
C
C=======================================================================
C           END CALCULATING THE PAIRING TERM
C=======================================================================
C
         END IF
C
C=======================================================================
C        CALCULATING THE TOTAL ENERGIES IN EACH REGULARIZATION ORDER
C=======================================================================
C
         IF (NEWGOG.EQ.0.AND.N3LORD.GE.0) THEN
C
C=======================================================================
C            HERE WE TRANSFORM THE  POSITION  ("CE") REPRESENTATION
C                         INTO THE DERIVATIVE ("RE") REPRESENTATION
C=======================================================================
C
             DO INREGA=1,MUREGA
C
                FACTOR(INREGA)=(GOGWI0*SQRT(4.0D0*ATAN(1.00D0)))**3
     *                         *GOGWI0**(2*(INREGA-1))
C
             END DO
C
             DO ICHARG=0,NDISOS
                DO JCHARG=0,NDISOS
C
         HREGSD(1,ICHARG,JCHARG)=      HCEGSD(1,ICHARG,JCHARG)/FACTOR(1)
         HREGSD(2,ICHARG,JCHARG)=   -6*HCEGSD(1,ICHARG,JCHARG)/FACTOR(1)
     *                              +4*HCEGSD(2,ICHARG,JCHARG)/FACTOR(2)
         HREGSD(3,ICHARG,JCHARG)=   60*HCEGSD(1,ICHARG,JCHARG)/FACTOR(1)
     *                             -80*HCEGSD(2,ICHARG,JCHARG)/FACTOR(2)
     *                             +16*HCEGSD(3,ICHARG,JCHARG)/FACTOR(3)
         HREGSD(4,ICHARG,JCHARG)= -840*HCEGSD(1,ICHARG,JCHARG)/FACTOR(1)
     *                           +1680*HCEGSD(2,ICHARG,JCHARG)/FACTOR(2)
     *                            -672*HCEGSD(3,ICHARG,JCHARG)/FACTOR(3)
     *                             +64*HCEGSD(4,ICHARG,JCHARG)/FACTOR(4)
C
         HREGVD(1,ICHARG,JCHARG)=      HCEGVD(1,ICHARG,JCHARG)/FACTOR(1)
         HREGVD(2,ICHARG,JCHARG)=   -6*HCEGVD(1,ICHARG,JCHARG)/FACTOR(1)
     *                              +4*HCEGVD(2,ICHARG,JCHARG)/FACTOR(2)
         HREGVD(3,ICHARG,JCHARG)=   60*HCEGVD(1,ICHARG,JCHARG)/FACTOR(1)
     *                             -80*HCEGVD(2,ICHARG,JCHARG)/FACTOR(2)
     *                             +16*HCEGVD(3,ICHARG,JCHARG)/FACTOR(3)
         HREGVD(4,ICHARG,JCHARG)= -840*HCEGVD(1,ICHARG,JCHARG)/FACTOR(1)
     *                           +1680*HCEGVD(2,ICHARG,JCHARG)/FACTOR(2)
     *                            -672*HCEGVD(3,ICHARG,JCHARG)/FACTOR(3)
     *                             +64*HCEGVD(4,ICHARG,JCHARG)/FACTOR(4)
C
         HREGSE(1,ICHARG,JCHARG)=      HCEGSE(1,ICHARG,JCHARG)/FACTOR(1)
         HREGSE(2,ICHARG,JCHARG)=   -6*HCEGSE(1,ICHARG,JCHARG)/FACTOR(1)
     *                              +4*HCEGSE(2,ICHARG,JCHARG)/FACTOR(2)
         HREGSE(3,ICHARG,JCHARG)=   60*HCEGSE(1,ICHARG,JCHARG)/FACTOR(1)
     *                             -80*HCEGSE(2,ICHARG,JCHARG)/FACTOR(2)
     *                             +16*HCEGSE(3,ICHARG,JCHARG)/FACTOR(3)
         HREGSE(4,ICHARG,JCHARG)= -840*HCEGSE(1,ICHARG,JCHARG)/FACTOR(1)
     *                           +1680*HCEGSE(2,ICHARG,JCHARG)/FACTOR(2)
     *                            -672*HCEGSE(3,ICHARG,JCHARG)/FACTOR(3)
     *                             +64*HCEGSE(4,ICHARG,JCHARG)/FACTOR(4)
C
         HREGVE(1,ICHARG,JCHARG)=      HCEGVE(1,ICHARG,JCHARG)/FACTOR(1)
         HREGVE(2,ICHARG,JCHARG)=   -6*HCEGVE(1,ICHARG,JCHARG)/FACTOR(1)
     *                              +4*HCEGVE(2,ICHARG,JCHARG)/FACTOR(2)
         HREGVE(3,ICHARG,JCHARG)=   60*HCEGVE(1,ICHARG,JCHARG)/FACTOR(1)
     *                             -80*HCEGVE(2,ICHARG,JCHARG)/FACTOR(2)
     *                             +16*HCEGVE(3,ICHARG,JCHARG)/FACTOR(3)
         HREGVE(4,ICHARG,JCHARG)= -840*HCEGVE(1,ICHARG,JCHARG)/FACTOR(1)
     *                           +1680*HCEGVE(2,ICHARG,JCHARG)/FACTOR(2)
     *                            -672*HCEGVE(3,ICHARG,JCHARG)/FACTOR(3)
     *                             +64*HCEGVE(4,ICHARG,JCHARG)/FACTOR(4)
C
                END DO
             END DO
C
             EREGSD=C_ZERO
             EREGVD=C_ZERO
             EREGSE=C_ZERO
             EREGVE=C_ZERO
C
             ECEGOR=0.0D0
C
             DO INREGA=1,MUREGA
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      EREGSD(ICHARG,JCHARG)=EREGSD(       ICHARG,JCHARG)
     *                              +GOR_SD(INREGA,INGOGA,ICHARG,JCHARG)
     *                              *HREGSD(INREGA,       ICHARG,JCHARG)
C
                      EREGVD(ICHARG,JCHARG)=EREGVD(       ICHARG,JCHARG)
     *                              +GOR_VD(INREGA,INGOGA,ICHARG,JCHARG)
     *                              *HREGVD(INREGA,       ICHARG,JCHARG)
C
                      EREGSE(ICHARG,JCHARG)=EREGSE(       ICHARG,JCHARG)
     *                              +GOR_SE(INREGA,INGOGA,ICHARG,JCHARG)
     *                              *HREGSE(INREGA,       ICHARG,JCHARG)
C
                      EREGVE(ICHARG,JCHARG)=EREGVE(       ICHARG,JCHARG)
     *                              +GOR_VE(INREGA,INGOGA,ICHARG,JCHARG)
     *                              *HREGVE(INREGA,       ICHARG,JCHARG)
C
                      ECEGOR(INREGA)=ECEGOR(INREGA)+
     *                          REAL(COR_SD(INREGA,INGOGA,ICHARG,JCHARG)
     *                              *HCEGSD(INREGA,       ICHARG,JCHARG)
     *
     *                              +COR_VD(INREGA,INGOGA,ICHARG,JCHARG)
     *                              *HCEGVD(INREGA,       ICHARG,JCHARG)
     *
     *                              +COR_SE(INREGA,INGOGA,ICHARG,JCHARG)
     *                              *HCEGSE(INREGA,       ICHARG,JCHARG)
     *
     *                              +COR_VE(INREGA,INGOGA,ICHARG,JCHARG)
     *                              *HCEGVE(INREGA,       ICHARG,JCHARG)
     *                                                                 )
C
                   END DO
                END DO
C
             END DO
C
         ELSE
C
C=======================================================================
C            HERE WE IDENTIFY THE  POSITION  ("CE") ARRAYS
C                        WITH THE DERIVATIVE ("RE") ARRAYS
C=======================================================================
C
             HREGSD=HCEGSD
             HREGVD=HCEGVD
             HREGSE=HCEGSE
             HREGVE=HCEGVE
C
             EREGSD=ECEGSD
             EREGVD=ECEGVD
             EREGSE=ECEGSE
             EREGVE=ECEGVE
C
         END IF
C
         EREGOR=0.0D0
C
         DO INREGA=1,MUREGA
C
            DO ICHARG=0,NDISOS
               DO JCHARG=0,NDISOS
C
                  EREGOR(INREGA)=EREGOR(INREGA)+
     *                      REAL(GOR_SD(INREGA,INGOGA,ICHARG,JCHARG)*
     *                           HREGSD(INREGA,       ICHARG,JCHARG)+
     *
     *                           GOR_VD(INREGA,INGOGA,ICHARG,JCHARG)*
     *                           HREGVD(INREGA,       ICHARG,JCHARG)+
     *
     *                           GOR_SE(INREGA,INGOGA,ICHARG,JCHARG)*
     *                           HREGSE(INREGA,       ICHARG,JCHARG)+
     *
     *                           GOR_VE(INREGA,INGOGA,ICHARG,JCHARG)*
     *                           HREGVE(INREGA,       ICHARG,JCHARG))
C
               END DO
            END DO
C
         END DO
C
C=======================================================================
C        CALCULATING THE TOTAL DIRECT AND EXCHANGE ENERGIES
C=======================================================================
C
         EREGDT=0.0D0
         EREGET=0.0D0
C
         EKEREG=C_ZERO
C
         DO ICHARG=0,NDISOS
            DO JCHARG=0,NDISOS
C
               EREGDT=EREGDT
     *                +REAL(EREGSD(ICHARG,JCHARG)+EREGVD(ICHARG,JCHARG))
               EREGET=EREGET
     *                +REAL(EREGSE(ICHARG,JCHARG)+EREGVE(ICHARG,JCHARG))
C
               EKEREG=EKEREG+EREGSD(ICHARG,JCHARG)+EREGVD(ICHARG,JCHARG)
     *                      +EREGSE(ICHARG,JCHARG)+EREGVE(ICHARG,JCHARG)
C
            END DO
         END DO
C
C=======================================================================
C        CALCULATING THE TOTAL PAIRING ENERGY
C=======================================================================
C
         EREGPT=0.0D0
         DO ICHARG=0,NDISOS
            EREGPT=EREGPT+REAL(EREGSP(ICHARG)+EREGVP(ICHARG))
         END DO
C
C=======================================================================
C        HERE  ENDS  THE LOOP OVER DIFFERENT GAUSSIANS
C=======================================================================
C
      END DO
C
C=======================================================================
C        CALCULATING THE PAIRING GAPS OF THE REGULARIZED OR GOGNY FORCE
C=======================================================================
C
      IF (IGORPA.GE.2) THEN
C
          ALLOCATE(HPAIMP(1:NDBASE,1:NDBASE))
          ALLOCATE(HPAIPM(1:NDBASE,1:NDBASE))
C
          IF (ISIMPY.NE.1) THEN
C
              ALLOCATE(HPAIPP(1:NDBASE,1:NDBASE))
              ALLOCATE(HPAIMM(1:NDBASE,1:NDBASE))
C
          END IF
C
          DO ICHARG=0,NDISOS
C
             DELTAY=C_ZERO
C
             DO KARTEZ=0,NDKART
C
                DO IKET=1,LDBASE
                   NPY=NYVECT(IKET,1)
                   DO IBRA=1,LDBASE
                      MPY=NYVECT(IBRA,1)
C
                      HPAIMP(IBRA,IKET)=REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAMP(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      HPAIPM(IBRA,IKET)=REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAPM(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
C
                      IF (ISIMPY.NE.1) THEN
C
                      HPAIPP(IBRA,IKET)=REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAPP(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      HPAIMM(IBRA,IKET)=REGPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAMM(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      END IF
C
                   END DO
                END DO
C
                DELTAX(KARTEZ)=C_ZERO
                EPAIRX(KARTEZ)=C_ZERO
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      DELTAX(KARTEZ)=DELTAX(KARTEZ)
     *                              +HPAIMP(IBRA,IKET)
     *                              *DEN_PP(IKET,IBRA,0,ICHARG)
     *                              -HPAIPM(IBRA,IKET)
     *                              *DEN_PP(IKET,IBRA,1,ICHARG)
                      EPAIRX(KARTEZ)=EPAIRX(KARTEZ)
     *                              +HPAIPM(IBRA,IKET)*CONJG(
     *                               CHI_PM(IBRA,IKET,0,ICHARG))/2
     *                              +HPAIMP(IBRA,IKET)*CONJG(
     *                               CHI_PM(IBRA,IKET,1,ICHARG))/2
C
                      IF (ISIMPY.NE.1) THEN
C
                      DELTAX(KARTEZ)=DELTAX(KARTEZ)
     *                              -HPAIPP(IBRA,IKET)
     *                              *DEN_PM(IKET,IBRA,0,ICHARG)
     *                              +HPAIMM(IBRA,IKET)
     *                              *DEN_PM(IKET,IBRA,1,ICHARG)
                      EPAIRX(KARTEZ)=EPAIRX(KARTEZ)
     *                              +HPAIPP(IBRA,IKET)*CONJG(
     *                               CHI_PP(IBRA,IKET,0,ICHARG))/2
     *                              +HPAIMM(IBRA,IKET)*CONJG(
     *                               CHI_PP(IBRA,IKET,1,ICHARG))/2
                      END IF
C
                   END DO
                END DO
C
C=======================================================================
C             ATTENTION! THE CHANGES OF SIGN BELOW ARE NOT BASED ON  ANY
C                        DERIVATION, BUT THEY RESULT FROM THE COMPARISON
C                        WITH FINRES4 TESTS BY KARIM BENNACEUR.
C                        THEY HAVE BEEN INTRODUCED IN VERSION (2.79D) ON
C                        12.04.2017.
C=======================================================================
C             ATTENTION! DEFINITION OF THE  PAIRING  GAP  BELOW  IMPLIES
C                        DEPENDENCE   ON   THE   GAUGE   TRANSFORMATION.
C                        THEREFORE, ONLY  ITS  ABSOLUTE  VALUE  MATTERS.
C                        THIS HAS BEEN IMPLEMENTED IN VERSION (2.89B) ON
C                        12.03.2019.
C=======================================================================
C
                IF (KARTEZ.EQ.1) DELTAX(KARTEZ)=-DELTAX(KARTEZ)
                IF (KARTEZ.EQ.2) DELTAX(KARTEZ)=-DELTAX(KARTEZ)
C
                DELTAY=DELTAY             +DELTAX(KARTEZ)
                PREGVP(KARTEZ,ICHARG)=REAL(EPAIRX(KARTEZ))
C
C     WRITE (*,'(2I3,2(4X,2D15.7))') ICHARG,KARTEZ,
C    *                               DELTAX(KARTEZ),EPAIRX(KARTEZ)
C
             END DO
C
             IF (ICHARG.EQ.0) DELTAN=DELTAN+ABS(DELTAY)/IN_FIX
             IF (ICHARG.EQ.1) DELTAP=DELTAP+ABS(DELTAY)/IZ_FIX
C
          END DO
C
                           DEALLOCATE(HPAIMP,HPAIPM)
          IF (ISIMPY.NE.1) DEALLOCATE(HPAIPP,HPAIMM)
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('REGENE',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FSTENE(I_SLOW,SLOWEV,ISFSTA,
     *                         SLOWPA,ISFSTP,
     *                         ISIMPY,IN_FIX,IZ_FIX,
     *                         EKEFSO,EKEFTO,EKEFTE)
C=======================================================================
      USE TBCSTO
      USE FSTSTO
      USE FPASTO
      USE GAUSTO
      USE MAD_PP
      USE MAD_PM
      USE MAP_PP
      USE MAP_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDOSC2=(NDOSCI+1)*(NDOSCI+1))
      PARAMETER (NDFSTA=3)
C=======================================================================
      COMPLEX
     *          EFSOSD,EFSOSE,
     *          EFTOSD,EFTOSE,
     *          EFTESD,EFTESE
      COMPLEX
     *          EFSOSP,EFTOSP,EFTESP
      COMPLEX
     *          EFSTSD,EFSTSE
      COMPLEX
     *          HREGSD,HREGSE,HREGSP
      COMPLEX
     *          EKEFSO,EKEFTO,EKEFTE
      COMPLEX
     *          C_ZERO,UNIT_I,CFSTXX
      COMPLEX
     *          DELTAY,DELTAX(0:NDKART),EPAIRX(0:NDKART)
      COMPLEX
     *          HPAIMP,HPAIPM,HPAIPP,HPAIMM
      COMPLEX
     *          PHACOM
      COMPLEX
     *          GAXVEC,GAYVEC,GAZVEC,
     *          GAXVEI,GAYVEI,GAZVEI
C=======================================================================
      ALLOCATABLE :: HPAIMP(:,:),HPAIPM(:,:),HPAIPP(:,:),HPAIMM(:,:)
C=======================================================================
C
      DIMENSION
     *          DUMSTR(NDGOGA,NDFORC)
      DIMENSION
     *          FSO_SD(NDGOGA,0:NDISOS,0:NDISOS),
     *          FSO_VD(NDGOGA,0:NDISOS,0:NDISOS),
     *          FSO_SE(NDGOGA,0:NDISOS,0:NDISOS),
     *          FSO_VE(NDGOGA,0:NDISOS,0:NDISOS),
     *          FSO_SP(NDGOGA,0:NDISOS,0:NDISOS),
     *          FSO_VP(NDGOGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          FTO_SD(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTO_VD(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTO_SE(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTO_VE(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTO_SP(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTO_VP(NDGOGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          FTE_SD(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTE_VD(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTE_SE(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTE_VE(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTE_SP(NDGOGA,0:NDISOS,0:NDISOS),
     *          FTE_VP(NDGOGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          FST_XX(NDGOGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          HREGSD(NDREGA,0:NDISOS,0:NDISOS),
     *          HREGSE(NDREGA,0:NDISOS,0:NDISOS),
     *          HREGSP(NDREGA,0:NDISOS,0:NDISOS)
C=======================================================================
      COMMON
     *       /FSTSIN/ FSTX00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /GA_DIQ/ GAXEIG(NDOSC2),GAYEIG(NDOSC2),GAZEIG(NDOSC2),
     *
     *                GAXVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAYVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAZVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *
     *                GAXVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAYVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAZVEI(NDOSC2,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /ENEFST/ EFSTSD(NDFSTA,0:NDISOS,0:NDISOS),
     *                EFSTSE(NDFSTA,0:NDISOS,0:NDISOS)
      COMMON
     *       /PV_FST/ PFSTVP(0:NDKART,0:NDISOS)
      COMMON
     *       /PN_FST/ EFSOSP(0:NDISOS),EFTOSP(0:NDISOS),EFTESP(0:NDISOS)
      COMMON
     *       /FSTFOR/ FSOSTR(NDGOGA,NDFORC),
     *                FTOSTR(NDGOGA,NDFORC),
     *                FTESTR(NDGOGA,NDFORC),FSTWID(NDGOGA)
      COMMON
     *       /EFSOTT/ EFSODT,EFSOET
      COMMON
     *       /EFTOTT/ EFTODT,EFTOET
      COMMON
     *       /EFTETT/ EFTEDT,EFTEET
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /B_PHAS/ JPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIQ_GA/ DIQCOD,DIQCOE,DIQCOP,IDIQGA
      COMMON
     *       /MNDDIQ/ KXDDIQ(0:NDOSCI,0:NDOSCI),LXDDIQ(NDOSC2,2),NXDDIQ,
     *                KYDDIQ(0:NDOSCI,0:NDOSCI),LYDDIQ(NDOSC2,2),NYDDIQ,
     *                KZDDIQ(0:NDOSCI,0:NDOSCI),LZDDIQ(NDOSC2,2),NZDDIQ
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /SWFSTA/ I_FSTA(NDFSTA)
      COMMON
     *       /SFSTPA/ IFSTPA(NDFSTA)
C
C=======================================================================
C
      CALL CPUTIM('FSTENE',1)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
      CFSTXX=CMPLX(1.0D0,0.0D0)
C
      SQRTPI=SQRT(4.0D0*ATAN(1.0D0))
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE AVERAGE VALUES AND  MEAN  FIELDS
C        OF THE FINITE-RANGE SPIN-ORBIT AND TENSOR FORCES
C=======================================================================
C        1) FOR MAXVAL(I_FSTA)>0 THIS SUBROUTINE CALCULATES THE P=H
C           AVERAGE VALUES OF THE FINITE-RANGE SPIN-ORBIT AND TENSOR
C           FORCES
C        2) FOR I_FSTA(I)=2 OR I_FSTA(I)=3, IT CALCULATES IN ADDITION
C           THE CORRESPONDING DIRECT P-H FIELDS OF THE SPIN-ORBIT (I=1)
C           ODD TENSOR (I=2) OR EVEN TENSOR (I=3) FORCE
C        3) FOR I_FSTA(I)=2 OR I_FSTA(I)=4, IT CALCULATES IN ADDITION
C           THE CORRESPONDING EXCHANAGE MEAN FIELDS
C        4) FOR IFSTPA(I)>0 IT CALCULATES THE P-P AVERAGE VALUES OF THE
C           FINITE-RANGE SPIN-ORBIT AND TENSOR FORCE
C        5) FOR IFSTPA(I)=2 IT CALCULATES IN ADDITION THE  CORRESPONDING
C           P-P FIELDS
C
C        SWITCHES "I_FSTA" AND "IFSTPA" HANDLE CALCULATIONS OF  THE  P-H
C        AND P-P CONTRIBUTIONS, RESPECTIELY, AND:
C         I_FSTA(1) AND IFSTPA(1) HANDLE CALCULATIONS OF THE  SPIN-ORBIT
C         I_FSTA(2) AND IFSTPA(2) HANDLE CALCULATIONS OF THE  ODD TENSOR
C         I_FSTA(3) AND IFSTPA(3) HANDLE CALCULATIONS OF THE EVEN TENSOR
C=======================================================================
C           ATTENTION: FOR THE FINITE-RANGE SPIN-ORBIT AND TENSOR TERMS,
C                      THERE  ARE  ONLY  TWO  INDEPENDENT   SPIN-ISOSPIN
C                      COMPONENTS "W,H" OF THE FORCE  PARAMETERS  STORED
C                      IN ARRAYS  "FSOSTR", "FTOSTR",  AND  "FTESTR" FOR
C                      THEIR SECOND INDICES EQUAL 1 OR 3. THE  REMAINING
C                      TWO PARAMETERS "B,M" ARE REDUNDANT AND  THUS  THE
C                      VALUES STORED FOR THEIR SECOND INDICES EQUAL 2 OR
C                      4 ARE IRRELEVANT. NEVERTHELESS,  SINCE  THE  CODE
C                      (THE  "P._FST"  SUBROUTINES)  EXPECTS   RECEIVING
C                      ARRAYS DIMENDIONNED FROM 1 TO 4 , THE   REDUNDANT
C                      SPIN-ISOSPIN COMPONENTS 2 AND 4 ARE SET EQUAL  TO
C                      ZERO. BY THE SAME TOKEN, ALL VECTOR P-N TERMS, IN
C                      ARRAYS  "FSO_V.",  "FTO_V.",  AND  "FTE_V.",  ARE
C                      NEVER USED IN THIS SUBROUTINE.
C=======================================================================
C           ATTENTION: A. FOR THE ENERGIES, ONLY THE AVERAGE  VALUES  OF
C                         THE SPIN-ORBIT AND TENSOR TERMS ARE CALCULATED
C                         IN "GAUENE" AND ALL NUMERICAL  PREFACTORS  ARE
C                         ADDED EXPLICITLY HERE IN "FSTENE"  ALONG  WITH
C                         COMBINING THE SPIN AND MOMENTUM COMPONENTS.
C                      B. FOR THE MEAN FIELDS, COMPLETE  FIELDS  OF  THE
C                         SPIN-ORBIT AND  TENSOR  TERMS  ARE  CALCULATED
C                         IN "GAUENE"  AND ALL NUMERICAL  PREFACTORS ARE
C                         EXPLICITLY INCLUDED THERE.
C=======================================================================
C           ATTENTION: AT PRESENT, FOR EVERY SPIN-ORBIT OR TENSOR  TERM,
C                      ONLY ONE GAUSSIAN IS IMPLEMENTED
C=======================================================================
C           ATTENTION: AT PRESENT, FOR EVERY SPIN-ORBIT OR TENSOR  TERM,
C                      ONLY THE LOWEST (FIRST) ORDER TERM IS IMPLEMENTED
C=======================================================================
C
      NUFSOA=1
      NUFTOA=1
      NUFTEA=1
C
      IF (NUFSOA.GT.NDGOGA) STOP 'NUFSOA TOO LARGE IN FSTENE'
      IF (NUFTOA.GT.NDGOGA) STOP 'NUFTNA TOO LARGE IN FSTENE'
      IF (NUFTEA.GT.NDGOGA) STOP 'NUFTNA TOO LARGE IN FSTENE'
C
C=======================================================================
C        NOTE THAT THE NUMBER OF TERMS      IS EQUAL TO MUFSTA=4
C              AND THE NUMBER OF GAUSSIANS IS  EQUAL TO MUGOGA=1
C=======================================================================
C
      MUFSTA=4
      MUGOGA=1
C
C=======================================================================
C           HERE ARE THE NN, NP, PP, AND PN STRENGTHS
C           DERIVED IN THE NOTES 105-A (9-175)
C=======================================================================
C           HERE WE NORMALIZE THE SPIN-ORBIT & TENSOR COUPLING CONSTANTS
C           READ FROM THE INPUT DATA FILE TO THE GAUSSIAN  FACTORS  THAT
C           CORRESPOND TO THE REGULARIZED DELTAS. IN THIS WAY,  THE SAME
C           VALUES OF THE COUPLING CONSTANTS CAN BE USED FOR THE  FINITE
C           RANGE AND ZERO RANGE, AND THE ZERO-RANGE LIMIT CAN BE EASILY
C           OBTAINED.
C=======================================================================
C           ATTENTION: THIS NORMALIZATION  WAS  IMPLEMENTED  IN  VERSION
C                      (3.31I) ON 03/12/2024.
C=======================================================================
C
      DO INGOGA=1,MUGOGA
         DUMSTR(INGOGA,1:NDFORC)=FSOSTR(INGOGA,1:NDFORC)/
     *                          (FSTWID(INGOGA)*SQRTPI)**3
      END DO
C
      CALL PH_FST(DUMSTR,FSO_SD,FSO_SE,NDGOGA,NUFSOA)
C
C     WRITE (*,'(A,2X,4E15.6)') 'FSOSTR',FSOSTR(1,:)
C     WRITE (*,'(A,2X,4E15.6)') 'FSO_SD',FSO_SD(1,:,:)
C     WRITE (*,'(A,2X,4E15.6)') 'FSO_VD',FSO_VD(1,:,:)
C     WRITE (*,'(A,2X,4E15.6)') 'FSO_SE',FSO_SE(1,:,:)
C     WRITE (*,'(A,2X,4E15.6)') 'FSO_VE',FSO_VE(1,:,:)
C
      CALL PP_FST(DUMSTR,FSO_SP,NDGOGA,NUFSOA)
C
C     WRITE (*,'(A,2X,4E15.6)') 'FSOSTR',FSOSTR(1,:)
C     WRITE (*,'(A,2X,4E15.6)') 'FSO_SP',FSO_SP(1,:,:)
C
      DO INGOGA=1,MUGOGA
         DUMSTR(INGOGA,1:NDFORC)=FTOSTR(INGOGA,1:NDFORC)/
     *                          (FSTWID(INGOGA)*SQRTPI)**3
      END DO
C
      CALL PH_FST(DUMSTR,FTO_SD,FTO_SE,NDGOGA,NUFTOA)
C
      CALL PP_FST(DUMSTR,FTO_SP,NDGOGA,NUFTOA)
C
C     WRITE (*,'(A,2X,4E15.6)') 'FTOSTR',FTOSTR(1,:)
C     WRITE (*,'(A,2X,4E15.6)') 'FTO_SP',FTO_SP(1,:,:)
C
      DO INGOGA=1,MUGOGA
         DUMSTR(INGOGA,1:NDFORC)=FTESTR(INGOGA,1:NDFORC)/
     *                          (FSTWID(INGOGA)*SQRTPI)**3
      END DO
C
      CALL PH_FST(DUMSTR,FTE_SD,FTE_SE,NDGOGA,NUFTEA)
C
      CALL PP_FST(DUMSTR,FTE_SP,NDGOGA,NUFTEA)
C
C     WRITE (*,'(A,2X,4E15.6)') 'FTESTR',FTESTR(1,:)
C     WRITE (*,'(A,2X,4E15.6)') 'FTE_SP',FTE_SP(1,:,:)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(FSTASV).AND.MAXVAL(I_FSTA).GE.2) THEN
          ALLOCATE (FSTASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FSTASV','FSTENE')
      END IF
      IF (.NOT.ALLOCATED(FSTPSV).AND.MAXVAL(IFSTPA).GE.2) THEN
          ALLOCATE (FSTPSV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FSTPSV','FSTENE')
      END IF
C
C=======================================================================
C        ZEROING THE ARRAYS THAT WILL COLLECT THE CONTRIBUTIONS COMING
C        FROM INDIVIDUAL TERMS AND INDIVIDUAL GAUSSIANS
C=======================================================================
C
      EFSOSD=C_ZERO
      EFSOSE=C_ZERO
C
      EFTOSD=C_ZERO
      EFTOSE=C_ZERO
C
      EFTESD=C_ZERO
      EFTESE=C_ZERO
C
      EFSOSP(:)=C_ZERO
      EFTOSP(:)=C_ZERO
      EFTESP(:)=C_ZERO
C
      EFSTSD(:,:,:)=C_ZERO
      EFSTSE(:,:,:)=C_ZERO
C
C=======================================================================
C        INITIALIZING THE SLOW-DOWN FACTORS
C=======================================================================
C
      IF (ISFSTA.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDEV=0.0
      ELSE
          XOLDEV=SLOWEV
      END IF
C
      XNEWEV=1.0-XOLDEV
C
      IF (ISFSTP.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDPA=0.0
      ELSE
          XOLDPA=SLOWPA
      END IF
C
      XNEWPA=1.0-XOLDPA
C
C=======================================================================
C        INITIALIZING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      IF (MAXVAL(I_FSTA).GE.2) THEN
C
          IF (ISFSTA.NE.1) THEN
C
              FSTASV=C_ZERO
          ELSE
              FSTASV=FSTASV*XOLDEV
C
          END IF
C
      END IF
C
      IF (MAXVAL(IFSTPA).GE.2) THEN
C
          IF (ISFSTP.NE.1) THEN
C
              FSTPSV=C_ZERO
          ELSE
              FSTPSV=FSTPSV*XOLDPA
C
          END IF
C
      END IF
C
C=======================================================================
C        HERE STARTS THE LOOP OVER DIFFERENT GAUSSIANS
C=======================================================================
C
      DO INGOGA=1,MUGOGA
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS UNLESS MAXVAL(I_FSTA).LT.1
C=======================================================================
C
         IF (MAXVAL(I_FSTA).LT.1) GO TO 5672
C
         FSTWI0=FSTWID(INGOGA)
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
         NXMAXX=NXMAXV(1)
         NYMAXX=NYMAXV(1)
         NZMAXX=NZMAXV(1)
C
         CALL DEFFST(NXMAXX,NGAUSS,1,FSTWI0,
     *               FSTX00,FSTX01,FSTX10,FSTX02,FSTX11,FSTX20,
     *                             GAUX22,GAUX41,GAUX42,GAUX43)
         CALL DEFFST(NYMAXX,NGAUSS,2,FSTWI0,
     *               FSTY00,FSTY01,FSTY10,FSTY02,FSTY11,FSTY20,
     *                             GAUY22,GAUY41,GAUY42,GAUY43)
         CALL DEFFST(NZMAXX,NGAUSS,3,FSTWI0,
     *               FSTZ00,FSTZ01,FSTZ10,FSTZ02,FSTZ11,FSTZ20,
     *                             GAUZ22,GAUZ41,GAUZ42,GAUZ43)
C
         IDENSI=0
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS  THAT  CONSTITUTE  THE  FINITE-
C        RANGE SPIN-ORBIT AND TENSOR FORCE
C=======================================================================
C        HERE AND BELOW, THE LOOP COUNTER "INREGA" ENUMERATES FOUR TYPES
C        OF TERMS THAT HAVE TO BE CALCULATED:
C          INREGA=1 CORRESPONDS TO CALCULATING THE VECTOR  K' X K  TERMS
C                   THAT DEFINE THE SPIN-ORBIT INTERACTION
C          INREGA=2 CORRESPONDS TO CALCULATING THE TENSOR  K' X K  TERMS
C                   THAT DEFINE THE ODD TENSOR INTERACTION
C          INREGA=3 CORRESPONDS TO CALCULATING THE TENSOR  K' X K' TERMS
C                   THAT DEFINE TERM 1 OF THE EVEN TENSOR INTERACTION
C          INREGA=4 CORRESPONDS TO CALCULATING THE TENSOR  K  X K  TERMS
C                   THAT DEFINE TERM 2 OF THE EVEN TENSOR INTERACTION
C=======================================================================
C
         DO INREGA=1,MUFSTA
C
            HREGSD(INREGA,:,:)=C_ZERO
C
            I_PART=-1
C
            IF (I_FSTA(1).GE.1.AND.INREGA.EQ.1) I_PART=13
            IF (I_FSTA(2).GE.1.AND.INREGA.EQ.2) I_PART=14
            IF (I_FSTA(3).GE.1.AND.INREGA.EQ.3) I_PART=15
            IF (I_FSTA(3).GE.1.AND.INREGA.EQ.4) I_PART=16
C
            J_FSTA=1
C
            IF (I_FSTA(1).EQ.2.AND.INREGA.EQ.1.OR.
     *          I_FSTA(2).EQ.2.AND.INREGA.EQ.2.OR.
     *          I_FSTA(3).EQ.2.AND.INREGA.EQ.3.OR.
     *          I_FSTA(3).EQ.2.AND.INREGA.EQ.4.OR.
     *
     *          I_FSTA(1).EQ.3.AND.INREGA.EQ.1.OR.
     *          I_FSTA(2).EQ.3.AND.INREGA.EQ.2.OR.
     *          I_FSTA(3).EQ.3.AND.INREGA.EQ.3.OR.
     *          I_FSTA(3).EQ.3.AND.INREGA.EQ.4)    J_FSTA=2
C
            IF (I_FSTA(1).GE.1.AND.INREGA.EQ.1.OR.
     *          I_FSTA(2).GE.1.AND.INREGA.EQ.2.OR.
     *          I_FSTA(3).GE.1.AND.INREGA.EQ.3.OR.
     *          I_FSTA(3).GE.1.AND.INREGA.EQ.4)    THEN
C
                IF (IDIQGA.EQ.1) THEN
C
C=======================================================================
C        DIAGONALIZE THE GAUSSIAN FORMFACTORS AND EVALUATE THE
C        CORRESPONDING ENERGIES AND FIELDS USING THE DIAGONAL
C        APPROXIMATION
C=======================================================================
C
                    CALL DEFDIQ(NXMAXX,FSTX00,GAXEIG,GAXVEC,GAXVEI,
     *                                        KXDDIQ,LXDDIQ,NXDDIQ)
C
                    CALL DEFDIQ(NYMAXX,FSTY00,GAYEIG,GAYVEC,GAYVEI,
     *                                        KYDDIQ,LYDDIQ,NYDDIQ)
C
                    CALL DEFDIQ(NZMAXX,FSTZ00,GAZEIG,GAZVEC,GAZVEI,
     *                                        KZDDIQ,LZDDIQ,NZDDIQ)
C
                    CALL GAUDIQ(ISIMPY,J_FSTA,I_PART,IDENSI,DIQCOD)
C
                ELSE
C
                    CALL GAUENE(ISIMPY,J_FSTA,I_PART,IDENSI,1,1)
C
                END IF
C
            END IF
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
C=======================================================================
C           FINITE-RANGE SPIN-ORBIT, SEE EQ. (115)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
            IF (I_FSTA(1).GE.1.AND.INREGA.EQ.1) THEN
C
C=======================================================================
C               FOR INREGA=1 (I_PART=13), IN ITS FIRST TWO INDICES ARRAY
C               "TINAVR" IS SUPPOSED TO CONTAIN AVERAGE ENERGIES FOR THE
C               SIX OFF-DIAGONAL CARTESIAN COMPONENTS  OF  THE  MOMENTUM
C               k'_i^* AND k_j, THAT IS, FOR i DIFFERENT THEN j.
C=======================================================================
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      HREGSD(INREGA,ICHARG,JCHARG)=
     *                HREGSD(INREGA,ICHARG,JCHARG)
     *
     *               +(TINAVR(2,3,1,0,ICHARG,JCHARG)
     *                +TINAVR(2,3,0,1,ICHARG,JCHARG))
     *               -(TINAVR(3,2,1,0,ICHARG,JCHARG)
     *                +TINAVR(3,2,0,1,ICHARG,JCHARG))
     *
     *               +(TINAVR(3,1,2,0,ICHARG,JCHARG)
     *                +TINAVR(3,1,0,2,ICHARG,JCHARG))
     *               -(TINAVR(1,3,2,0,ICHARG,JCHARG)
     *                +TINAVR(1,3,0,2,ICHARG,JCHARG))
     *
     *               +(TINAVR(1,2,3,0,ICHARG,JCHARG)
     *                +TINAVR(1,2,0,3,ICHARG,JCHARG))
     *               -(TINAVR(2,1,3,0,ICHARG,JCHARG)
     *                +TINAVR(2,1,0,3,ICHARG,JCHARG))
C
C     WRITE (*,'(3I3,2E15.6,12(4I3,2E13.4))') INREGA,ICHARG,JCHARG,
C    *               HREGSD(INREGA,ICHARG,JCHARG),
C    *               2,3,1,0,TINAVR(2,3,1,0,ICHARG,JCHARG),
C    *               2,3,0,1,TINAVR(2,3,0,1,ICHARG,JCHARG),
C    *               3,2,1,0,TINAVR(3,2,1,0,ICHARG,JCHARG),
C    *               3,2,0,1,TINAVR(3,2,0,1,ICHARG,JCHARG),
C    *
C    *               3,1,2,0,TINAVR(3,1,2,0,ICHARG,JCHARG),
C    *               3,1,0,2,TINAVR(3,1,0,2,ICHARG,JCHARG),
C    *               1,3,2,0,TINAVR(1,3,2,0,ICHARG,JCHARG),
C    *               1,3,0,2,TINAVR(1,3,0,2,ICHARG,JCHARG),
C    *
C    *               1,2,3,0,TINAVR(1,2,3,0,ICHARG,JCHARG),
C    *               1,2,0,3,TINAVR(1,2,0,3,ICHARG,JCHARG),
C    *               2,1,3,0,TINAVR(2,1,3,0,ICHARG,JCHARG),
C    *               2,1,0,3,TINAVR(2,1,0,3,ICHARG,JCHARG)
C
                   END DO
                END DO
C
C=======================================================================
C               THE IMAGINARY UNIT BELOW COMES FROM THAT IN EQ. (115)
C               OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
                HREGSD(INREGA,:,:)=UNIT_I*HREGSD(INREGA,:,:)
C
            END IF
C
C=======================================================================
C           FINITE-RANGE ODD TENSOR, SEE EQ. (117)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
            IF (I_FSTA(2).GE.1.AND.INREGA.EQ.2) THEN
C
C=======================================================================
C               FOR INREGA=2 (I_PART=14), IN ITS FIRST TWO INDICES ARRAY
C               "TINAVR" IS SUPPOSED TO CONTAIN AVERAGE ENERGIES FOR THE
C               CARTESIAN COMPONENTS OF THE MOMENTUM k'_i^* AND k_j  FOR
C               ALL VALUES OF PAIRS OF INDICES (i,j), THAT IS,  FOR  ALL
C               ITS COMPONENTS.
C=======================================================================
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      DO KARTEL=1,NDKART
                         DO KARTEP=1,NDKART
C
                      HREGSD(INREGA,ICHARG,JCHARG)=
     *                HREGSD(INREGA,ICHARG,JCHARG)
     *
     *              +(TINAVR(KARTEL,KARTEP,KARTEL,KARTEP,ICHARG,JCHARG)
     *               +TINAVR(KARTEL,KARTEP,KARTEP,KARTEL,ICHARG,JCHARG))
     *                                                          *3.0D0/2
     *               -TINAVR(KARTEL,KARTEL,KARTEP,KARTEP,ICHARG,JCHARG)
C
C     WRITE (*,'(3I3,2E15.6,3(4I3,2E13.4))') INREGA,ICHARG,JCHARG,
C    *               HREGSD(INREGA,ICHARG,JCHARG),
C    *               KARTEL,KARTEP,KARTEL,KARTEP,
C    *        TINAVR(KARTEL,KARTEP,KARTEL,KARTEP,ICHARG,JCHARG),
C    *               KARTEL,KARTEP,KARTEP,KARTEL,
C    *        TINAVR(KARTEL,KARTEP,KARTEP,KARTEL,ICHARG,JCHARG),
C    *               KARTEL,KARTEL,KARTEP,KARTEP,
C    *        TINAVR(KARTEL,KARTEL,KARTEP,KARTEP,ICHARG,JCHARG)
C
                        END DO
                     END DO
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           FINITE-RANGE EVEN TENSOR BOTH TERMS, SEE EQ. (116)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
            IF (I_FSTA(3).GE.1.AND.(INREGA.EQ.3.OR.INREGA.EQ.4)) THEN
C
C=======================================================================
C               FOR INREGA=3 (I_PART=15), IN ITS FIRST TWO INDICES ARRAY
C               "TINAVR" IS SUPPOSED TO CONTAIN AVERAGE ENERGIES FOR THE
C               CARTESIAN COMPONENTS OF THE MOMENTUM  k_i   &   k_j  FOR
C               ALL VALUES OF PAIRS OF INDICES (i,j), THAT IS,  FOR  ALL
C               ITS COMPONENTS.
C=======================================================================
C               FOR INREGA=4 (I_PART=16), IN ITS FIRST TWO INDICES ARRAY
C               "TINAVR" IS SUPPOSED TO CONTAIN AVERAGE ENERGIES FOR THE
C               CARTESIAN COMPONENTS OF THE MOMENTUM k'_i^* & k'_j^* FOR
C               ALL VALUES OF PAIRS OF INDICES (i,j), THAT IS,  FOR  ALL
C               ITS COMPONENTS.
C=======================================================================
C               HERE WE SYMMETRIZE  ARRAY  "TINAVR"  BY  COMPLETING  THE
C               CARTESIAN ELEMENTS THAT WERE NOT CALCULATED IN "GAUENE".
C
                TINAVR(2,1,:,:,:,:)=TINAVR(1,2,:,:,:,:)
                TINAVR(3,1,:,:,:,:)=TINAVR(1,3,:,:,:,:)
                TINAVR(3,2,:,:,:,:)=TINAVR(2,3,:,:,:,:)
C
C=======================================================================
C               THE FLIPPED SIGN BELOW COMES FROM TWO IMAGINARY UNITS BY
C               WHICH THE TWO RELATIVE LINEAR MOMENTA, k OR k'*,  DIFFER
C               FROM THE  DERIVATIVES  OVER  THE  RELATIVE  COORDINATES,
C               r OR r',  RESPECTIVELY,  SEE  BELOW  EQS.  (3)  AND  (4)
C               OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      DO KARTEL=1,NDKART
                         DO KARTEP=1,NDKART
C
                      HREGSD(INREGA,ICHARG,JCHARG)=
     *                HREGSD(INREGA,ICHARG,JCHARG)
     *
     *              -(TINAVR(KARTEL,KARTEP,KARTEL,KARTEP,ICHARG,JCHARG)
     *               +TINAVR(KARTEL,KARTEP,KARTEP,KARTEL,ICHARG,JCHARG))
     *                                                          *3.0D0/4
     *               +TINAVR(KARTEL,KARTEL,KARTEP,KARTEP,ICHARG,JCHARG)
     *                                                                /2
C
                        END DO
                     END DO
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           CALCULATING THE SUM OF ALL DIRECT TERMS
C=======================================================================
C           FACTORS 1/2 BELOW CORRESPOND TO THE OVERALL FACTOR OF THE
C           TWO-BODY ENERGY RELATED TO THE ANTISYMMETRISATION  OF THE
C           INTERACTION
C=======================================================================
C
            DO ICHARG=0,NDISOS
               DO JCHARG=0,NDISOS
C
                  IF (INREGA.EQ.1)
     *            EFSOSD=EFSOSD+FSO_SD(INGOGA,ICHARG,JCHARG)
     *                         *HREGSD(INREGA,ICHARG,JCHARG)/2
C
                  IF (INREGA.EQ.2)
     *            EFTOSD=EFTOSD+FTO_SD(INGOGA,ICHARG,JCHARG)
     *                         *HREGSD(INREGA,ICHARG,JCHARG)/2
C
                  IF (INREGA.EQ.3.OR.INREGA.EQ.4)
     *            EFTESD=EFTESD+FTE_SD(INGOGA,ICHARG,JCHARG)
     *                         *HREGSD(INREGA,ICHARG,JCHARG)/2
C
C=======================================================================
C
                  IF (INREGA.EQ.1)
     *            EFSTSD(1,ICHARG,JCHARG)=EFSTSD(1,ICHARG,JCHARG)
     *                         +FSO_SD(INGOGA,ICHARG,JCHARG)
     *                         *HREGSD(INREGA,ICHARG,JCHARG)/2
C
                  IF (INREGA.EQ.2)
     *            EFSTSD(2,ICHARG,JCHARG)=EFSTSD(2,ICHARG,JCHARG)
     *                         +FTO_SD(INGOGA,ICHARG,JCHARG)
     *                         *HREGSD(INREGA,ICHARG,JCHARG)/2
C
                  IF (INREGA.EQ.3.OR.INREGA.EQ.4)
     *            EFSTSD(3,ICHARG,JCHARG)=EFSTSD(3,ICHARG,JCHARG)
     *                         +FTE_SD(INGOGA,ICHARG,JCHARG)
     *                         *HREGSD(INREGA,ICHARG,JCHARG)/2
C
               END DO
            END DO
C
C=======================================================================
C           CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
            FST_XX=0.0D0
            IFSTXX=0
C
            IF (INREGA.EQ.1.AND.(I_FSTA(1).EQ.2.OR.I_FSTA(1).EQ.3)) THEN
C
                FST_XX=FSO_SD
                IFSTXX=1
                CFSTXX=UNIT_I
C
            END IF
C
            IF (INREGA.EQ.2.AND.(I_FSTA(2).EQ.2.OR.I_FSTA(2).EQ.3)) THEN
C
                FST_XX=FTO_SD
                IFSTXX=1
                CFSTXX=CMPLX(1.0D0,0.0D0)
C
            END IF
C
            IF ((INREGA.EQ.3.OR.INREGA.EQ.4).AND.
     *                          (I_FSTA(3).EQ.2.OR.I_FSTA(3).EQ.3)) THEN
C
                FST_XX=FTE_SD
                IFSTXX=1
                CFSTXX=CMPLX(1.0D0,0.0D0)
C
            END IF
C
            IF (IFSTXX.GE.1) THEN
C
                DO ICHARG=0,NDISOS
C
                   DO IKET=1,LDBASE
                      DO IBRA=1,LDBASE
C
                         KARTEZ=0
C
                         FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  +FST_XX(INGOGA,ICHARG,ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                                    *CFSTXX*XNEWEV
     *
     *                  +FST_XX(INGOGA,ICHARG,1-ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                    *CFSTXX*XNEWEV
C
                        DO KARTEZ=1,NDKART
C
                           FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *                    =FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                        +FST_XX(INGOGA,ICHARG,ICHARG)
     *                        *GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                                    *CFSTXX*XNEWEV
     *
     *                        +FST_XX(INGOGA,ICHARG,1-ICHARG)
     *                        *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                    *CFSTXX*XNEWEV
C
                        END DO
C
                      END DO
                   END DO
C
                END DO
C
                ISFSTA=1
C
            END IF
C
         END DO ! INREGA=1,MUFSTA
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
         CALL EXCGOG(NXMAXX,
     *               FSTX00,FSTX01,FSTX10,FSTX02,FSTX11,FSTX20,
     *                             GAUX22,GAUX41,GAUX42,GAUX43)
         CALL EXCGOG(NYMAXX,
     *               FSTY00,FSTY01,FSTY10,FSTY02,FSTY11,FSTY20,
     *                             GAUY22,GAUY41,GAUY42,GAUY43)
         CALL EXCGOG(NZMAXX,
     *               FSTZ00,FSTZ01,FSTZ10,FSTZ02,FSTZ11,FSTZ20,
     *                             GAUZ22,GAUZ41,GAUZ42,GAUZ43)
C
         IDENSI=0
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS  THAT  CONSTITUTE  THE  FINITE-
C        RANGE SPIN-ORBIT AND TENSOR FORCE.
C=======================================================================
C
         DO INREGA=1,MUFSTA
C
            HREGSE(INREGA,:,:)=C_ZERO
C
            I_PART=-1
C
            IF (I_FSTA(1).GE.1.AND.INREGA.EQ.1) I_PART=13
            IF (I_FSTA(2).GE.1.AND.INREGA.EQ.2) I_PART=14
            IF (I_FSTA(3).GE.1.AND.INREGA.EQ.3) I_PART=15
            IF (I_FSTA(3).GE.1.AND.INREGA.EQ.4) I_PART=16
C
            J_FSTA=1
C
            IF (I_FSTA(1).EQ.2.AND.INREGA.EQ.1.OR.
     *          I_FSTA(2).EQ.2.AND.INREGA.EQ.2.OR.
     *          I_FSTA(3).EQ.2.AND.INREGA.EQ.3.OR.
     *          I_FSTA(3).EQ.2.AND.INREGA.EQ.4.OR.
     *
     *          I_FSTA(1).EQ.4.AND.INREGA.EQ.1.OR.
     *          I_FSTA(2).EQ.4.AND.INREGA.EQ.2.OR.
     *          I_FSTA(3).EQ.4.AND.INREGA.EQ.3.OR.
     *          I_FSTA(3).EQ.4.AND.INREGA.EQ.4)    J_FSTA=2
C
            IF (I_FSTA(1).GE.1.AND.INREGA.EQ.1.OR.
     *          I_FSTA(2).GE.1.AND.INREGA.EQ.2.OR.
     *          I_FSTA(3).GE.1.AND.INREGA.EQ.3.OR.
     *          I_FSTA(3).GE.1.AND.INREGA.EQ.4)    THEN
C
                IF (IDIQGA.EQ.1) THEN
C
C=======================================================================
C        DIAGONALIZE THE GAUSSIAN FORMFACTORS AND EVALUATE THE
C        CORRESPONDING ENERGIES AND FIELDS USING THE DIAGONAL
C        APPROXIMATION
C=======================================================================
C
                    CALL DEFDIQ(NXMAXX,FSTX00,GAXEIG,GAXVEC,GAXVEI,
     *                                        KXDDIQ,LXDDIQ,NXDDIQ)
C
                    CALL DEFDIQ(NYMAXX,FSTY00,GAYEIG,GAYVEC,GAYVEI,
     *                                        KYDDIQ,LYDDIQ,NYDDIQ)
C
                    CALL DEFDIQ(NZMAXX,FSTZ00,GAZEIG,GAZVEC,GAZVEI,
     *                                        KZDDIQ,LZDDIQ,NZDDIQ)
C
                    CALL GAUDIQ(ISIMPY,J_FSTA,I_PART,IDENSI,DIQCOD)
C
                ELSE
C
                    CALL GAUENE(ISIMPY,J_FSTA,I_PART,IDENSI,1,1)
C
                END IF
C
            END IF
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE EXCHANGE TERM
C=======================================================================
C
C=======================================================================
C           FINITE-RANGE SPIN-ORBIT, SEE EQ. (115)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
            IF (I_FSTA(1).GE.1.AND.INREGA.EQ.1) THEN
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      HREGSE(INREGA,ICHARG,JCHARG)=
     *                HREGSE(INREGA,ICHARG,JCHARG)
     *
     *               +(TINAVR(2,3,1,0,ICHARG,JCHARG)
     *                +TINAVR(2,3,0,1,ICHARG,JCHARG))
     *               -(TINAVR(3,2,1,0,ICHARG,JCHARG)
     *                +TINAVR(3,2,0,1,ICHARG,JCHARG))
     *
     *               +(TINAVR(3,1,2,0,ICHARG,JCHARG)
     *                +TINAVR(3,1,0,2,ICHARG,JCHARG))
     *               -(TINAVR(1,3,2,0,ICHARG,JCHARG)
     *                +TINAVR(1,3,0,2,ICHARG,JCHARG))
     *
     *               +(TINAVR(1,2,3,0,ICHARG,JCHARG)
     *                +TINAVR(1,2,0,3,ICHARG,JCHARG))
     *               -(TINAVR(2,1,3,0,ICHARG,JCHARG)
     *                +TINAVR(2,1,0,3,ICHARG,JCHARG))
C
                   END DO
                END DO
C
C=======================================================================
C               THE IMAGINARY UNIT BELOW COMES FROM THAT IN EQ. (115)
C               OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
                HREGSE(INREGA,:,:)=UNIT_I*HREGSE(INREGA,:,:)
C
            END IF
C
C=======================================================================
C           FINITE-RANGE ODD TENSOR, SEE EQ. (117)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
            IF (I_FSTA(2).GE.1.AND.INREGA.EQ.2) THEN
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      DO KARTEL=1,NDKART
                         DO KARTEP=1,NDKART
C
                      HREGSE(INREGA,ICHARG,JCHARG)=
     *                HREGSE(INREGA,ICHARG,JCHARG)
     *
     *              +(TINAVR(KARTEL,KARTEP,KARTEL,KARTEP,ICHARG,JCHARG)
     *               +TINAVR(KARTEL,KARTEP,KARTEP,KARTEL,ICHARG,JCHARG))
     *                                                          *3.0D0/2
     *               -TINAVR(KARTEL,KARTEL,KARTEP,KARTEP,ICHARG,JCHARG)
C
                        END DO
                     END DO
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           FINITE-RANGE EVEN TENSOR BOTH TERMS, SEE EQ. (116)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
            IF (I_FSTA(3).GE.1.AND.(INREGA.EQ.3.OR.INREGA.EQ.4)) THEN
C
C=======================================================================
C               HERE WE SYMMETRIZE  ARRAY  "TINAVR"  BY  COMPLETING  THE
C               ELEMENTS THAT WERE NOT CALCULATED IN "GAUENE".
C
                TINAVR(2,1,:,:,:,:)=TINAVR(1,2,:,:,:,:)
                TINAVR(3,1,:,:,:,:)=TINAVR(1,3,:,:,:,:)
                TINAVR(3,2,:,:,:,:)=TINAVR(2,3,:,:,:,:)
C
C=======================================================================
C               THE FLIPPED SIGN BELOW COMES FROM TWO IMAGINARY UNITS BY
C               WHICH THE TWO RELATIVE LINEAR MOMENTA, k OR k'*,  DIFFER
C               FROM THE  DERIVATIVES  OVER  THE  RELATIVE  COORDINATES,
C               r OR r',  RESPECTIVELY,  SEE  BELOW  EQS.  (3)  AND  (4)
C               OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      DO KARTEL=1,NDKART
                         DO KARTEP=1,NDKART
C
                      HREGSE(INREGA,ICHARG,JCHARG)=
     *                HREGSE(INREGA,ICHARG,JCHARG)
     *
     *              -(TINAVR(KARTEL,KARTEP,KARTEL,KARTEP,ICHARG,JCHARG)
     *               +TINAVR(KARTEL,KARTEP,KARTEP,KARTEL,ICHARG,JCHARG))
     *                                                          *3.0D0/4
     *               +TINAVR(KARTEL,KARTEL,KARTEP,KARTEP,ICHARG,JCHARG)
     *                                                                /2
C
                        END DO
                     END DO
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           CALCULATING THE SUM OF ALL EXCHANGE TERMS
C=======================================================================
C           FACTORS 1/2 BELOW CORRESPOND TO THE OVERALL FACTOR OF THE
C           TWO-BODY ENERGY RELATED TO THE ANTISYMMETRISATION  OF THE
C           INTERACTION
C=======================================================================
C
            DO ICHARG=0,NDISOS
               DO JCHARG=0,NDISOS
C
                  IF (INREGA.EQ.1)
     *            EFSOSE=EFSOSE+FSO_SE(INGOGA,ICHARG,JCHARG)
     *                         *HREGSE(INREGA,ICHARG,JCHARG)/2
C
                  IF (INREGA.EQ.2)
     *            EFTOSE=EFTOSE+FTO_SE(INGOGA,ICHARG,JCHARG)
     *                         *HREGSE(INREGA,ICHARG,JCHARG)/2
C
                  IF (INREGA.EQ.3.OR.INREGA.EQ.4)
     *            EFTESE=EFTESE+FTE_SE(INGOGA,ICHARG,JCHARG)
     *                         *HREGSE(INREGA,ICHARG,JCHARG)/2
C
C=======================================================================
C
                  IF (INREGA.EQ.1)
     *            EFSTSE(1,ICHARG,JCHARG)=EFSTSE(1,ICHARG,JCHARG)
     *                         +FSO_SE(INGOGA,ICHARG,JCHARG)
     *                         *HREGSE(INREGA,ICHARG,JCHARG)/2
C
                  IF (INREGA.EQ.2)
     *            EFSTSE(2,ICHARG,JCHARG)=EFSTSE(2,ICHARG,JCHARG)
     *                         +FTO_SE(INGOGA,ICHARG,JCHARG)
     *                         *HREGSE(INREGA,ICHARG,JCHARG)/2
C
                  IF (INREGA.EQ.3.OR.INREGA.EQ.4)
     *            EFSTSE(3,ICHARG,JCHARG)=EFSTSE(3,ICHARG,JCHARG)
     *                         +FTE_SE(INGOGA,ICHARG,JCHARG)
     *                         *HREGSE(INREGA,ICHARG,JCHARG)/2
C
               END DO
            END DO
C
C=======================================================================
C           CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
            FST_XX=0.0D0
            IFSTXX=0
C
            IF (INREGA.EQ.1.AND.(I_FSTA(1).EQ.2.OR.I_FSTA(1).EQ.3)) THEN
C
                FST_XX=FSO_SE
                IFSTXX=1
                CFSTXX=UNIT_I
C
            END IF
C
            IF (INREGA.EQ.2.AND.(I_FSTA(2).EQ.2.OR.I_FSTA(2).EQ.3)) THEN
C
                FST_XX=FTO_SE
                IFSTXX=1
                CFSTXX=CMPLX(1.0D0,0.0D0)
C
            END IF
C
            IF ((INREGA.EQ.3.OR.INREGA.EQ.4).AND.
     *                          (I_FSTA(3).EQ.2.OR.I_FSTA(3).EQ.3)) THEN
C
                FST_XX=FTE_SE
                IFSTXX=1
                CFSTXX=CMPLX(1.0D0,0.0D0)
C
            END IF
C
            IF (IFSTXX.GE.1) THEN
C
                DO ICHARG=0,NDISOS
C
                   DO IKET=1,LDBASE
                      DO IBRA=1,LDBASE
C
                         KARTEZ=0
C
                         FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  +FST_XX(INGOGA,ICHARG,ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                                    *CFSTXX*XNEWEV
     *
     *                  +FST_XX(INGOGA,ICHARG,1-ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                    *CFSTXX*XNEWEV
C
                        DO KARTEZ=1,NDKART
C
                           FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *                    =FSTASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                        +FST_XX(INGOGA,ICHARG,ICHARG)
     *                        *GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                                    *CFSTXX*XNEWEV
     *
     *                        +FST_XX(INGOGA,ICHARG,1-ICHARG)
     *                        *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                    *CFSTXX*XNEWEV
C
                        END DO
C
                      END DO
                   END DO
C
                END DO
C
                ISFSTA=1
C
            END IF
C
         END DO ! INREGA=1,MUFSTA
C
 5672    CONTINUE
C
C=======================================================================
C        CALCULATING THE PAIRING TERMS UNLESS MAXVAL(IFSTPA).LT.1
C=======================================================================
C
         IF (MAXVAL(IFSTPA).LT.1) GO TO 5673
C
C=======================================================================
C        HERE WE PUT THE  PARTICLE-PARTICLE  MATRIX  ELEMENTS  INTO  THE
C        PARTICLE-HOLE LOCATIONS, SO AS  THE  SAME  SUBROUTINE  "GAUENE"
C        CAN BE USED TO EVALUATE THE PAIRING TERM. NOTE THAT  THIS  MUST
C        BE DONE  A_F_T_E_R  CALCULATING THE EXCHANGE MATRIX ELEMENTS BY
C        CALLING "EXCGOG" ABOVE
C=======================================================================
C
         CALL PAIGOG(NXMAXX,
     *               FSTX00,FSTX01,FSTX10,FSTX02,FSTX11,FSTX20,
     *                             GAUX22,GAUX41,GAUX42,GAUX43)
         CALL PAIGOG(NYMAXX,
     *               FSTY00,FSTY01,FSTY10,FSTY02,FSTY11,FSTY20,
     *                             GAUY22,GAUY41,GAUY42,GAUY43)
         CALL PAIGOG(NZMAXX,
     *               FSTZ00,FSTZ01,FSTZ10,FSTZ02,FSTZ11,FSTZ20,
     *                             GAUZ22,GAUZ41,GAUZ42,GAUZ43)
C
         IDENSI=1
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS  THAT  CONSTITUTE  THE  FINITE-
C        RANGE SPIN-ORBIT AND TENSOR FORCE
C=======================================================================
C
         DO INREGA=1,MUFSTA
C
            HREGSP(INREGA,:,:)=C_ZERO
C
            I_PART=-1
C
            IF (IFSTPA(1).GE.1.AND.INREGA.EQ.1) I_PART=13
            IF (IFSTPA(2).GE.1.AND.INREGA.EQ.2) I_PART=14
            IF (IFSTPA(3).GE.1.AND.INREGA.EQ.3) I_PART=15
            IF (IFSTPA(3).GE.1.AND.INREGA.EQ.4) I_PART=16
C
            J_FSTA=1
C
            IF (IFSTPA(1).EQ.2.AND.INREGA.EQ.1.OR.
     *          IFSTPA(2).EQ.2.AND.INREGA.EQ.2.OR.
     *          IFSTPA(3).EQ.2.AND.INREGA.EQ.3.OR.
     *          IFSTPA(3).EQ.2.AND.INREGA.EQ.4)    J_FSTA=2
C
            IF (IFSTPA(1).GE.1.AND.INREGA.EQ.1.OR.
     *          IFSTPA(2).GE.1.AND.INREGA.EQ.2.OR.
     *          IFSTPA(3).GE.1.AND.INREGA.EQ.3.OR.
     *          IFSTPA(3).GE.1.AND.INREGA.EQ.4)    THEN
C
                IF (IDIQGA.EQ.1) THEN
C
C=======================================================================
C        DIAGONALIZE THE GAUSSIAN FORMFACTORS AND EVALUATE THE
C        CORRESPONDING ENERGIES AND FIELDS USING THE DIAGONAL
C        APPROXIMATION
C=======================================================================
C
                    CALL DEFDIQ(NXMAXX,FSTX00,GAXEIG,GAXVEC,GAXVEI,
     *                                        KXDDIQ,LXDDIQ,NXDDIQ)
C
                    CALL DEFDIQ(NYMAXX,FSTY00,GAYEIG,GAYVEC,GAYVEI,
     *                                        KYDDIQ,LYDDIQ,NYDDIQ)
C
                    CALL DEFDIQ(NZMAXX,FSTZ00,GAZEIG,GAZVEC,GAZVEI,
     *                                        KZDDIQ,LZDDIQ,NZDDIQ)
C
                    CALL GAUDIQ(ISIMPY,J_FSTA,I_PART,IDENSI,DIQCOP)
C
                ELSE
C
                    CALL GAUENE(ISIMPY,J_FSTA,I_PART,IDENSI,1,1)
C
                END IF
C
            END IF
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE PAIRING TERM
C=======================================================================
C
C=======================================================================
C           FINITE-RANGE SPIN-ORBIT, SEE EQ. (115)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112 AND
C           EQ. (65c) IN PERLINSKA ET AL., WHERE THE FACTOR OF (-i)
C           CANCELS THE FACTOR OF (i) FROM THE SPIN-ORBIT FORCE
C=======================================================================
C
            IF (IFSTPA(1).GE.1.AND.INREGA.EQ.1) THEN
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      HREGSP(INREGA,ICHARG,JCHARG)=
     *                HREGSP(INREGA,ICHARG,JCHARG)
     *
     *               +(TINAVR(2,3,2,3,ICHARG,JCHARG)
     *                +TINAVR(3,2,3,2,ICHARG,JCHARG))
     *               -(TINAVR(2,3,3,2,ICHARG,JCHARG)
     *                +TINAVR(3,2,2,3,ICHARG,JCHARG))
     *
     *               +(TINAVR(3,1,3,1,ICHARG,JCHARG)
     *                +TINAVR(1,3,1,3,ICHARG,JCHARG))
     *               -(TINAVR(3,1,1,3,ICHARG,JCHARG)
     *                +TINAVR(1,3,3,1,ICHARG,JCHARG))
     *
     *               +(TINAVR(1,2,1,2,ICHARG,JCHARG)
     *                +TINAVR(2,1,2,1,ICHARG,JCHARG))
     *               -(TINAVR(1,2,2,1,ICHARG,JCHARG)
     *                +TINAVR(2,1,1,2,ICHARG,JCHARG))
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           FINITE-RANGE ODD TENSOR, SEE EQ. (117)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112 AND
C           EQ. (65d) IN PERLINSKA ET AL., WHERE THE FACTOR OF (-1)
C           FLIPS THE SIGN OF THE STANDARD TENSOR OPERATOR S12
C=======================================================================
C
            IF (I_FSTA(2).GE.1.AND.INREGA.EQ.2) THEN
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      DO KARTEL=1,NDKART
                         DO KARTEP=1,NDKART
C
                      HREGSP(INREGA,ICHARG,JCHARG)=
     *                HREGSP(INREGA,ICHARG,JCHARG)
     *
     *              -(TINAVR(KARTEL,KARTEP,KARTEL,KARTEP,ICHARG,JCHARG)
     *               +TINAVR(KARTEL,KARTEP,KARTEP,KARTEL,ICHARG,JCHARG))
     *                                                          *3.0D0/2
     *               +TINAVR(KARTEL,KARTEL,KARTEP,KARTEP,ICHARG,JCHARG)
C
                        END DO
                     END DO
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           FINITE-RANGE EVEN TENSOR BOTH TERMS, SEE EQ. (116)
C           OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112 AND
C           EQ. (65d) IN PERLINSKA ET AL., WHERE THE FACTOR OF (-1)
C           FLIPS THE SIGN OF THE STANDARD TENSOR OPERATOR S12
C=======================================================================
C
            IF (I_FSTA(3).GE.1.AND.(INREGA.EQ.3.OR.INREGA.EQ.4)) THEN
C
C=======================================================================
C               HERE WE SYMMETRIZE  ARRAY  "TINAVR"  BY  COMPLETING  THE
C               ELEMENTS THAT WERE NOT CALCULATED IN "GAUENE".
C
                TINAVR(2,1,:,:,:,:)=TINAVR(1,2,:,:,:,:)
                TINAVR(3,1,:,:,:,:)=TINAVR(1,3,:,:,:,:)
                TINAVR(3,2,:,:,:,:)=TINAVR(2,3,:,:,:,:)
C
C=======================================================================
C               THE FLIPPED SIGN BELOW COMES FROM TWO IMAGINARY UNITS BY
C               WHICH THE TWO RELATIVE LINEAR MOMENTA, k OR k'*,  DIFFER
C               FROM THE  DERIVATIVES  OVER  THE  RELATIVE  COORDINATES,
C               r OR r',  RESPECTIVELY,  SEE  BELOW  EQS.  (3)  AND  (4)
C               OF J. Phys. G: Nucl. Part. Phys. 41 (2014) 055112
C=======================================================================
C
                DO ICHARG=0,NDISOS
                   DO JCHARG=0,NDISOS
C
                      DO KARTEL=1,NDKART
                         DO KARTEP=1,NDKART
C
                      HREGSP(INREGA,ICHARG,JCHARG)=
     *                HREGSP(INREGA,ICHARG,JCHARG)
     *
     *              +(TINAVR(KARTEL,KARTEP,KARTEL,KARTEP,ICHARG,JCHARG)
     *               +TINAVR(KARTEL,KARTEP,KARTEP,KARTEL,ICHARG,JCHARG))
     *                                                          *3.0D0/4
     *               -TINAVR(KARTEL,KARTEL,KARTEP,KARTEP,ICHARG,JCHARG)
     *                                                                /2
C
                        END DO
                     END DO
C
                   END DO
                END DO
C
            END IF
C
C=======================================================================
C           CALCULATING THE SUM OF ALL PAIRING TERMS
C=======================================================================
C
            DO ICHARG=0,NDISOS
C
               IF (INREGA.EQ.1)
     *             EFSOSP(ICHARG)=EFSOSP(ICHARG)
     *            +FSO_SP(INGOGA,ICHARG,ICHARG)
     *            *HREGSP(INREGA,ICHARG,ICHARG)
C
               IF (INREGA.EQ.2)
     *             EFTOSP(ICHARG)=EFTOSP(ICHARG)
     *            +FTO_SP(INGOGA,ICHARG,ICHARG)
     *            *HREGSP(INREGA,ICHARG,ICHARG)
C
               IF (INREGA.EQ.3.OR.INREGA.EQ.4)
     *             EFTESP(ICHARG)=EFTESP(ICHARG)
     *            +FTE_SP(INGOGA,ICHARG,ICHARG)
     *            *HREGSP(INREGA,ICHARG,ICHARG)
C
            END DO
C
C=======================================================================
C           CALCULATING THE MEAN FIELDS OF THE PAIRING TERM
C=======================================================================
C
            FST_XX=0.0D0
            IFSTXX=0
C
            IF (INREGA.EQ.1.AND.IFSTPA(1).EQ.2) THEN
C
                FST_XX=FSO_SP
                IFSTXX=1
                CFSTXX=CMPLX(1.0D0,0.0D0)
C
            END IF
C
            IF (INREGA.EQ.2.AND.IFSTPA(2).EQ.2) THEN
C
                FST_XX=FTO_SP
                IFSTXX=1
                CFSTXX=CMPLX(-1.0D0,0.0D0)
C
            END IF
C
            IF ((INREGA.EQ.3.OR.INREGA.EQ.4).AND.IFSTPA(3).EQ.2) THEN
C
                FST_XX=FTE_SP
                IFSTXX=1
                CFSTXX=CMPLX(-1.0D0,0.0D0)
C
            END IF
C
            IF (IFSTXX.GE.1) THEN
C
                DO ICHARG=0,NDISOS
C
                   DO IKET=1,LDBASE
                      DO IBRA=1,LDBASE
C
                         KARTEZ=0
C
                         FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  +FST_XX(INGOGA,ICHARG,ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                                    *CFSTXX*XNEWEV
     *
     *                  +FST_XX(INGOGA,ICHARG,1-ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                    *CFSTXX*XNEWEV
C
                        DO KARTEZ=1,NDKART
C
                           FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                    =FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                        +FST_XX(INGOGA,ICHARG,ICHARG)
     *                        *GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                                    *CFSTXX*XNEWEV
     *
     *                        +FST_XX(INGOGA,ICHARG,1-ICHARG)
     *                        *GAUFIL(0,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                    *CFSTXX*XNEWEV
C
                        END DO
C
                      END DO
                   END DO
C
                END DO
C
                ISFSTP=1
C
            END IF
C
         END DO ! INREGA=1,MUFSTA
C
C=======================================================================
C           END CALCULATING THE PAIRING TERM
C=======================================================================
C
 5673    CONTINUE
C
C=======================================================================
C        HERE  ENDS  THE LOOP OVER DIFFERENT GAUSSIANS
C=======================================================================
C
      END DO
C
      EFSODT=REAL(EFSOSD)
      EFSOET=REAL(EFSOSE)
      EFTODT=REAL(EFTOSD)
      EFTOET=REAL(EFTOSE)
      EFTEDT=REAL(EFTESD)
      EFTEET=REAL(EFTESE)
C
      EKEFSO=EFSOSD+EFSOSE
      EKEFTO=EFTOSD+EFTOSE
      EKEFTE=EFTESD+EFTESE
C
C=======================================================================
C        CALCULATING THE PAIRING GAPS OF THE FINITE RANGE SPIN-ORBIT  OR
C        TENSOR FORCE
C=======================================================================
C
      IF (MAXVAL(IFSTPA).GE.2) THEN
C
          ALLOCATE(HPAIMP(1:NDBASE,1:NDBASE))
          ALLOCATE(HPAIPM(1:NDBASE,1:NDBASE))
C
          IF (ISIMPY.NE.1) THEN
C
              ALLOCATE(HPAIPP(1:NDBASE,1:NDBASE))
              ALLOCATE(HPAIMM(1:NDBASE,1:NDBASE))
C
          END IF
C
          DO ICHARG=0,NDISOS
C
             DELTAY=C_ZERO
C
             DO KARTEZ=0,NDKART
C
                DO IKET=1,LDBASE
                   NPY=NYVECT(IKET,1)
                   DO IBRA=1,LDBASE
                      MPY=NYVECT(IBRA,1)
C
                      HPAIMP(IBRA,IKET)=FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAMP(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      HPAIPM(IBRA,IKET)=FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAPM(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
C
                      IF (ISIMPY.NE.1) THEN
C
                      HPAIPP(IBRA,IKET)=FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAPP(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      HPAIMM(IBRA,IKET)=FSTPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAMM(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      END IF
C
                   END DO
                END DO
C
                DELTAX(KARTEZ)=C_ZERO
                EPAIRX(KARTEZ)=C_ZERO
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      DELTAX(KARTEZ)=DELTAX(KARTEZ)
     *                              +HPAIMP(IBRA,IKET)
     *                              *DEN_PP(IKET,IBRA,0,ICHARG)
     *                              -HPAIPM(IBRA,IKET)
     *                              *DEN_PP(IKET,IBRA,1,ICHARG)
                      EPAIRX(KARTEZ)=EPAIRX(KARTEZ)
     *                              +HPAIPM(IBRA,IKET)*CONJG(
     *                               CHI_PM(IBRA,IKET,0,ICHARG))/2
     *                              +HPAIMP(IBRA,IKET)*CONJG(
     *                               CHI_PM(IBRA,IKET,1,ICHARG))/2
C
                      IF (ISIMPY.NE.1) THEN
C
                      DELTAX(KARTEZ)=DELTAX(KARTEZ)
     *                              -HPAIPP(IBRA,IKET)
     *                              *DEN_PM(IKET,IBRA,0,ICHARG)
     *                              +HPAIMM(IBRA,IKET)
     *                              *DEN_PM(IKET,IBRA,1,ICHARG)
                      EPAIRX(KARTEZ)=EPAIRX(KARTEZ)
     *                              +HPAIPP(IBRA,IKET)*CONJG(
     *                               CHI_PP(IBRA,IKET,0,ICHARG))/2
     *                              +HPAIMM(IBRA,IKET)*CONJG(
     *                               CHI_PP(IBRA,IKET,1,ICHARG))/2
                      END IF
C
                   END DO
                END DO
C
C=======================================================================
C             ATTENTION! THE CHANGES OF SIGN BELOW ARE NOT BASED ON  ANY
C                        DERIVATION, BUT THEY RESULT FROM THE COMPARISON
C                        WITH FINRES4 TESTS BY KARIM BENNACEUR.
C                        THEY HAVE BEEN INTRODUCED IN VERSION (2.79D) ON
C                        12.04.2017.
C=======================================================================
C             ATTENTION! DEFINITION OF THE  PAIRING  GAP  BELOW  IMPLIES
C                        DEPENDENCE   ON   THE   GAUGE   TRANSFORMATION.
C                        THEREFORE, ONLY  ITS  ABSOLUTE  VALUE  MATTERS.
C                        THIS HAS BEEN IMPLEMENTED IN VERSION (2.89B) ON
C                        12.03.2019.
C=======================================================================
C
                IF (KARTEZ.EQ.1) DELTAX(KARTEZ)=-DELTAX(KARTEZ)
                IF (KARTEZ.EQ.2) DELTAX(KARTEZ)=-DELTAX(KARTEZ)
C
                DELTAY=DELTAY             +DELTAX(KARTEZ)
                PFSTVP(KARTEZ,ICHARG)=REAL(EPAIRX(KARTEZ))
C
C     WRITE (*,'(2I3,2(4X,2D15.7))') ICHARG,KARTEZ,
C    *                               DELTAX(KARTEZ),EPAIRX(KARTEZ)
C
             END DO
C
             IF (ICHARG.EQ.0) DELTAN=DELTAN+ABS(DELTAY)/IN_FIX
             IF (ICHARG.EQ.1) DELTAP=DELTAP+ABS(DELTAY)/IZ_FIX
C
          END DO
C
                           DEALLOCATE(HPAIMP,HPAIPM)
          IF (ISIMPY.NE.1) DEALLOCATE(HPAIPP,HPAIMM)
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('FSTENE',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ADD2BC(ISIMPY)
C=======================================================================
      USE TBCSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDOSC2=(NDOSCI+1)*(NDOSCI+1))
      PARAMETER (NDF2BC=5,NDG2BC=7)
C=======================================================================
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          A2BCIN,A2BCSA
      COMPLEX
     *          EIN2BC,ESA2BC,EFO2BC
C
      DIMENSION
     *          EIN2BC(1:NDF2BC,0:NDKART,0:NDKART,0:NDKART,0:NDKART,
     *                                            0:NDISOS,0:NDISOS)
      DIMENSION
     *          ESA2BC(1:NDF2BC,0:NDKART,0:NDKART,0:NDKART,0:NDKART,
     *                          0:NDKART,0:NDKART,0:NDISOS,0:NDISOS)
      DIMENSION
     *          NGO2BC(1:NDF2BC),CCF2BC(1:NDF2BC)
      DIMENSION
     *          GAUWID(1:NDF2BC,1:NDG2BC),GAUSTR(1:NDF2BC,1:NDG2BC)
      COMPLEX
     *          GAXVEC,GAYVEC,GAZVEC,
     *          GAXVEI,GAYVEI,GAZVEI
C=======================================================================
C        ATTENTION: ARRAYS TBC?4? BELOW ARE DUMMY ARRAYS KEPT  ONLY  FOR
C                   COMPATIBILITY WITH THE COMMON "GAUSIN".
C=======================================================================
      COMMON
     *       /TBCSIN/ TBC0X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC0X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC0X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC0X3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Y3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Z3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC1X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC1X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC1X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBCX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBCX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBCX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /GA_DIQ/ GAXEIG(NDOSC2),GAYEIG(NDOSC2),GAZEIG(NDOSC2),
     *
     *                GAXVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAYVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAZVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *
     *                GAXVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAYVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAZVEI(NDOSC2,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /MNDDIQ/ KXDDIQ(0:NDOSCI,0:NDOSCI),LXDDIQ(NDOSC2,2),NXDDIQ,
     *                KYDDIQ(0:NDOSCI,0:NDOSCI),LYDDIQ(NDOSC2,2),NYDDIQ,
     *                KZDDIQ(0:NDOSCI,0:NDOSCI),LZDDIQ(NDOSC2,2),NZDDIQ
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /A2BCTI/ A2BCIN(-1:+1),A2BCSA(-1:+1)
      COMMON
     *       /E2BCTI/ EFO2BC(1:NDF2BC,1:NDKART)
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
      COMMON
     *       /PHYPIO/ PIMASS,G_AXIC,PIDECA
      COMMON
     *       /DIQ_GA/ DIQCOD,DIQCOE,DIQCOP,IDIQGA
      COMMON
     *       /FOR2BC/ MAG2BC(NDF2BC)
      COMMON
     *       /GEF2BC/ GIN2BC,GSA2BC,IGY2BC
      COMMON
     *       /MAGUNI/ AUNITS(0:NDMULT,0:NDMULT)
C
C=======================================================================
C        HERE WE DEFINE THE COEFFICENTS AND WIDTHS OF THE  EXPANSIONS OF
C        THE SPATIAL FORMFACTORS INTO GAUSSIANS.
C=======================================================================
C        ATTENTION: STARTING FROM VERSION (3.28D) THE CODE USES SCALABLE
C                   DEFINITIONS OF FORMFACTRS, SEE BELOW.
C=======================================================================
C        ATTENTION: STARTING FROM VERSION (3.31A) THE CODE USES THE  NEW
C                   PARAMETERS OF FORMFACTRS, SEE THE HERLIK'S EMAIL  OF
C                   25/11/2024, 16:09
C=======================================================================
C        ATTENTION: STARTING FROM VERSION (3.32K) THE CODE USES THE  NEW
C                   PARAMETERS OF FORMFACTOR FF2, SEE THE HERLIK'S EMAIL
C                   OF 26/01/2025, 13:24
C=======================================================================
C
      DATA
     *      ((GAUSTR(IFO2BC,IGO2BC),GAUWID(IFO2BC,IGO2BC),
     *                                 IGO2BC=1,NDG2BC),IFO2BC=1,NDF2BC)
     *
     *       /0.120000D+0, 0.146100D+1,
     *        0.012600D+0, 0.415700D+1,
     *        0.328000D+0, 0.907000D+0,
     *        0.077000D+0, 0.285000D+1,
     *        0.165000D+0, 0.194400D+1,
     *        0.000000D+0, 0.000000D+0,
     *        0.000000D+0, 0.000000D+0,
*
     *        0.138016D+3, 0.232000D+0,
     *        0.008000D+0, 0.277400D+1,
     *        0.134790D+2, 0.500000D+0,
     *        0.151092D+4, 0.106000D+0,
     *        0.212444D+5, 0.046000D+0,
     *        0.109000D+0, 0.169800D+1,
     *        0.990000D+0, 0.101100D+1,
     *
     *        0.122072D+1, 0.510763D+0,
     *        0.457913D+1, 0.239530D+0,
     *        0.022711D+0, 0.299413D+1,
     *        0.184528D+0, 0.170489D+1,
     *        0.610362D+0, 0.929940D+0,
     *        0.000000D+0, 0.000000D+0,
     *        0.000000D+0, 0.000000D+0,
     *
     *        0.372693D+3, 0.357000D+0,
     *        0.572086D+5, 0.134000D+0,
     *        0.134932D+7, 0.074000D+0,
     *        0.780000D+0, 0.125200D+1,
     *        0.250020D+2, 0.635000D+0,
     *        0.303417D+4, 0.232000D+0,
     *        0.000000D+0, 0.000000D+0,
     *
     *        0.067000D+0, 0.260500D+1,
     *        0.614500D+1, 0.875000D+0,
     *        0.503900D+2, 0.457000D+0,
     *        0.463449D+3, 0.219000D+0,
     *        0.003000D+0, 0.401500D+1,
     *        0.710000D+0, 0.159200D+1,
     *        0.000000D+0, 0.000000D+0/
C
C=======================================================================
C
      CALL CPUTIM('ADD2BC',1)
C
C=======================================================================
C
      IF (NDF2BC.NE.5) STOP 'NDF2BC=5 REQUIRED FOR THE DATA IN ADD2BC'
      IF (NDG2BC.NE.7) STOP 'NDG2BC=7 REQUIRED FOR THE DATA IN ADD2BC'
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      PI=4.0D0*ATAN(1.0D0)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE AVERAGE VALUES OF THE  TWO-BODY-
C        CURRENT CONTRIBUTIONS TO MAGNETIC MOMENTS. THE FIVE  TERMS  FOR
C        IFO2BC=1,2 AND IFO2BC=3,4,5 CORRESPOND  TO  THE  INTRINSIC  AND
C        SACHS TERMS, RESPECTIVELY,  ENUMERATED  ACCORDNG  TO  THE  FIVE
C        SPATIAL FORMFACTORS:
C
C        F1(r) =                   exp(-mr)
C        F2(r) =          (1+1/mr)*exp(-mr)/r^2
C        F3(r) =                   exp(-mr)/r
C        F4(r) = (1+3/mr+3/m^2r^2)*exp(-mr)/r^3
C        F5(r) = (1+3/mr+3/m^2r^2)*exp(-mr)/r
C
C        WHERE m IS THE PION MASS, SEE EQS. (175)-(178) IN THE NOTES:
C        Herlik.240131a.Meson_exchange_currents(310124).pdf
C=======================================================================
C        ATTENTION: STARTING FROM VERSION (3.28D) THE CODE USES SCALABLE
C                   DEFINITIONS OF FORMFACTRS:
C
C        F1(u) =               exp(-u)
C        F2(u) =       (1+1/u)*exp(-u)/u^2
C        F3(u) =               exp(-u)/u
C        F4(u) = (1+3/u+3/u^2)*exp(-u)/u^3
C        F5(u) = (1+3/u+3/u^2)*exp(-u)/u
C
C        THEREFORE, THE FORMFACTORS MUST BE USED  FOR  u=mr  ALONG  WITH
C        MULTIPLICATIONS BY THE CORRESPONDING POWERS  OF  m  DEFINED  IN
C        ARRAY "CCF2BC".
C
C        THE SCALABLE FORMFACTORS ARE EXPANDED ON GAUSSIANS THAT  DEPEND
C        ON DIMENSIONLESS VARIABLE u  AND  ON  DIMENSIONLESS  PARAMETERS
C        GAUSTR(I,J) AND GAUWID(I,J), SUCH THAT:
C
C        FI(u)=SUM_J GAUSTR(I,J)*EXP(-u^2/GAUWID(I,J)^2)
C
C        THUS THE GAUSSIANS MUST BE USED FOR:
C
C        GAUWI0=GAUWID(I,J)/PIMASS
C
C=======================================================================
C
      NFO2BC=NDF2BC
C
C=======================================================================
C        DEFINING THE COUPLING CONSTANTS
C=======================================================================
C
C        16/08/2024 - FACTOR OF 2 INCLUDED TO ACCOUNT FOR TWO  DIFFERENT
C                     TERMS BEING SUMMED UP IN  THE  ISOSPIN  STRUCTURE.
C        23/08/2024 - THE NUCLEAR MAGNETON IN  FERMI  IS  CALCULATED  AS
C                     XMIU_N = e*hbar*c/(2*M_N*c^2)
C        16/08/2024 - FACTOR OF 1/2 INCLUDED TO ACCOUNT FOR THE  GENERAL
C                     FACTOR IN THE DEFINITION OF THE AVERAGE VALUE OF A
C                     TWO-BODY OPERATOR.
C        17/11/2024 - ATTENTION:
C                     AFTER A LONG PERIOD OF TESTING, THE DIFFERENCE  IN
C                     SIGN BETWEEN THE HFODD AND HFBTEMP IMPLEMENTATIONS
C                     HAS NOT BEEN RESOLVED AND AWAITS  SOLUTION.  SINCE
C                     THE SIGN IMPLEMENTED  IN  HFBTEMP  APPEARS  TO  BE
C                     CORRECT, IN "I2BCSI" BELOW WE IMPLEMENT AN  AD-HOC
C                     SIGN CHANGE.
C
      I2BCSI=-1
C
      XMIU_N = H_BARC/(2*XMASSN)
C
C        THE COUPLING CONSTANT OF THE INTRINSIC TERM
C
      CCI2BC = G_AXIC**2 * PIMASS    * 2 /(4*PIDECA**2)/( 8*PI)/XMIU_N/2
     *       * I2BCSI
C
C        THE COUPLING CONSTANT OF THE SACHS TERM
C
      CCS2BC = G_AXIC**2 * PIMASS**2 * 2 /(4*PIDECA**2)/(24*PI)/XMIU_N/2
     *       * I2BCSI
C
C=======================================================================
C
      CCF2BC(1)=1
      CCF2BC(2)=PIMASS**2
      CCF2BC(3)=PIMASS
      CCF2BC(4)=PIMASS**3
      CCF2BC(5)=PIMASS
C
C=======================================================================
C        DEFINE THE ARRAY WITH THE NUMBER OF GAUSSIANS FOR EACH FORM
C        FACTOR
C=======================================================================
C
      NGO2BC(1)=5
      NGO2BC(2)=7
      NGO2BC(3)=5
      NGO2BC(4)=6
      NGO2BC(5)=6
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER FORM FACTORS
C=======================================================================
C
      DO IFO2BC=1,NFO2BC
C
C=======================================================================
C        ZEROING THE ARRAYS THAT WILL COLLECT THE CONTRIBUTIONS COMING
C        FROM INDIVIDUAL GAUSSIANS
C=======================================================================
C
         EIN2BC(IFO2BC,:,:,:,:,:,:)    =C_ZERO
         ESA2BC(IFO2BC,:,:,:,:,:,:,:,:)=C_ZERO
C
C=======================================================================
C        HERE WE ASSUME THAT THE FORMFACTORS 1-2 BELONG TO THE INTRINSIC
C        PART OF THE 2BC OPERATOR AND THOSE FOR 3-5 TO THE SACHS PART
C=======================================================================
C
         IF (IFO2BC.LE.2) I_PART=11
         IF (IFO2BC.GT.2) I_PART=12
C
C=======================================================================
C        HERE STARTS THE LOOP OVER DIFFERENT GAUSSIANS
C=======================================================================
C
         DO IGO2BC=1,NGO2BC(IFO2BC)
C
            IF (MAG2BC(IFO2BC).EQ.1) THEN
C
C=======================================================================
C           CALCULATING THE EXCHANGE MATRIX ELEMENTS OF THE  FORMFACTOR.
C
C           THE NAMES OF ARRAYS CONTANING THE FORMFACTORS ARE DEFINED AS
C           "TBCMKN", WHERE:
C           M = THE POWER 0 OR 1 OF THE CENTER-OF-MASS COORDINATE NEEDED
C               FOR THE INTRINSIC OR SACHS TERM, RESPECTIVELY
C           K = THE CARTESIAN DIRECTION X, Y, OR Z
C           N = THE POWER 0,1,2 OF THE RELATIVE  COORDINATE  NEEDED  FOR
C               THE INTRINSIC TERM (M=0) OR 0,1,2,3 NEEDED FOR THE SACHS
C               TERM (M=1)
C=======================================================================
C
                GAUWI0=GAUWID(IFO2BC,IGO2BC)/PIMASS
C
                NXMAXX=NXMAXV(1)
                NYMAXX=NYMAXV(1)
                NZMAXX=NZMAXV(1)
C
                CALL DEF2BC(NXMAXX,NXHERM,1,GAUWI0,
     *                 TBC0X0,TBC0X1,TBC0X2,TBC0X3,TBC1X0,TBC1X1,TBC1X2)
                CALL DEF2BC(NYMAXX,NYHERM,2,GAUWI0,
     *                 TBC0Y0,TBC0Y1,TBC0Y2,TBC0Y3,TBC1Y0,TBC1Y1,TBC1Y2)
                CALL DEF2BC(NZMAXX,NZHERM,3,GAUWI0,
     *                 TBC0Z0,TBC0Z1,TBC0Z2,TBC0Z3,TBC1Z0,TBC1Z1,TBC1Z2)
C
                CALL EXCGOG(NXMAXX,
     *                 TBC0X0,TBC0X1,TBC0X2,TBC0X3,TBC1X0,TBC1X1,TBC1X2,
     *                                             TBCX41,TBCX42,TBCX43)
                CALL EXCGOG(NYMAXX,
     *                 TBC0Y0,TBC0Y1,TBC0Y2,TBC0Y3,TBC1Y0,TBC1Y1,TBC1Y2,
     *                                             TBCY41,TBCY42,TBCY43)
                CALL EXCGOG(NZMAXX,
     *                 TBC0Z0,TBC0Z1,TBC0Z2,TBC0Z3,TBC1Z0,TBC1Z1,TBC1Z2,
     *                                             TBCZ41,TBCZ42,TBCZ43)
C
C=======================================================================
C            THE SWITCH "I_2BCA" IS SET TO 1 TO REQUEST THE CALCULATION
C            OF THE AVERAGE VALUE ONLY
C=======================================================================
C
                I_2BCA=1
C
                IDENSI=0
C
                IF (IDIQGA.EQ.1) THEN
C
C=======================================================================
C            DIAGONALIZE THE GAUSSIAN FORMFACTORS AND EVALUATE THE
C            CORRESPONDING ENERGIES AND FIELDS USING THE DIAGONAL
C            APPROXIMATION
C=======================================================================
C
C                    PRINT *, 'THIS IS RELATIVE TO THE EXCHANGE X DIR'
C
                    CALL DEFDIQ(NXMAXX,TBC0X0,GAXEIG,GAXVEC,GAXVEI,
     *                                        KXDDIQ,LXDDIQ,NXDDIQ)
C
C                    PRINT *, 'THIS IS RELATIVE TO THE EXCHANGE Y DIR'
C
                    CALL DEFDIQ(NYMAXX,TBC0Y0,GAYEIG,GAYVEC,GAYVEI,
     *                                        KYDDIQ,LYDDIQ,NYDDIQ)
C
C                    PRINT *, 'THIS IS RELATIVE TO THE EXCHANGE Z DIR'
C
                    CALL DEFDIQ(NZMAXX,TBC0Z0,GAZEIG,GAZVEC,GAZVEI,
     *                                        KZDDIQ,LZDDIQ,NZDDIQ)
C
                    CALL GAUDIQ(ISIMPY,I_2BCA,I_PART,IDENSI,DIQCOE)
C
                ELSE
C
                    CALL GAUENE(ISIMPY,I_2BCA,I_PART,IDENSI,1,1)
C
                END IF
C
C=======================================================================
C           HERE THE AVERAGE VALUES OF EXCHANGE TERMS ARE SUMMED UP OVER
C           GAUSSIANS
C=======================================================================
C
                IF (IFO2BC.LE.2) THEN
C
C=======================================================================
C         INDICES OF THE EIN2BC(1,2,3,4,5,6,7) ARRAY CORRESPOND TO:
C         1: THE CONSEQUTIVE NUMBER OF THE INTRINSIC FORMFACTOR
C            (1 OR 2)
C         2: CARTESIAN COMPONENT OF THE  FIRST RELATIVE COORDINATE
C            (0,X,Y,Z)
C         3: CARTESIAN COMPONENT OF THE SECOND RELATIVE COORDINATE
C            (0,X,Y,Z)
C         4: CARTESIAN SPACE COMPONENT OF THE LEFT  DENSITY MATRIX
C            (0,X,Y,Z)
C         5: CARTESIAN SPACE COMPONENT OF THE RIGHT DENSITY MATRIX
C            (0,X,Y,Z)
C         6: CARTESIAN ISOSPIN COMPONENT OF THE LEFT  DENSITY MATRIX
C            (0,1,2,3)
C         7: CARTESIAN ISOSPIN COMPONENT OF THE RIGHT DENSITY MATRIX
C            (0,1,2,3)
C=======================================================================
C
                    EIN2BC(IFO2BC,:,:,:,:,:,:)=
     *              EIN2BC(IFO2BC,:,:,:,:,:,:)+
     *              TINAVR(       :,:,:,:,:,:)*GAUSTR(IFO2BC,IGO2BC)
     *                                        *CCF2BC(IFO2BC)*GIN2BC
C
                ELSE
C
C=======================================================================
C         INDICES OF THE ESA2BC(1,2,3,4,5,6,7,8,9) ARRAY CORRESPOND TO:
C         1: THE CONSEQUTIVE NUMBER OF THE INTRINSIC FORMFACTOR
C            (3,4, OR 5)
C         2: CARTESIAN SPACE COMPONENT OF THE CENTER-OF-MASS COORDINATE
C            (0,X,Y,Z)
C         3: CARTESIAN SPACE COMPONENT OF THE  FIRST RELATIVE COORDINATE
C            (0,X,Y,Z)
C         4: CARTESIAN SPACE COMPONENT OF THE SECOND RELATIVE COORDINATE
C            (0,X,Y,Z)
C         5: CARTESIAN SPACE COMPONENT OF THE  THIRD RELATIVE COORDINATE
C            (0,X,Y,Z)
C         6: CARTESIAN SPACE COMPONENT OF THE LEFT  DENSITY MATRIX
C            (0,X,Y,Z)
C         7: CARTESIAN SPACE COMPONENT OF THE RIGHT DENSITY MATRIX
C            (0,X,Y,Z)
C         8: CARTESIAN ISOSPIN COMPONENT OF THE LEFT  DENSITY MATRIX
C            (0,1,2,3)
C         9: CARTESIAN ISOSPIN COMPONENT OF THE RIGHT DENSITY MATRIX
C            (0,1,2,3)
C=======================================================================
C
                    ESA2BC(IFO2BC,:,:,:,:,:,:,:,:)=
     *              ESA2BC(IFO2BC,:,:,:,:,:,:,:,:)+
     *              TSAAVR(       :,:,:,:,:,:,:,:)*GAUSTR(IFO2BC,IGO2BC)
     *                                            *CCF2BC(IFO2BC)*GSA2BC
C
                END IF
C
C=======================================================================
C           END CALCULATING THE EXCHANGE TERM
C=======================================================================
C
            END IF
C
C=======================================================================
C           HERE ENDS THE LOOP OVER GAUSIANS
C=======================================================================
C
         END DO
C
C=======================================================================
C        HERE ENDS THE LOOP OVER FORMFACTORS
C=======================================================================
C
      END DO
C
C=======================================================================
C        FOR POSITIVE VALUES OF INDICES NOS. 2 AND 3, THE ARRAY "EIN2BC"
C        IS SYMMETRIC BUT IN "TINAVR" IT HAS BEEN  CALCULATED  ONLY  FOR
C        NON-DECRESING VALUES THEREOF.  THEREFORE,  HERE  THE  REMAINING
C        LOCATIONS ARE COPIED FROM THOSE THAT HAVE BEEN CALCULATED.
C=======================================================================
C
      EIN2BC(:,2,1,:,:,:,:)=EIN2BC(:,1,2,:,:,:,:)
      EIN2BC(:,3,1,:,:,:,:)=EIN2BC(:,1,3,:,:,:,:)
      EIN2BC(:,3,2,:,:,:,:)=EIN2BC(:,2,3,:,:,:,:)
C
C=======================================================================
C        FOR POSITIVE VALUES OF INDICES NOS. 4 AND 5, THE ARRAY "ESA2BC"
C        IS SYMMETRIC BUT IN "TSAAVR" IT HAS BEEN  CALCULATED  ONLY  FOR
C        NON-DECRESING VALUES THEREOF.  THEREFORE,  HERE  THE  REMAINING
C        LOCATIONS ARE COPIED FROM THOSE THAT HAVE BEEN CALCULATED.
C=======================================================================
C
      ESA2BC(:,:,:,2,1,:,:,:,:)=ESA2BC(:,:,:,1,2,:,:,:,:)
      ESA2BC(:,:,:,3,1,:,:,:,:)=ESA2BC(:,:,:,1,3,:,:,:,:)
      ESA2BC(:,:,:,3,2,:,:,:,:)=ESA2BC(:,:,:,2,3,:,:,:,:)
C
C=======================================================================
C        HERE WE SUM UP CONTRIBUTIONS FROM THE FORMFACTORS IN THE
C        EXCHANGE TERMS
C=======================================================================
C
C=======================================================================
C        THE INTRINSC FORMFACTOR NO.1
C=======================================================================
C        THE SIGN AT "CCI2BC" BELOW COMES FROM THE FOLLOWING SOURCES:
C        1) THE OVERALL SIGN OF THE INTERACTION "V=-e*..."
C        2) THE OVERALL SIGN OF THE EXCHANGE TERM "-V*P_T*P_S*P_M"
C        3) THE PRODUCT OF TWO "i" UNITS IN THE ISOSPIN "P_T=i*..." AND
C           SPIN "P_S=i*..." EXCHANGE OPERATORS IN THE EXCHANGE CHANNEL,
C           SEE EQS. (8) AND (15) IN NOTES TwoBcurrents-03.pdf 15/12/23.
C        4) THE SIGN AT THE SIGMA_1 X SIGMA_2 TERM OF THE INTRINSIC-TERM
C           OPERATOR, SEE EQ. (171) IN NOTES:
C           Herlik.240131a.Meson_exchange_currents(310124)+JD.pdf
C           OF 17/07/24.
C        ATTENTION: BEFORE VERSION (3.27T) THE SIGN WAS WRONG.
C=======================================================================
C
      EFO2BC(1,:)=C_ZERO
C
      DO KARTEZ=1,NDKART
C
         EFO2BC(1,KARTEZ)=EFO2BC(1,KARTEZ)+CCI2BC*
     *                  (+EIN2BC(1,0,0,KARTEZ,0,0,1)
     *                   -EIN2BC(1,0,0,KARTEZ,0,1,0)
     *
     *                   -EIN2BC(1,0,0,0,KARTEZ,0,1)
     *                   +EIN2BC(1,0,0,0,KARTEZ,1,0))
C
      END DO
C
C=======================================================================
C        THE INTRINSC FORMFACTOR NO.2
C=======================================================================
C        THE SIGN AT "CCI2BC" BELOW COMES FROM SOURCES 1-3 ABOVE.
C        ATTENTION: BEFORE VERSION (3.27T) THE SIGN WAS WRONG.
C=======================================================================
C
      EFO2BC(2,:)=C_ZERO
C
      DO KARTEP=1,NDKART
C
         EFO2BC(2,KARTEP)=C_ZERO
C
         DO KARTEL=1,NDKART
C
            EFO2BC(2,KARTEP)=EFO2BC(2,KARTEP)-CCI2BC*
     *                     (+EIN2BC(2,KARTEL,KARTEP,KARTEL,0,0,1)
     *                      -EIN2BC(2,KARTEL,KARTEP,KARTEL,0,1,0)
     *
     *                      -EIN2BC(2,KARTEL,KARTEP,0,KARTEL,0,1)
     *                      +EIN2BC(2,KARTEL,KARTEP,0,KARTEL,1,0))
C
         END DO
C
      END DO
C
C=======================================================================
C        THE SACHS FORMFACTOR NO.3
C=======================================================================
C        THE SIGN AT "CCS2BC" BELOW COMES FROM SOURCES 1-2 ABOVE.
C        ATTENTION: BEFORE VERSION (3.27T) THE SIGN WAS WRONG.
C=======================================================================
C        THE FACTOR IFACTO/2 COMES FROM THE SIGMA_1 * SIGMA_2 TERM IN
C        EXCHANGE CHANNEL, SEE EQ. (14) IN TwoBcurrents-03.pdf 15/12/23.
C=======================================================================
C        THE "i" COMES FROM THE ISOSPIN EXCHANGE OPERATOR "P_T=i*..." IN
C        THE EXCHANGE CHANNEL, SEE EQ. (8) IN NOTES TwoBcurrents-03.pdf.
C=======================================================================
C
      EFO2BC(3,:)=C_ZERO
C
      DO KARTEP=0,NDKART
C
         IF (KARTEP.EQ.0) IFACTO=+3
         IF (KARTEP.GT.0) IFACTO=-1
C
         EFO2BC(3,1)=EFO2BC(3,1)+CCS2BC*IFACTO*UNIT_I/2*
     *             (+ESA2BC(3,2,3,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(3,2,3,0,0,KARTEP,KARTEP,1,0)
     *
     *            -(+ESA2BC(3,3,2,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(3,3,2,0,0,KARTEP,KARTEP,1,0)))
C
         EFO2BC(3,2)=EFO2BC(3,2)+CCS2BC*IFACTO*UNIT_I/2*
     *             (+ESA2BC(3,3,1,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(3,3,1,0,0,KARTEP,KARTEP,1,0)
     *
     *            -(+ESA2BC(3,1,3,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(3,1,3,0,0,KARTEP,KARTEP,1,0)))
C
         EFO2BC(3,3)=EFO2BC(3,3)+CCS2BC*IFACTO*UNIT_I/2*
     *             (+ESA2BC(3,1,2,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(3,1,2,0,0,KARTEP,KARTEP,1,0)
     *
     *            -(+ESA2BC(3,2,1,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(3,2,1,0,0,KARTEP,KARTEP,1,0)))
C
      END DO
C
C=======================================================================
C        THE SACHS FORMFACTOR NO.4
C=======================================================================
C        THE SIGN AT "CCS2BC" BELOW COMES FROM SOURCES 1-2 ABOVE.
C        ATTENTION: BEFORE VERSION (3.27T) THE SIGN WAS WRONG.
C=======================================================================
C        THE FACTOR OF "3" BELOW COMES FROM THE SPIN TENSOR OPERATOR S12
C        SEE EQ. (167) IN NOTES:
C        Herlik.240131a.Meson_exchange_currents(310124).pdf 31/01/24.
C=======================================================================
C        THE "i" COMES FROM THE ISOSPIN EXCHANGE OPERATOR "P_T=i*..." IN
C        THE EXCHANGE CHANNEL, SEE EQ. (8) IN NOTES TwoBcurrents-03.pdf.
C=======================================================================
C        ATTENTION: ON 17/11/2024, IN VERSION (3.29I), DEFINITION OF THE
C                   SACHS TERM NO.4 HAS CHANGED BY ADDING TWO TERMS THAT
C                   NORMALLY WOULD CANCEL THE  ANALOGOUS  TERMS  IN  THE
C                   SACHS TERM NO.5,  SEE  EQS.  (612)-(618)  IN  Herlik
C                   .241022.Matrix_elements_Intrinsic_Sachs(221024).pdf.
C                   IN THIS WAY, THE DEFINITIONS  OF  BOTH  SACHS  TERMS
C                   BECAME ALIGNED WITH THOSE USED IN THE  CODE  HFBTEMP.
C=======================================================================
C
      EFO2BC(4,:)=C_ZERO
C
      DO KARTEP=1,NDKART
C
         DO KARTEL=1,NDKART
C
C           THE FIRST TERM OF S12*Psigma
C
            EFO2BC(4,1)=EFO2BC(4,1)+3*CCS2BC*UNIT_I*
     *                (+ESA2BC(4,2,3,KARTEL,KARTEP,KARTEL,KARTEP,0,1)
     *                 -ESA2BC(4,2,3,KARTEL,KARTEP,KARTEL,KARTEP,1,0)
     *
     *               -(+ESA2BC(4,3,2,KARTEL,KARTEP,KARTEL,KARTEP,0,1)
     *                 -ESA2BC(4,3,2,KARTEL,KARTEP,KARTEL,KARTEP,1,0)))
C
            EFO2BC(4,2)=EFO2BC(4,2)+3*CCS2BC*UNIT_I*
     *                (+ESA2BC(4,3,1,KARTEL,KARTEP,KARTEL,KARTEP,0,1)
     *                 -ESA2BC(4,3,1,KARTEL,KARTEP,KARTEL,KARTEP,1,0)
     *
     *               -(+ESA2BC(4,1,3,KARTEL,KARTEP,KARTEL,KARTEP,0,1)
     *                 -ESA2BC(4,1,3,KARTEL,KARTEP,KARTEL,KARTEP,1,0)))
C
            EFO2BC(4,3)=EFO2BC(4,3)+3*CCS2BC*UNIT_I*
     *                (+ESA2BC(4,1,2,KARTEL,KARTEP,KARTEL,KARTEP,0,1)
     *                 -ESA2BC(4,1,2,KARTEL,KARTEP,KARTEL,KARTEP,1,0)
     *
     *               -(+ESA2BC(4,2,1,KARTEL,KARTEP,KARTEL,KARTEP,0,1)
     *                 -ESA2BC(4,2,1,KARTEL,KARTEP,KARTEL,KARTEP,1,0)))
C
C           THE THIRD TERM OF S12*Psigma
C
            EFO2BC(4,1)=EFO2BC(4,1)-3*CCS2BC*UNIT_I/2*
     *                (+ESA2BC(4,2,3,KARTEL,KARTEL,KARTEP,KARTEP,0,1)
     *                 -ESA2BC(4,2,3,KARTEL,KARTEL,KARTEP,KARTEP,1,0)
     *
     *               -(+ESA2BC(4,3,2,KARTEL,KARTEL,KARTEP,KARTEP,0,1)
     *                 -ESA2BC(4,3,2,KARTEL,KARTEL,KARTEP,KARTEP,1,0)))
C
            EFO2BC(4,2)=EFO2BC(4,2)-3*CCS2BC*UNIT_I/2*
     *                (+ESA2BC(4,3,1,KARTEL,KARTEL,KARTEP,KARTEP,0,1)
     *                 -ESA2BC(4,3,1,KARTEL,KARTEL,KARTEP,KARTEP,1,0)
     *
     *               -(+ESA2BC(4,1,3,KARTEL,KARTEL,KARTEP,KARTEP,0,1)
     *                 -ESA2BC(4,1,3,KARTEL,KARTEL,KARTEP,KARTEP,1,0)))
C
            EFO2BC(4,3)=EFO2BC(4,3)-3*CCS2BC*UNIT_I/2*
     *                (+ESA2BC(4,1,2,KARTEL,KARTEL,KARTEP,KARTEP,0,1)
     *                 -ESA2BC(4,1,2,KARTEL,KARTEL,KARTEP,KARTEP,1,0)
     *
     *               -(+ESA2BC(4,2,1,KARTEL,KARTEL,KARTEP,KARTEP,0,1)
     *                 -ESA2BC(4,2,1,KARTEL,KARTEL,KARTEP,KARTEP,1,0)))
C
         END DO
C
C        THE SECOND TERM OF S12*Psigma
C
         EFO2BC(4,1)=EFO2BC(4,1)+3*CCS2BC*UNIT_I/2*
     *             (+ESA2BC(4,2,3,KARTEP,KARTEP,0,0,0,1)
     *              -ESA2BC(4,2,3,KARTEP,KARTEP,0,0,1,0)
     *
     *            -(+ESA2BC(4,3,2,KARTEP,KARTEP,0,0,0,1)
     *              -ESA2BC(4,3,2,KARTEP,KARTEP,0,0,1,0)))
C
         EFO2BC(4,2)=EFO2BC(4,2)+3*CCS2BC*UNIT_I/2*
     *             (+ESA2BC(4,3,1,KARTEP,KARTEP,0,0,0,1)
     *              -ESA2BC(4,3,1,KARTEP,KARTEP,0,0,1,0)
     *
     *            -(+ESA2BC(4,1,3,KARTEP,KARTEP,0,0,0,1)
     *              -ESA2BC(4,1,3,KARTEP,KARTEP,0,0,1,0)))
C
         EFO2BC(4,3)=EFO2BC(4,3)+3*CCS2BC*UNIT_I/2*
     *             (+ESA2BC(4,1,2,KARTEP,KARTEP,0,0,0,1)
     *              -ESA2BC(4,1,2,KARTEP,KARTEP,0,0,1,0)
     *
     *            -(+ESA2BC(4,2,1,KARTEP,KARTEP,0,0,0,1)
     *              -ESA2BC(4,2,1,KARTEP,KARTEP,0,0,1,0)))
C
      END DO
C
C=======================================================================
C        THE SACHS FORMFACTOR NO.5
C=======================================================================
C        THE SIGN AT "CCS2BC" BELOW COMES FROM SOURCES 1-2 ABOVE AND:
C        5) THE SIGN AT THE SIGMA_1 * SIGMA_2 TERM IN  THE  SPIN  TENSOR
C           OPERATOR S12, SEE EQ. (167) IN NOTES:
C           Herlik.240131a.Meson_exchange_currents(310124).pdf 31/01/24.
C=======================================================================
C        THE "i" COMES FROM THE ISOSPIN EXCHANGE OPERATOR "P_T=i*..." IN
C        THE EXCHANGE CHANNEL, SEE EQ. (8) IN NOTES TwoBcurrents-03.pdf.
C=======================================================================
C        ATTENTION: ON 17/11/2024, IN VERSION (3.29I), DEFINITION OF THE
C                   SACHS TERM NO.5 HAS CHANGED BY ADDING TWO TERMS THAT
C                   NORMALLY WOULD CANCEL THE  ANALOGOUS  TERMS  IN  THE
C                   SACHS TERM NO.4,  SEE  EQS.  (612)-(618)  IN  Herlik
C                   .241022.Matrix_elements_Intrinsic_Sachs(221024).pdf.
C                   IN THIS WAY, THE DEFINITIONS  OF  BOTH  SACHS  TERMS
C                   BECAME ALIGNED WITH THOSE USED IN THE  CODE  HFBTEMP.
C=======================================================================
C        ATTENTION: ON 22/01/2025, IN VERSION (3.32I), SIGNS OF TERMS IN
C                   THE LOOP OVER "KARTEP" WERE INVERTRED, SEE  HERLIK'S
C                   EMAIL OF 22/01/2025, 11:38.
C=======================================================================
C        THE FACTORS OF "1/2" AND "3/2" BELOW COME FROM THE SPIN  TENSOR
C        OPERATOR S12*Psigma,  SEE  EQS.  (616)-(617)  IN  Herlik.241022
C        .Matrix_elements_Intrinsic_Sachs(221024).pdf.
C=======================================================================
C
      EFO2BC(5,:)=C_ZERO
C
      DO KARTEP=1,NDKART
C
         EFO2BC(5,1)=EFO2BC(5,1)+CCS2BC*UNIT_I/2*
     *             (+ESA2BC(5,2,3,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(5,2,3,0,0,KARTEP,KARTEP,1,0)
     *
     *            -(+ESA2BC(5,3,2,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(5,3,2,0,0,KARTEP,KARTEP,1,0)))
C
         EFO2BC(5,2)=EFO2BC(5,2)+CCS2BC*UNIT_I/2*
     *             (+ESA2BC(5,3,1,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(5,3,1,0,0,KARTEP,KARTEP,1,0)
     *
     *            -(+ESA2BC(5,1,3,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(5,1,3,0,0,KARTEP,KARTEP,1,0)))
C
         EFO2BC(5,3)=EFO2BC(5,3)+CCS2BC*UNIT_I/2*
     *             (+ESA2BC(5,1,2,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(5,1,2,0,0,KARTEP,KARTEP,1,0)
     *
     *            -(+ESA2BC(5,2,1,0,0,KARTEP,KARTEP,0,1)
     *              -ESA2BC(5,2,1,0,0,KARTEP,KARTEP,1,0)))
C
      END DO
C
      EFO2BC(5,1)=EFO2BC(5,1)-3*CCS2BC*UNIT_I/2*
     *          (+ESA2BC(5,2,3,0,0,0,0,0,1)
     *           -ESA2BC(5,2,3,0,0,0,0,1,0)
     *
     *         -(+ESA2BC(5,3,2,0,0,0,0,0,1)
     *           -ESA2BC(5,3,2,0,0,0,0,1,0)))
C
      EFO2BC(5,2)=EFO2BC(5,2)-3*CCS2BC*UNIT_I/2*
     *          (+ESA2BC(5,3,1,0,0,0,0,0,1)
     *           -ESA2BC(5,3,1,0,0,0,0,1,0)
     *
     *         -(+ESA2BC(5,1,3,0,0,0,0,0,1)
     *           -ESA2BC(5,1,3,0,0,0,0,1,0)))
C
      EFO2BC(5,3)=EFO2BC(5,3)-3*CCS2BC*UNIT_I/2*
     *          (+ESA2BC(5,1,2,0,0,0,0,0,1)
     *           -ESA2BC(5,1,2,0,0,0,0,1,0)
     *
     *         -(+ESA2BC(5,2,1,0,0,0,0,0,1)
     *           -ESA2BC(5,2,1,0,0,0,0,1,0)))
C
C=======================================================================
C        HERE WE TRANSFORM THE RESULTS TO THE SPHERICAL-TENSOR
C        REPRESENTATION AND MULTIPLY THEM BY THE FACTORS  THAT
C        ARE INCLUDED IN THE 1B MAGNETIC MOMENT, SEE "MAGPRI".
C=======================================================================
C
      DIPNO1=SQRT(8.0D0*PI/3.0D0)/AUNITS(1,1)
      DIPNO0=SQRT(4.0D0*PI/3.0D0)/AUNITS(1,0)
C
C
C     BELOW WE USE EXPRESSIONS: A(-1)=+Y/SQ2
C                               A( 0)=+Z
C                               A(+1)=-X/SQ2
C     THOSE CORRESPOND TO THE STANDARD USED BY THE CODE  WHEN
C     STORING THE TENSOR SPHERICAL COMPONENTS.
C
      A2BCIN(-1)=+(EFO2BC(1,2)+EFO2BC(2,2))/DIPNO1
      A2BCIN( 0)= (EFO2BC(1,3)+EFO2BC(2,3))/DIPNO0
      A2BCIN(+1)=-(EFO2BC(1,1)+EFO2BC(2,1))/DIPNO1
C
      A2BCSA(-1)=+(EFO2BC(3,2)+EFO2BC(4,2)+EFO2BC(5,2))/DIPNO1
      A2BCSA( 0)= (EFO2BC(3,3)+EFO2BC(4,3)+EFO2BC(5,3))/DIPNO0
      A2BCSA(+1)=-(EFO2BC(3,1)+EFO2BC(4,1)+EFO2BC(5,1))/DIPNO1
C
C     WRITE (*,'(6E12.4)') A2BCIN
C
C=======================================================================
C
      CALL CPUTIM('ADD2BC',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SEPENE(ISSEPA,I_SEPA,SLOWPA,ISSEPP,ISEPPA,
     *                  N3SERD,ISIMPY,IN_FIX,IZ_FIX,EKESEP,
     *                                I_SLOW,SLOWEV,LDPNMX)
C
C=======================================================================
      USE GAUSTO
      USE SEPSTO
      USE SPASTO
      USE MAD_PP
      USE MAD_PM
      USE MAP_PP
      USE MAP_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *          ESEPSD,ESEPVD,ESEPSE,ESEPVE
      COMPLEX
     *          ESPTSD,ESPTVD,ESPTSE,ESPTVE,
     *          ESPSSD,ESPSVD,ESPSSE,ESPSVE,
     *          ESPPSD,ESPPVD,ESPPSE,ESPPVE,
     *          ESPMSD,ESPMVD,ESPMSE,ESPMVE
      COMPLEX
     *          ESEPSP,ESEPVP
      COMPLEX
     *          HSEGSD,HSEGVD,HSEGSE,HSEGVE
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS 2.95L AND 2.97D, VARIABLES "GSEP.."
C                   BELOW, WHICH WERE ANALOGUES OF VARIABLES "ESEP.." IN
C                   YET OLDER VERSIONS, WERE NOT  DECLARED  AS  COMPLEX.
C                   THIS BUG, OF UNKNOWN CONSEQUENCES, WAS CORRECTED  ON
C                   17/07/2020 IN VERSION (2.97E).
C=======================================================================
      COMPLEX
     *          GSEPSD,GSEPVD,GSEPSE,GSEPVE,GSEPSP,GSEPVP
      COMPLEX
     *          EKESEP
      COMPLEX
     *          C_ZERO
      COMPLEX
     *          DELTAY,DELTAX(0:NDKART),EPAIRX(0:NDKART)
      COMPLEX
     *          HPAIMP,HPAIPM,HPAIPP,HPAIMM
      COMPLEX
     *          PHACOM
C=======================================================================
      ALLOCATABLE :: HPAIMP(:,:),HPAIPM(:,:),HPAIPP(:,:),HPAIMM(:,:)
C=======================================================================
      ALLOCATABLE :: SEG_SD(:,:,:),SEG_VD(:,:,:),
     *               SEG_SE(:,:,:),SEG_VE(:,:,:),
     *               SEG_SP(:,:,:),SEG_VP(:,:,:)
C=======================================================================
      ALLOCATABLE :: HSEGSD(:,:,:),HSEGVD(:,:,:),
     *               HSEGSE(:,:,:),HSEGVE(:,:,:)
C=======================================================================
      ALLOCATABLE :: GSEPSD(:,:),GSEPSE(:,:),
     *               GSEPVD(:,:),GSEPVE(:,:)
C=======================================================================
      ALLOCATABLE :: GSEPSP(:),GSEPVP(:)
C=======================================================================
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /EN_SEP/ ESEPSD(0:NDISOS,0:NDISOS),
     *                ESEPSE(0:NDISOS,0:NDISOS),
     *                ESEPVD(0:NDISOS,0:NDISOS),
     *                ESEPVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_SOR/ ESEPOR(NDSEPA)
     *
     *       /EN_STS/ ESPTSD,ESPTSE,ESPTVD,ESPTVE,
     *                ESPSSD,ESPSSE,ESPSVD,ESPSVE
     *
     *       /EN_SPM/ ESPPSD,ESPPSE,ESPPVD,ESPPVE,
     *                ESPMSD,ESPMSE,ESPMVD,ESPMVE
      COMMON
     *       /PN_SEP/ ESEPSP(0:NDISOS),ESEPVP(0:NDISOS)
     *
     *       /PV_SEP/ PSEPVP(0:NDKART,0:NDISOS)
      COMMON
     *       /ESEPTT/ ESEPDT,ESEPET
      COMMON
     *       /PSEPTT/ ESEPPT
      COMMON
     *       /SEPPAR/ SEPWID(NDSEGA),SEPGAU(NDSEGA),NUSEGA
      COMMON
     *       /SEPVIN/ SEPVCC(NDSEPA,NDFORC),IRESEP
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /B_PHAS/ JPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('SEPENE',1)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        THIS SUBROUTINE:
C        1) FOR I_SEPA>0 CALCULATES THE AVERAGE VALUES OF THE
C           FINITE-RANGE SEPARABLE FORCE (FOR N3SERD < 0)
C        2) FOR I_SEPA=2 OR I_SEPA=3 IT CALCULATES IN ADDITION
C           THE CORRESPONDING  DIRECT  MEAN FIELDS
C        3) FOR I_SEPA=2 OR I_SEPA=4 IT CALCULATES IN ADDITION
C           THE CORRESPONDING EXCHANAGE MEAN FIELDS
C        4) FOR ISEPPA>0 CALCULATES THE AVERAGE VALUES OF THE PAIRING
C           FINITE-RANGE SEPARABLE FORCE (FOR N3SERD < 0)
C        5) FOR ISEPPA=2 IT CALCULATES IN ADDITION
C           THE CORRESPONDING PAIRING MEAN FIELDS
C=======================================================================
C
      ALLOCATE(SEG_SD(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_VD(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_SE(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_VE(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_SP(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_VP(NDSEPA,0:LDPNMX,0:LDPNMX))
C
      ALLOCATE(HSEGSD(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(HSEGVD(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(HSEGSE(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(HSEGVE(NDSEPA,0:LDPNMX,0:LDPNMX))
C
      ALLOCATE(GSEPSD(0:LDPNMX,0:LDPNMX))
      ALLOCATE(GSEPSE(0:LDPNMX,0:LDPNMX))
      ALLOCATE(GSEPVD(0:LDPNMX,0:LDPNMX))
      ALLOCATE(GSEPVE(0:LDPNMX,0:LDPNMX))
C
      ALLOCATE(GSEPSP(0:LDPNMX))
      ALLOCATE(GSEPVP(0:LDPNMX))
C
C=======================================================================
C
      IF (N3SERD.LT.0) STOP 'N3SERD < 0 NOT READY IN SEPENE'
C
      IF (N3SERD.GT.0) STOP 'N3SERD > 0 NOT ALLOWED IN SEPENE'
C
      NUSEPA=((IABS(N3SERD)+1)*(IABS(N3SERD)+2))/2
C
C=======================================================================
C           HERE ARE THE NN, NP, PP, AND PN STRENGTHS
C           DERIVED IN THE NOTES 77-B AND BY NICOLAS SCHUNCK
C=======================================================================
C
      CALL PHCHAN(SEPVCC,SEG_SD,SEG_VD,SEG_SE,SEG_VE,NDSEPA,NUSEPA)
C
      CALL PPCHAN(SEPVCC,SEG_SP,SEG_VP,NDSEPA,NUSEPA)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(SEPASV).AND.I_SEPA.GE.2) THEN
          ALLOCATE (SEPASV(NDBASE,NDBASE,0:NDKART,0:LDPNMX),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SEPASV','SEPENE')
      END IF
      IF (.NOT.ALLOCATED(SEPPSV).AND.ISEPPA.GE.2) THEN
          ALLOCATE (SEPPSV(NDBASE,NDBASE,0:NDKART,0:LDPNMX),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SEPPSV','SEPENE')
      END IF
C=======================================================================
C
      IF (N3SERD.GE.0) THEN
C
          I_PART=4+N3SERD
      ELSE
          I_PART=IABS(N3SERD)+7
C
      END IF
C
C=======================================================================
C
      IF (ISSEPA.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDEV=0.0
      ELSE
          XOLDEV=SLOWEV
      END IF
C
      XNEWEV=1.0-XOLDEV
C
C=======================================================================
C
      IF (ISSEPP.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDPA=0.0
      ELSE
          XOLDPA=SLOWPA
      END IF
C
      XNEWPA=1.0-XOLDPA
C
C=======================================================================
C        ZEROING THE ARRAYS THAT WILL COLLECT THE CONTRIBUTIONS COMING
C        FROM INDIVIDUAL TERMS
C=======================================================================
C
      ESPTSD=C_ZERO
      ESPTVD=C_ZERO
      ESPTSE=C_ZERO
      ESPTVE=C_ZERO
C
      ESPSSD=C_ZERO
      ESPSVD=C_ZERO
      ESPSSE=C_ZERO
      ESPSVE=C_ZERO
C
      ESPPSD=C_ZERO
      ESPPVD=C_ZERO
      ESPPSE=C_ZERO
      ESPPVE=C_ZERO
C
      ESPMSD=C_ZERO
      ESPMVD=C_ZERO
      ESPMSE=C_ZERO
      ESPMVE=C_ZERO
C
C=======================================================================
C
      GSEPSD=C_ZERO
      GSEPVD=C_ZERO
C
C=======================================================================
C
      GSEPSE=C_ZERO
      GSEPVE=C_ZERO
C
C=======================================================================
C
      GSEPSP=C_ZERO
      GSEPVP=C_ZERO
C
C=======================================================================
C
      ESEPOR=0.0D0
C
C=======================================================================
C
      ESEPDT=0.0D0
      ESEPET=0.0D0
C
      EKESEP=C_ZERO
C
C=======================================================================
C
      ESEPPT=0.0D0
C
C=======================================================================
C        INITIALIZING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      IF (I_SEPA.GE.2) THEN
C
          IF (ISSEPA.NE.1) THEN
C
              SEPASV=C_ZERO
          ELSE
              SEPASV=SEPASV*XOLDEV
C
          END IF
C
      END IF
C
C=======================================================================
C        INITIALIZING ARRAYS OF PAIRING FIELDS
C=======================================================================
C
      IF (ISEPPA.GE.2) THEN
C
          IF (ISSEPP.NE.1) THEN
              SEPPSV=C_ZERO
          ELSE
              SEPPSV=SEPPSV*XOLDPA
          END IF
C
      END IF
C
C=======================================================================
C        HERE BEGIN LOOPS (NOT INDENTED) OVER THE EXPANSION OF THE
C        SEPARABLE-FORCE FORM FACTORS INTO GAUSSIANS.
C=======================================================================
C
      NXMAXX=NXMAXV(1)
      NYMAXX=NYMAXV(1)
      NZMAXX=NZMAXV(1)
C
      DO ILEFGA=1,NUSEGA
      DO IRIGGA=1,NUSEGA
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
      CALL DEFSEP(NXMAXX,NXHERM,1,ILEFGA,IRIGGA,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
      CALL DEFSEP(NYMAXX,NYHERM,2,ILEFGA,IRIGGA,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
      CALL DEFSEP(NZMAXX,NZHERM,3,ILEFGA,IRIGGA,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
C=======================================================================
C        FOR I_SEPA=0, THE CALCULATION OF THE DIRECT TERM IS JUMPED OVER
C=======================================================================
C
      IF (I_SEPA.LT.1) GO TO 9121
C
C=======================================================================
C
      IDENSI=0
C
      CALL GAUENE(ISIMPY,I_SEPA,I_PART,IDENSI,1,1)
C
                       GAUAVR=GAUAVR*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
      IF (I_SEPA.GE.2) GAUFIL=GAUFIL*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE SEPARABLE
C        FORCE
C=======================================================================
C
      DO INSEPA=1,NUSEPA
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
         DO ICHARG=0,LDPNMX
            DO JCHARG=0,LDPNMX
C
               KARTEZ=0
C
               HSEGSD(INSEPA,ICHARG,JCHARG)=
     *         GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               HSEGVD(INSEPA,ICHARG,JCHARG)=C_ZERO
C
               DO KARTEZ=1,NDKART
C
                  HSEGVD(INSEPA,ICHARG,JCHARG)=
     *            HSEGVD(INSEPA,ICHARG,JCHARG)+
     *         GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
            END DO
         END DO
C
         DO ICHARG=0,LDPNMX
            DO JCHARG=0,LDPNMX
C
               GSEPSD(ICHARG,JCHARG)=GSEPSD(       ICHARG,JCHARG)+
     *                               SEG_SD(INSEPA,ICHARG,JCHARG)*
     *                               HSEGSD(INSEPA,ICHARG,JCHARG)
C
               GSEPVD(ICHARG,JCHARG)=GSEPVD(       ICHARG,JCHARG)+
     *                               SEG_VD(INSEPA,ICHARG,JCHARG)*
     *                               HSEGVD(INSEPA,ICHARG,JCHARG)
C
            END DO
         END DO
C
C        WRITE (*,*) ILEFGA,IRIGGA,INSEPA,GSEPSD
C
         KARTEZ=0
C
         ESPTSD=ESPTSD+SEG_SD(INSEPA,0,1)
     *                *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         ESPSSD=ESPSSD+(SEG_SD(INSEPA,0,0)-SEG_SD(INSEPA,0,1))
     *                *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         ESPPSD=ESPPSD+(SEG_SD(INSEPA,0,0)+SEG_SD(INSEPA,0,1))/2
     *                *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         ESPMSD=ESPMSD+(SEG_SD(INSEPA,0,0)-SEG_SD(INSEPA,0,1))/2
     *                *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                 -GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                 -GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         DO KARTEZ=1,NDKART
C
            ESPTVD=ESPTVD+SEG_VD(INSEPA,0,1)
     *                   *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
            ESPSVD=ESPSVD+(SEG_VD(INSEPA,0,0)-SEG_VD(INSEPA,0,1))
     *                   *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
            ESPPVD=ESPPVD+(SEG_VD(INSEPA,0,0)+SEG_VD(INSEPA,0,1))/2
     *                   *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
            ESPMVD=ESPMVD+(SEG_VD(INSEPA,0,0)-SEG_VD(INSEPA,0,1))/2
     *                   *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                    -GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                    -GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         END DO
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
         IF (I_SEPA.EQ.2.OR.I_SEPA.EQ.3) THEN
C
             DO ICHARG=0,LDPNMX
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *               =SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                   +SEG_SD(INSEPA,ICHARG,  ICHARG)
     *                   *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,  ICHARG)
     *                                                           *XNEWEV
     *                   +SEG_SD(INSEPA,ICHARG,1-ICHARG)
     *                   *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                           *XNEWEV
C
                      DO KARTEZ=1,NDKART
C
                         SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                      +SEG_VD(INSEPA,ICHARG,  ICHARG)
     *                      *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,  ICHARG)
     *                                                           *XNEWEV
     *                      +SEG_VD(INSEPA,ICHARG,1-ICHARG)
     *                      *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                           *XNEWEV
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISSEPA=1
C
         END IF
C
      END DO
C
 9121 CONTINUE
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
      CALL EXCGOG(NXMAXX,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
      CALL EXCGOG(NYMAXX,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
      CALL EXCGOG(NZMAXX,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
C=======================================================================
C        FOR I_SEPA=0, THE CALCULATION OF THE EXCHNG TERM IS JUMPED OVER
C=======================================================================
C
      IF (I_SEPA.LT.1) GO TO 9122
C
C=======================================================================
C
      IDENSI=0
C
      CALL GAUENE(ISIMPY,I_SEPA,I_PART,IDENSI,1,1)
C
                       GAUAVR=GAUAVR*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
      IF (I_SEPA.GE.2) GAUFIL=GAUFIL*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE SEPARABLE
C        FORCE
C=======================================================================
C
      DO INSEPA=1,NUSEPA
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE EXCHANGE TERM
C=======================================================================
C
         DO ICHARG=0,LDPNMX
            DO JCHARG=0,LDPNMX
C
               KARTEZ=0
C
               HSEGSE(INSEPA,ICHARG,JCHARG)=
     *                    GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               HSEGVE(INSEPA,ICHARG,JCHARG)=C_ZERO
C
               DO KARTEZ=1,NDKART
C
                  HSEGVE(INSEPA,ICHARG,JCHARG)=
     *            HSEGVE(INSEPA,ICHARG,JCHARG)+
     *                    GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
            END DO
         END DO
C
         DO ICHARG=0,LDPNMX
            DO JCHARG=0,LDPNMX
C
               GSEPSE(ICHARG,JCHARG)=GSEPSE(       ICHARG,JCHARG)+
     *                               SEG_SE(INSEPA,ICHARG,JCHARG)*
     *                               HSEGSE(INSEPA,ICHARG,JCHARG)
C
               GSEPVE(ICHARG,JCHARG)=GSEPVE(       ICHARG,JCHARG)+
     *                               SEG_VE(INSEPA,ICHARG,JCHARG)*
     *                               HSEGVE(INSEPA,ICHARG,JCHARG)
C
            END DO
         END DO
C
         KARTEZ=0
C
         ESPTSE=ESPTSE+SEG_SE(INSEPA,0,1)
     *                *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         ESPSSE=ESPSSE+(SEG_SE(INSEPA,0,0)-SEG_SE(INSEPA,0,1))
     *                *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         ESPPSE=ESPPSE+(SEG_SE(INSEPA,0,0)+SEG_SE(INSEPA,0,1))/2
     *                *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         ESPMSE=ESPMSE+(SEG_SE(INSEPA,0,0)-SEG_SE(INSEPA,0,1))/2
     *                *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                 -GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                 -GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                 +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         DO KARTEZ=1,NDKART
C
            ESPTVE=ESPTVE+SEG_VE(INSEPA,0,1)
     *                   *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
            ESPSVE=ESPSVE+(SEG_VE(INSEPA,0,0)-SEG_VE(INSEPA,0,1))
     *                   *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
            ESPPVE=ESPPVE+(SEG_VE(INSEPA,0,0)+SEG_VE(INSEPA,0,1))/2
     *                   *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
            ESPMVE=ESPMVE+(SEG_VE(INSEPA,0,0)-SEG_VE(INSEPA,0,1))/2
     *                   *(GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,0)
     *                    -GAUAVR(INSEPA-1,KARTEZ,KARTEZ,0,1)
     *                    -GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,0)
     *                    +GAUAVR(INSEPA-1,KARTEZ,KARTEZ,1,1))/2
C
         END DO
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
         IF (I_SEPA.EQ.2.OR.I_SEPA.EQ.4) THEN
C
             DO ICHARG=0,LDPNMX
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *               =SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                   +SEG_SE(INSEPA,ICHARG,  ICHARG)
     *                   *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,  ICHARG)
     *                                                           *XNEWEV
     *                   +SEG_SE(INSEPA,ICHARG,1-ICHARG)
     *                   *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                           *XNEWEV
C
                      DO KARTEZ=1,NDKART
C
                         SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                      +SEG_VE(INSEPA,ICHARG,  ICHARG)
     *                      *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,  ICHARG)
     *                                                           *XNEWEV
     *                      +SEG_VE(INSEPA,ICHARG,1-ICHARG)
     *                      *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,1-ICHARG)
     *                                                           *XNEWEV
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISSEPA=1
C
         END IF
C
      END DO
C
 9122 CONTINUE
C
C=======================================================================
C        CALCULATING THE PAIRING TERM (BLOCK NOT INDENTED)
C=======================================================================
C
      IF (ISEPPA.GE.1) THEN
C
C=======================================================================
C        HERE WE PUT THE  PARTICLE-PARTICLE  MATRIX  ELEMENTS  INTO  THE
C        PARTICLE-HOLE LOCATIONS, SO AS  THE  SAME  SUBROUTINE  "GAUENE"
C        CAN BE USED TO EVALUATE THE PAIRING TERM. NOTE THAT  THIS  MUST
C        BE DONE  A_F_T_E_R  CALCULATING THE EXCHANGE MATRIX ELEMENTS BY
C        CALLING "EXCGOG" ABOVE
C=======================================================================
C
      CALL PAIGOG(NXMAXX,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
      CALL PAIGOG(NYMAXX,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
      CALL PAIGOG(NZMAXX,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
      IDENSI=1
C
      CALL GAUENE(ISIMPY,ISEPPA,I_PART,IDENSI,1,1)
C
                       GAUAVR=GAUAVR*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
      IF (ISEPPA.GE.2) GAUFIL=GAUFIL*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE SEPARABLE
C        FORCE
C=======================================================================
C
      DO INSEPA=1,NUSEPA
C
C=======================================================================
C        CALCULATING THE AVERAGE PAIRING ENERGY
C=======================================================================
C
         DO ICHARG=0,LDPNMX
C
            KARTEZ=0
C
            GSEPSP(ICHARG)=GSEPSP(ICHARG)
     *                    +SEG_SP(INSEPA,ICHARG,ICHARG)
     *           *GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,ICHARG)
C
            DO KARTEZ=1,NDKART
C
               GSEPVP(ICHARG)=GSEPVP(ICHARG)
     *                       +SEG_VP(INSEPA,ICHARG,ICHARG)
     *              *GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,ICHARG)
C
            END DO
C
         END DO
C
C=======================================================================
C        CALCULATING THE CONTRIBUTION TO THE PAIRING FIELD
C=======================================================================
C
         IF (ISEPPA.EQ.2) THEN
C
C=======================================================================
C           FACTORS OF 2 BELOW STEM FROM THE DIFFERENT  FACTORS  IN  THE
C           ENERGIES IN THE DIRECT OR EXCHANGE PH CHANNELS AND  THAT  IN
C           THE PP CHANNEL, SEE EQS. (61)-(63) IN THE DRAFT OF THE HFODD
C           PAPER (hfodd2013-20.lat) OF 31.08.2015. BY THE  SAME  TOKEN,
C           IN THE PAIRING ENERGIES ABOVE THERE IS NO FACTOR 1/2.
C=======================================================================
C
             DO ICHARG=0,LDPNMX
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *               =SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *               +SEG_SP(INSEPA,ICHARG,ICHARG)*2
     *               *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,ICHARG)*XNEWPA
C
                      DO KARTEZ=1,NDKART
C
C=======================================================================
C             ATTENTION! THE CHANGE OF SIGN BELOW IS NOT  BASED  ON  ANY
C                        DERIVATION, BUT IT RESULTS FROM THE  COMPARISON
C                        WITH  THE  HFODD  IMPLEMENTATIONS  BY   NICOLAS
C                        SCHUNCK AND FINRES4 TESTS BY  KARIM  BENNACEUR.
C                        IT HAS BEEN INTRODUCED ON 14.03.2016.
C                        MOREOVER, FROM VERSION  (277D) TO (277O),  THIS
C                        CHANGE OF SIGN WAS INADVERTENTLY REMOVED.
C=======================================================================
C
                         SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  -SEG_VP(INSEPA,ICHARG,ICHARG)*2
     *                  *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,ICHARG)*XNEWPA
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISSEPP=1
C
         END IF
C
      END DO
C
C=======================================================================
C        END CALCULATING THE PAIRING TERM (BLOCK NOT INDENTED)
C=======================================================================
C
      END IF
C
C=======================================================================
C        CALCULATING THE TOTAL ENERGIES IN EACH SEPARABLE ORDER
C=======================================================================
C
      DO INSEPA=1,NUSEPA
C
         DO ICHARG=0,LDPNMX
            DO JCHARG=0,LDPNMX
C
               ESEPOR(INSEPA)=ESEPOR(INSEPA)+
     *                          REAL(SEG_SD(INSEPA,ICHARG,JCHARG)*
     *                               HSEGSD(INSEPA,ICHARG,JCHARG)+
     *
     *                               SEG_VD(INSEPA,ICHARG,JCHARG)*
     *                               HSEGVD(INSEPA,ICHARG,JCHARG)+
     *
     *                               SEG_SE(INSEPA,ICHARG,JCHARG)*
     *                               HSEGSE(INSEPA,ICHARG,JCHARG)+
     *
     *                               SEG_VE(INSEPA,ICHARG,JCHARG)*
     *                               HSEGVE(INSEPA,ICHARG,JCHARG))
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C        HERE END LOOPS (NOT INDENTED) OVER THE EXPANSION OF THE
C        SEPARABLE-FORCE FORM FACTORS INTO GAUSSIANS.
C=======================================================================
C
      END DO
      END DO
C
C=======================================================================
C        CALCULATING THE TOTAL DIRECT AND EXCHANGE ENERGIES
C=======================================================================
C
      DO ICHARG=0,LDPNMX
         DO JCHARG=0,LDPNMX
C
            ESEPDT=ESEPDT
     *                +REAL(GSEPSD(ICHARG,JCHARG)+GSEPVD(ICHARG,JCHARG))
            ESEPET=ESEPET
     *                +REAL(GSEPSE(ICHARG,JCHARG)+GSEPVE(ICHARG,JCHARG))
            EKESEP=EKESEP
     *                +REAL(GSEPSD(ICHARG,JCHARG)+GSEPVD(ICHARG,JCHARG)
     *                     +GSEPSE(ICHARG,JCHARG)+GSEPVE(ICHARG,JCHARG))
C
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE TOTAL PAIRING ENERGY
C=======================================================================
C
      DO ICHARG=0,LDPNMX
         ESEPPT=ESEPPT+REAL(GSEPSP(ICHARG)+GSEPVP(ICHARG))
      END DO
C
C=======================================================================
C        CALCULATING THE PAIRING GAPS FROM THE SEPARABLE FORCE
C=======================================================================
C
      IF (ISEPPA.GE.2) THEN
C
          ALLOCATE(HPAIMP(1:NDBASE,1:NDBASE))
          ALLOCATE(HPAIPM(1:NDBASE,1:NDBASE))
C
          IF (ISIMPY.NE.1) THEN
C
              ALLOCATE(HPAIPP(1:NDBASE,1:NDBASE))
              ALLOCATE(HPAIMM(1:NDBASE,1:NDBASE))
C
          END IF
C
          DO ICHARG=0,LDPNMX
C
             DELTAY=C_ZERO
C
             DO KARTEZ=0,NDKART
C
                DO IKET=1,LDBASE
                   NPY=NYVECT(IKET,1)
                   DO IBRA=1,LDBASE
                      MPY=NYVECT(IBRA,1)
C
                      HPAIMP(IBRA,IKET)=SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAMP(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      HPAIPM(IBRA,IKET)=SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAPM(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
C
                      IF (ISIMPY.NE.1) THEN
C
                      HPAIPP(IBRA,IKET)=SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAPP(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      HPAIMM(IBRA,IKET)=SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAMM(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      END IF
C
                   END DO
                END DO
C
                DELTAX(KARTEZ)=C_ZERO
                EPAIRX(KARTEZ)=C_ZERO
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      DELTAX(KARTEZ)=DELTAX(KARTEZ)
     *                              +HPAIMP(IBRA,IKET)
     *                              *DEN_PP(IKET,IBRA,0,ICHARG)
     *                              -HPAIPM(IBRA,IKET)
     *                              *DEN_PP(IKET,IBRA,1,ICHARG)
                      EPAIRX(KARTEZ)=EPAIRX(KARTEZ)
     *                              +HPAIPM(IBRA,IKET)*CONJG(
     *                               CHI_PM(IBRA,IKET,0,ICHARG))/2
     *                              +HPAIMP(IBRA,IKET)*CONJG(
     *                               CHI_PM(IBRA,IKET,1,ICHARG))/2
C
                      IF (ISIMPY.NE.1) THEN
C
                      DELTAX(KARTEZ)=DELTAX(KARTEZ)
     *                              -HPAIPP(IBRA,IKET)
     *                              *DEN_PM(IKET,IBRA,0,ICHARG)
     *                              +HPAIMM(IBRA,IKET)
     *                              *DEN_PM(IKET,IBRA,1,ICHARG)
                      EPAIRX(KARTEZ)=EPAIRX(KARTEZ)
     *                              +HPAIPP(IBRA,IKET)*CONJG(
     *                               CHI_PP(IBRA,IKET,0,ICHARG))/2
     *                              +HPAIMM(IBRA,IKET)*CONJG(
     *                               CHI_PP(IBRA,IKET,1,ICHARG))/2
                      END IF
C
                   END DO
                END DO
C
C=======================================================================
C             ATTENTION! SEE COMMENTS IN "REGENE".
C=======================================================================
C
                IF (KARTEZ.EQ.1) DELTAX(KARTEZ)=-DELTAX(KARTEZ)
                IF (KARTEZ.EQ.2) DELTAX(KARTEZ)=-DELTAX(KARTEZ)
C
                DELTAY=DELTAY             +DELTAX(KARTEZ)
                PSEPVP(KARTEZ,ICHARG)=REAL(EPAIRX(KARTEZ))
C
C     WRITE (*,'(2I3,2(4X,2D15.7))') ICHARG,KARTEZ,
C    *                               DELTAX(KARTEZ),EPAIRX(KARTEZ)
C
             END DO
C
             IF (ICHARG.EQ.0) DELTAN=DELTAN+ABS(DELTAY)/IN_FIX
             IF (ICHARG.EQ.1) DELTAP=DELTAP+ABS(DELTAY)/IZ_FIX
          END DO
C
                           DEALLOCATE(HPAIMP,HPAIPM)
          IF (ISIMPY.NE.1) DEALLOCATE(HPAIPP,HPAIMM)
C
      END IF
C
      ESEPSD(0:NDISOS,0:NDISOS)=REAL(GSEPSD(0:NDISOS,0:NDISOS))
      ESEPSE(0:NDISOS,0:NDISOS)=REAL(GSEPSE(0:NDISOS,0:NDISOS))
      ESEPVD(0:NDISOS,0:NDISOS)=REAL(GSEPVD(0:NDISOS,0:NDISOS))
      ESEPVE(0:NDISOS,0:NDISOS)=REAL(GSEPVE(0:NDISOS,0:NDISOS))
C
      ESEPSP(0:NDISOS)         =REAL(GSEPSP(0:NDISOS))
      ESEPVP(0:NDISOS)         =REAL(GSEPVP(0:NDISOS))
C
C=======================================================================
C
      CALL CPUTIM('SEPENE',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SEPMIE(ISSEPA,I_SEPA,SLOWPA,ISSEPP,ISEPPA,
     *                  N3SERD,ISIMPY,IN_FIX,IZ_FIX,EKESEP,
     *                                I_SLOW,SLOWEV,LDPNMX)
C
C=======================================================================
      USE GAUSTO
      USE SEPSTO
      USE SPASTO
      USE MAD_PP
      USE MAD_PM
      USE MAP_PP
      USE MAP_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *          ESEPSD,ESEPVD,ESEPSE,ESEPVE
      COMPLEX
     *          ESEPSP,ESEPVP
      COMPLEX
     *          HSEGSD,HSEGVD,HSEGSE,HSEGVE,HSEGSP,HSEGVP
      COMPLEX
     *          EKESEP
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          DELTAY,DELTAX(0:NDKART),EPAIRX(0:NDKART)
      COMPLEX
     *          DELTNP,DELTPN
      COMPLEX
     *          HPAIMP,HPAIPM,HPAIPP,HPAIMM
      COMPLEX
     *          PHACOM
      COMPLEX
     *          GSE00D,GSE01D,GSE10D,GSE11D,
     *          GSE00E,GSE01E,GSE10E,GSE11E,
     *          GSE00P,GSE01P,GSE10P,GSE11P
C=======================================================================
      ALLOCATABLE :: HPAIMP(:,:),HPAIPM(:,:),HPAIPP(:,:),HPAIMM(:,:)
C=======================================================================
      ALLOCATABLE :: SEG_SD(:,:,:),SEG_VD(:,:,:),
     *               SEG_SE(:,:,:),SEG_VE(:,:,:),
     *               SEG_SP(:,:,:),SEG_VP(:,:,:)
C=======================================================================
      ALLOCATABLE :: HSEGSD(:,:,:),HSEGVD(:,:,:),
     *               HSEGSE(:,:,:),HSEGVE(:,:,:),
     *               HSEGSP(:,:,:),HSEGVP(:,:,:)
C=======================================================================
      DIMENSION
     *      SEG00D(NDSEPA),SEG01D(NDSEPA),SEG10D(NDSEPA),SEG11D(NDSEPA),
     *      SEG00E(NDSEPA),SEG01E(NDSEPA),SEG10E(NDSEPA),SEG11E(NDSEPA),
     *      SEG00P(NDSEPA),SEG01P(NDSEPA),SEG10P(NDSEPA),SEG11P(NDSEPA)
      DIMENSION
     *      GSE00D(NDSEPA),GSE01D(NDSEPA),GSE10D(NDSEPA),GSE11D(NDSEPA),
     *      GSE00E(NDSEPA),GSE01E(NDSEPA),GSE10E(NDSEPA),GSE11E(NDSEPA),
     *      GSE00P(NDSEPA),GSE01P(NDSEPA),GSE10P(NDSEPA),GSE11P(NDSEPA)
C=======================================================================
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /EN_SEP/ ESEPSD(0:NDISOS,0:NDISOS),
     *                ESEPSE(0:NDISOS,0:NDISOS),
     *                ESEPVD(0:NDISOS,0:NDISOS),
     *                ESEPVE(0:NDISOS,0:NDISOS)
     *
     *       /EN_SOR/ ESEPOR(NDSEPA)
     *
      COMMON
     *       /PN_SEP/ ESEPSP(0:NDISOS),ESEPVP(0:NDISOS)
     *
     *       /PV_SEP/ PSEPVP(0:NDKART,0:NDISOS)
      COMMON
     *       /ESEPTT/ ESEPDT,ESEPET
      COMMON
     *       /PSEPTT/ ESEPPT
      COMMON
     *       /SEPPAR/ SEPWID(NDSEGA),SEPGAU(NDSEGA),NUSEGA
      COMMON
     *       /SEPVIN/ SEPVCC(NDSEPA,NDFORC),IRESEP
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
     *       /DATMIX/ DELTNP,DELTPN
      COMMON
     *       /B_PHAS/ JPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('SEPMIE',1)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C        THIS SUBROUTINE WORKS IN THE CASE OF THE P-N MIXING, AND:
C        1) FOR I_SEPA>0 CALCULATES THE AVERAGE VALUES OF THE
C           FINITE-RANGE SEPARABLE FORCE (FOR N3SERD < 0)
C        2) FOR I_SEPA=2 OR I_SEPA=3 IT CALCULATES IN ADDITION
C           THE CORRESPONDING  DIRECT  MEAN FIELDS
C        3) FOR I_SEPA=2 OR I_SEPA=4 IT CALCULATES IN ADDITION
C           THE CORRESPONDING EXCHANAGE MEAN FIELDS
C        4) FOR ISEPPA>0 CALCULATES THE AVERAGE VALUES OF THE PAIRING
C           FINITE-RANGE SEPARABLE FORCE (FOR N3SERD < 0)
C        5) FOR ISEPPA=2 IT CALCULATES IN ADDITION
C           THE CORRESPONDING PAIRING MEAN FIELDS
C=======================================================================
C
      ALLOCATE(SEG_SD(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_VD(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_SE(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_VE(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_SP(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(SEG_VP(NDSEPA,0:LDPNMX,0:LDPNMX))
C
      ALLOCATE(HSEGSD(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(HSEGVD(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(HSEGSE(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(HSEGVE(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(HSEGSP(NDSEPA,0:LDPNMX,0:LDPNMX))
      ALLOCATE(HSEGVP(NDSEPA,0:LDPNMX,0:LDPNMX))
C
C=======================================================================
C
      IF (N3SERD.LT.0) STOP 'N3SERD < 0 NOT READY IN SEPMIE'
C
      IF (N3SERD.GT.0) STOP 'N3SERD > 0 NOT ALLOWED IN SEPMIE'
C
      NUSEPA=((IABS(N3SERD)+1)*(IABS(N3SERD)+2))/2
C
C=======================================================================
C           HERE ARE THE SCALAR-VECTOR AND ISOSCALAR-ISOVECTOR STRENGTHS
C           DERIVED IN CPC 216
C=======================================================================
C
      CALL PHISOC(SEPVCC,SEG00D,SEG01D,SEG10D,SEG11D,
     *                   SEG00E,SEG01E,SEG10E,SEG11E,NDSEPA,NUSEPA)
C
      CALL PPISOC(SEPVCC,SEG00P,SEG01P,SEG10P,SEG11P,NDSEPA,NUSEPA)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(SEPASV).AND.I_SEPA.GE.2) THEN
          ALLOCATE (SEPASV(NDBASE,NDBASE,0:NDKART,0:LDPNMX),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SEPASV','SEPMIE')
      END IF
      IF (.NOT.ALLOCATED(SEPPSV).AND.ISEPPA.GE.2) THEN
          ALLOCATE (SEPPSV(NDBASE,NDBASE,0:NDKART,0:LDPNMX),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SEPPSV','SEPMIE')
      END IF
C=======================================================================
C
      IF (N3SERD.GE.0) THEN
C
          I_PART=4+N3SERD
      ELSE
          I_PART=IABS(N3SERD)+7
C
      END IF
C
C=======================================================================
C
      IF (ISSEPA.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDEV=0.0
      ELSE
          XOLDEV=SLOWEV
      END IF
C
      XNEWEV=1.0-XOLDEV
C
C=======================================================================
C
      IF (ISSEPP.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDPA=0.0
      ELSE
          XOLDPA=SLOWPA
      END IF
C
      XNEWPA=1.0-XOLDPA
C
C=======================================================================
C        ZEROING THE ARRAYS THAT WILL COLLECT THE CONTRIBUTIONS COMING
C        FROM INDIVIDUAL TERMS
C=======================================================================
C
      GSE00D=C_ZERO
      GSE01D=C_ZERO
      GSE10D=C_ZERO
      GSE11D=C_ZERO
C
      GSE00E=C_ZERO
      GSE01E=C_ZERO
      GSE10E=C_ZERO
      GSE11E=C_ZERO
C
      GSE00P=C_ZERO
      GSE01P=C_ZERO
      GSE10P=C_ZERO
      GSE11P=C_ZERO
C
C=======================================================================
C
      ESEPOR=0.0D0
C
C=======================================================================
C
      ESEPDT=0.0D0
      ESEPET=0.0D0
C
      EKESEP=C_ZERO
C
C=======================================================================
C
      ESEPPT=0.0D0
C
C=======================================================================
C        INITIALIZING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      IF (I_SEPA.GE.2) THEN
C
          IF (ISSEPA.NE.1) THEN
C
              SEPASV=C_ZERO
          ELSE
              SEPASV=SEPASV*XOLDEV
C
          END IF
C
      END IF
C
C=======================================================================
C        INITIALIZING ARRAYS OF PAIRING FIELDS
C=======================================================================
C
      IF (ISEPPA.GE.2) THEN
C
          IF (ISSEPP.NE.1) THEN
              SEPPSV=C_ZERO
          ELSE
              SEPPSV=SEPPSV*XOLDPA
          END IF
C
      END IF
C
C=======================================================================
C        HERE BEGIN LOOPS (NOT INDENTED) OVER THE EXPANSION OF THE
C        SEPARABLE-FORCE FORM FACTORS INTO GAUSSIANS.
C=======================================================================
C
      NXMAXX=NXMAXV(1)
      NYMAXX=NYMAXV(1)
      NZMAXX=NZMAXV(1)
C
      DO ILEFGA=1,NUSEGA
      DO IRIGGA=1,NUSEGA
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
      CALL DEFSEP(NXMAXX,NXHERM,1,ILEFGA,IRIGGA,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
      CALL DEFSEP(NYMAXX,NYHERM,2,ILEFGA,IRIGGA,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
      CALL DEFSEP(NZMAXX,NZHERM,3,ILEFGA,IRIGGA,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
C=======================================================================
C        FOR I_SEPA=0, THE CALCULATION OF THE DIRECT TERM IS JUMPED OVER
C=======================================================================
C
      IF (I_SEPA.LT.1) GO TO 9122
C
C=======================================================================
C
      IDENSI=0
C
      CALL GAUENE(ISIMPY,I_SEPA,I_PART,IDENSI,1,1)
C
                       GAUAVR=GAUAVR*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
      IF (I_SEPA.GE.2) GAUFIL=GAUFIL*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE SEPARABLE
C        FORCE
C=======================================================================
C
      DO INSEPA=1,NUSEPA
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
         DO ICHARG=0,LDPNMX
            DO JCHARG=0,LDPNMX
C
               KARTEZ=0
C
               HSEGSD(INSEPA,ICHARG,JCHARG)=
     *         GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               HSEGVD(INSEPA,ICHARG,JCHARG)=C_ZERO
C
               DO KARTEZ=1,NDKART
C
                  HSEGVD(INSEPA,ICHARG,JCHARG)=
     *            HSEGVD(INSEPA,ICHARG,JCHARG)+
     *         GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
            END DO
         END DO
C
         GSE00D(INSEPA)=GSE00D(INSEPA)  +  SEG00D(INSEPA)
     *                *(HSEGSD(INSEPA,0,0)+HSEGSD(INSEPA,0,1)
     *                 +HSEGSD(INSEPA,1,0)+HSEGSD(INSEPA,1,1))
C
         GSE10D(INSEPA)=GSE10D(INSEPA)  +  SEG10D(INSEPA)
     *                *(HSEGVD(INSEPA,0,0)+HSEGVD(INSEPA,0,1)
     *                 +HSEGVD(INSEPA,1,0)+HSEGVD(INSEPA,1,1))
C
         GSE01D(INSEPA)=GSE01D(INSEPA)  +  SEG01D(INSEPA)
     *                *(HSEGSD(INSEPA,0,0)-HSEGSD(INSEPA,0,1)
     *                 -HSEGSD(INSEPA,1,0)+HSEGSD(INSEPA,1,1)
     *                 +HSEGSD(INSEPA,2,2)+HSEGSD(INSEPA,3,3)
     *                 -HSEGSD(INSEPA,2,2)*UNIT_I
     *                 +HSEGSD(INSEPA,3,3)*UNIT_I)
C
         GSE11D(INSEPA)=GSE11D(INSEPA)  +  SEG11D(INSEPA)
     *                *(HSEGVD(INSEPA,0,0)-HSEGVD(INSEPA,0,1)
     *                 -HSEGVD(INSEPA,1,0)+HSEGVD(INSEPA,1,1)
     *                 +HSEGVD(INSEPA,2,2)+HSEGVD(INSEPA,3,3)
     *                 -HSEGVD(INSEPA,2,2)*UNIT_I
     *                 +HSEGVD(INSEPA,3,3)*UNIT_I)
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
         IF (I_SEPA.EQ.2.OR.I_SEPA.EQ.3) THEN
C
             DO ICHARG=0,LDPNMX
C
                IF (ICHARG.EQ.0) SEG0XD=SEG00D(INSEPA)+SEG01D(INSEPA)
                IF (ICHARG.EQ.1) SEG0XD=SEG00D(INSEPA)+SEG01D(INSEPA)
                IF (ICHARG.EQ.2) SEG0XD=SEG00D(INSEPA)-SEG01D(INSEPA)
                IF (ICHARG.EQ.3) SEG0XD=SEG00D(INSEPA)-SEG01D(INSEPA)
C
                IF (ICHARG.EQ.0) SEG1XD=SEG10D(INSEPA)+SEG11D(INSEPA)
                IF (ICHARG.EQ.1) SEG1XD=SEG10D(INSEPA)+SEG11D(INSEPA)
                IF (ICHARG.EQ.2) SEG1XD=SEG10D(INSEPA)-SEG11D(INSEPA)
                IF (ICHARG.EQ.3) SEG1XD=SEG10D(INSEPA)-SEG11D(INSEPA)
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *               =SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *               +SEG0XD
     *               *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,ICHARG)*XNEWEV
C
                      DO KARTEZ=1,NDKART
C
                         SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  +SEG1XD
     *                  *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,ICHARG)*XNEWEV
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISSEPA=1
C
         END IF
C
      END DO
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
      CALL EXCGOG(NXMAXX,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
      CALL EXCGOG(NYMAXX,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
      CALL EXCGOG(NZMAXX,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
C=======================================================================
C        FOR I_SEPA=0, THE CALCULATION OF THE EXCHNG TERM IS JUMPED OVER
C=======================================================================
C
      IF (I_SEPA.LT.1) GO TO 9122
C
C=======================================================================
C
      IDENSI=0
C
      CALL GAUENE(ISIMPY,I_SEPA,I_PART,IDENSI,1,1)
C
                       GAUAVR=GAUAVR*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
      IF (I_SEPA.GE.2) GAUFIL=GAUFIL*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE SEPARABLE
C        FORCE
C=======================================================================
C
      DO INSEPA=1,NUSEPA
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE EXCHANGE TERM
C=======================================================================
C
         DO ICHARG=0,LDPNMX
            DO JCHARG=0,LDPNMX
C
               KARTEZ=0
C
               HSEGSE(INSEPA,ICHARG,JCHARG)=
     *         GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               HSEGVE(INSEPA,ICHARG,JCHARG)=C_ZERO
C
               DO KARTEZ=1,NDKART
C
                  HSEGVE(INSEPA,ICHARG,JCHARG)=
     *            HSEGVE(INSEPA,ICHARG,JCHARG)+
     *         GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
            END DO
         END DO
C
         GSE00E(INSEPA)=GSE00E(INSEPA)  +  SEG00E(INSEPA)
     *                *(HSEGSE(INSEPA,0,0)+HSEGSE(INSEPA,0,1)
     *                 +HSEGSE(INSEPA,1,0)+HSEGSE(INSEPA,1,1))
C
         GSE10E(INSEPA)=GSE10E(INSEPA)  +  SEG10E(INSEPA)
     *                *(HSEGVE(INSEPA,0,0)+HSEGVE(INSEPA,0,1)
     *                 +HSEGVE(INSEPA,1,0)+HSEGVE(INSEPA,1,1))
C
         GSE01E(INSEPA)=GSE01E(INSEPA)  +  SEG01E(INSEPA)
     *                *(HSEGSE(INSEPA,0,0)-HSEGSE(INSEPA,0,1)
     *                 -HSEGSE(INSEPA,1,0)+HSEGSE(INSEPA,1,1)
     *                 +HSEGSE(INSEPA,2,2)+HSEGSE(INSEPA,3,3)
     *                 -HSEGSE(INSEPA,2,2)*UNIT_I
     *                 +HSEGSE(INSEPA,3,3)*UNIT_I)
C
         GSE11E(INSEPA)=GSE11E(INSEPA)  +  SEG11E(INSEPA)
     *                *(HSEGVE(INSEPA,0,0)-HSEGVE(INSEPA,0,1)
     *                 -HSEGVE(INSEPA,1,0)+HSEGVE(INSEPA,1,1)
     *                 +HSEGVE(INSEPA,2,2)+HSEGVE(INSEPA,3,3)
     *                 -HSEGVE(INSEPA,2,2)*UNIT_I
     *                 +HSEGVE(INSEPA,3,3)*UNIT_I)
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
         IF (I_SEPA.EQ.2.OR.I_SEPA.EQ.4) THEN
C
             DO ICHARG=0,LDPNMX
C
                IF (ICHARG.EQ.0) SEG0XE=SEG00E(INSEPA)+SEG01E(INSEPA)
                IF (ICHARG.EQ.1) SEG0XE=SEG00E(INSEPA)+SEG01E(INSEPA)
                IF (ICHARG.EQ.2) SEG0XE=SEG00E(INSEPA)-SEG01E(INSEPA)
                IF (ICHARG.EQ.3) SEG0XE=SEG00E(INSEPA)-SEG01E(INSEPA)
C
                IF (ICHARG.EQ.0) SEG1XE=SEG10E(INSEPA)+SEG11E(INSEPA)
                IF (ICHARG.EQ.1) SEG1XE=SEG10E(INSEPA)+SEG11E(INSEPA)
                IF (ICHARG.EQ.2) SEG1XE=SEG10E(INSEPA)-SEG11E(INSEPA)
                IF (ICHARG.EQ.3) SEG1XE=SEG10E(INSEPA)-SEG11E(INSEPA)
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *               =SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *               +SEG0XE
     *               *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,ICHARG)*XNEWEV
C
                      DO KARTEZ=1,NDKART
C
                         SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =SEPASV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  +SEG1XE
     *                  *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,ICHARG)*XNEWEV
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISSEPA=1
C
         END IF
C
      END DO
C
 9122 CONTINUE
C
C=======================================================================
C        CALCULATING THE PAIRING TERM (BLOCK NOT INDENTED)
C=======================================================================
C
      IF (ISEPPA.GE.1) THEN
C
C=======================================================================
C        HERE WE PUT THE  PARTICLE-PARTICLE  MATRIX  ELEMENTS  INTO  THE
C        PARTICLE-HOLE LOCATIONS, SO AS  THE  SAME  SUBROUTINE  "GAUENE"
C        CAN BE USED TO EVALUATE THE PAIRING TERM. NOTE THAT  THIS  MUST
C        BE DONE  A_F_T_E_R  CALCULATING THE EXCHANGE MATRIX ELEMENTS BY
C        CALLING "EXCGOG" ABOVE
C=======================================================================
C
      CALL PAIGOG(NXMAXX,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
      CALL PAIGOG(NYMAXX,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
      CALL PAIGOG(NZMAXX,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
      IDENSI=1
C
      CALL GAUENE(ISIMPY,ISEPPA,I_PART,IDENSI,1,1)
C
                       GAUAVR=GAUAVR*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
      IF (ISEPPA.GE.2) GAUFIL=GAUFIL*(SEPGAU(ILEFGA)*SEPGAU(IRIGGA))
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE SEPARABLE
C        FORCE
C=======================================================================
C
      DO INSEPA=1,NUSEPA
C
C=======================================================================
C        CALCULATING THE AVERAGE PAIRING ENERGY
C=======================================================================
C
         DO ICHARG=0,LDPNMX
            DO JCHARG=0,LDPNMX
C
               KARTEZ=0
C
               HSEGSP(INSEPA,ICHARG,JCHARG)=
     *         GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               HSEGVP(INSEPA,ICHARG,JCHARG)=C_ZERO
C
               DO KARTEZ=1,NDKART
C
                  HSEGVP(INSEPA,ICHARG,JCHARG)=
     *            HSEGVP(INSEPA,ICHARG,JCHARG)+
     *         GAUAVR(INSEPA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
            END DO
         END DO
C
         GSE00P(INSEPA)=GSE00P(INSEPA)  +  SEG00P(INSEPA)
     *               *(-HSEGSP(INSEPA,2,2)+HSEGSP(INSEPA,3,3))
C
         GSE10P(INSEPA)=GSE10P(INSEPA)  +  SEG10P(INSEPA)
     *               *(-HSEGVP(INSEPA,2,2)+HSEGVP(INSEPA,3,3))
C
         GSE01P(INSEPA)=GSE01P(INSEPA)  +  SEG01P(INSEPA)
     *               *(-HSEGSP(INSEPA,0,0)+HSEGSP(INSEPA,0,1)
     *                 +HSEGSP(INSEPA,1,0)-HSEGSP(INSEPA,1,1)
     *                +(HSEGSP(INSEPA,0,0)+HSEGSP(INSEPA,0,1)
     *                 +HSEGSP(INSEPA,1,0)+HSEGSP(INSEPA,1,1))*(-UNIT_I)
     *                 +HSEGSP(INSEPA,2,2)+HSEGSP(INSEPA,3,3))
C
         GSE11P(INSEPA)=GSE11P(INSEPA)  +  SEG11P(INSEPA)
     *               *(-HSEGVP(INSEPA,0,0)+HSEGVP(INSEPA,0,1)
     *                 +HSEGVP(INSEPA,1,0)-HSEGVP(INSEPA,1,1)
     *                +(HSEGVP(INSEPA,0,0)+HSEGVP(INSEPA,0,1)
     *                 +HSEGVP(INSEPA,1,0)+HSEGVP(INSEPA,1,1))*(-UNIT_I)
     *                 +HSEGVP(INSEPA,2,2)+HSEGVP(INSEPA,3,3))
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE PAIRING TERM
C=======================================================================
C
         IF (ISEPPA.EQ.2) THEN
C
             DO ICHARG=0,LDPNMX
C
                IF (ICHARG.EQ.0) SEG0XP=SEG00P(INSEPA)+SEG01P(INSEPA)
                IF (ICHARG.EQ.1) SEG0XP=SEG00P(INSEPA)+SEG01P(INSEPA)
                IF (ICHARG.EQ.2) SEG0XP=SEG00P(INSEPA)-SEG01P(INSEPA)
                IF (ICHARG.EQ.3) SEG0XP=SEG00P(INSEPA)-SEG01P(INSEPA)
C
                IF (ICHARG.EQ.0) SEG1XP=SEG10P(INSEPA)+SEG11P(INSEPA)
                IF (ICHARG.EQ.1) SEG1XP=SEG10P(INSEPA)+SEG11P(INSEPA)
                IF (ICHARG.EQ.2) SEG1XP=SEG10P(INSEPA)-SEG11P(INSEPA)
                IF (ICHARG.EQ.3) SEG1XP=SEG10P(INSEPA)-SEG11P(INSEPA)
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *               =SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *               +SEG0XP
     *               *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,ICHARG)*XNEWPA
C
C=======================================================================
C             ATTENTION! THE CHANGE OF SIGN BELOW IS NOT  BASED  ON  ANY
C                        DERIVATION, BUT IT RESULTS FROM THE  COMPARISON
C                        WITH  THE  HFODD  IMPLEMENTATIONS  BY   NICOLAS
C                        SCHUNCK AND FINRES4 TESTS BY  KARIM  BENNACEUR.
C                        IT HAS BEEN INTRODUCED ON 14.03.2016.
C                        MOREOVER, FROM VERSION  (277D) TO (277O),  THIS
C                        CHANGE OF SIGN WAS INADVERTENTLY REMOVED.
C=======================================================================
C
                      DO KARTEZ=1,NDKART
C
                         SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                  =SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  -SEG1XP
     *                  *GAUFIL(INSEPA-1,IBRA,IKET,KARTEZ,ICHARG)*XNEWPA
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISSEPP=1
C
         END IF
C
      END DO
C
C=======================================================================
C        END CALCULATING THE PAIRING TERM (BLOCK NOT INDENTED)
C=======================================================================
C
      END IF
C
C=======================================================================
C        CALCULATING THE TOTAL ENERGIES IN EACH SEPARABLE ORDER
C        CALCULATING THE TOTAL DIRECT, EXCHANGE, AND PAIRING ENERGIES
C=======================================================================
C
      DO INSEPA=1,NUSEPA
C
         ESEPOR(INSEPA)=ESEPOR(INSEPA)+REAL(
     *
     *   GSE00D(INSEPA)+GSE01D(INSEPA)+GSE10D(INSEPA)+GSE11D(INSEPA)+
     *   GSE00E(INSEPA)+GSE01E(INSEPA)+GSE10E(INSEPA)+GSE11E(INSEPA))
C
         ESEPDT=ESEPDT+REAL(
     *   GSE00D(INSEPA)+GSE01D(INSEPA)+GSE10D(INSEPA)+GSE11D(INSEPA))
C
         ESEPET=ESEPET+REAL(
     *   GSE00E(INSEPA)+GSE01E(INSEPA)+GSE10E(INSEPA)+GSE11E(INSEPA))
C
         EKESEP=EKESEP+
     *   GSE00P(INSEPA)+GSE01P(INSEPA)+GSE10P(INSEPA)+GSE11P(INSEPA)
C
         ESEPPT=ESEPPT+REAL(
     *   GSE00P(INSEPA)+GSE01P(INSEPA)+GSE10P(INSEPA)+GSE11P(INSEPA))
C
      END DO
C
C=======================================================================
C        HERE END LOOPS (NOT INDENTED) OVER THE EXPANSION OF THE
C        SEPARABLE-FORCE FORM FACTORS INTO GAUSSIANS.
C=======================================================================
C
      END DO
      END DO
C
C=======================================================================
C        CALCULATING THE PAIRING GAPS FROM THE SEPARABLE FORCE
C=======================================================================
C
      IF (ISEPPA.GE.2) THEN
C
          ALLOCATE(HPAIMP(1:NDBASE,1:NDBASE))
          ALLOCATE(HPAIPM(1:NDBASE,1:NDBASE))
C
          IF (ISIMPY.NE.1) THEN
C
              ALLOCATE(HPAIPP(1:NDBASE,1:NDBASE))
              ALLOCATE(HPAIMM(1:NDBASE,1:NDBASE))
C
          END IF
C
          DO ICHARG=0,LDPNMX
C
             DELTAY=C_ZERO
C
             DO KARTEZ=0,NDKART
C
                DO IKET=1,LDBASE
                   NPY=NYVECT(IKET,1)
                   DO IBRA=1,LDBASE
                      MPY=NYVECT(IBRA,1)
C
                      HPAIMP(IBRA,IKET)=SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAMP(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      HPAIPM(IBRA,IKET)=SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAPM(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
C
                      IF (ISIMPY.NE.1) THEN
C
                      HPAIPP(IBRA,IKET)=SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAPP(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      HPAIMM(IBRA,IKET)=SEPPSV(IBRA,IKET,KARTEZ,ICHARG)
     *                                 *JPHAMM(MPY,NPY,KARTEZ)
     *                                 *CONJG(PHACOM(KARTEZ))
                      END IF
C
                   END DO
                END DO
C
                DELTAX(KARTEZ)=C_ZERO
                EPAIRX(KARTEZ)=C_ZERO
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      DELTAX(KARTEZ)=DELTAX(KARTEZ)
     *                              +HPAIMP(IBRA,IKET)
     *                              *DEN_PP(IKET,IBRA,0,ICHARG)
     *                              -HPAIPM(IBRA,IKET)
     *                              *DEN_PP(IKET,IBRA,1,ICHARG)
                      EPAIRX(KARTEZ)=EPAIRX(KARTEZ)
     *                              +HPAIPM(IBRA,IKET)*CONJG(
     *                               CHI_PM(IBRA,IKET,0,ICHARG))/2
     *                              +HPAIMP(IBRA,IKET)*CONJG(
     *                               CHI_PM(IBRA,IKET,1,ICHARG))/2
C
                      IF (ISIMPY.NE.1) THEN
C
                      DELTAX(KARTEZ)=DELTAX(KARTEZ)
     *                              -HPAIPP(IBRA,IKET)
     *                              *DEN_PM(IKET,IBRA,0,ICHARG)
     *                              +HPAIMM(IBRA,IKET)
     *                              *DEN_PM(IKET,IBRA,1,ICHARG)
                      EPAIRX(KARTEZ)=EPAIRX(KARTEZ)
     *                              +HPAIPP(IBRA,IKET)*CONJG(
     *                               CHI_PP(IBRA,IKET,0,ICHARG))/2
     *                              +HPAIMM(IBRA,IKET)*CONJG(
     *                               CHI_PP(IBRA,IKET,1,ICHARG))/2
                      END IF
C
                   END DO
                END DO
C
C=======================================================================
C             ATTENTION! SEE COMMENTS IN "REGENE".
C=======================================================================
C
                IF (KARTEZ.EQ.1) DELTAX(KARTEZ)=-DELTAX(KARTEZ)
                IF (KARTEZ.EQ.2) DELTAX(KARTEZ)=-DELTAX(KARTEZ)
C
                DELTAY=DELTAY             +DELTAX(KARTEZ)
C
C=======================================================================
C               STORING THE NP AND PN ENERGIES IS LEFT FOR LATER
C=======================================================================
C
                IF (ICHARG.LE.1)
     *          PSEPVP(KARTEZ,ICHARG)=REAL(EPAIRX(KARTEZ))
C
C     WRITE (*,'(2I3,2(4X,2D15.7))') ICHARG,KARTEZ,
C    *                               DELTAX(KARTEZ),EPAIRX(KARTEZ)
C
             END DO
C
             IF (ICHARG.EQ.0) DELTAN=DELTAN+ABS(DELTAY)/IN_FIX
             IF (ICHARG.EQ.1) DELTAP=DELTAP+ABS(DELTAY)/IZ_FIX
C
             IF (ICHARG.EQ.2) DELTNP=DELTNP+DELTAY
             IF (ICHARG.EQ.3) DELTPN=DELTPN+DELTAY
C
          END DO
C
                           DEALLOCATE(HPAIMP,HPAIPM)
          IF (ISIMPY.NE.1) DEALLOCATE(HPAIPP,HPAIMM)
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('SEPMIE',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE REGENP(I_SLOW,SLOWEV,ISREGA,I_REGA,N3LORD,ISIMPY,
     *                                                     EKEREG)
C=======================================================================
      USE GAUSTO
C     USE REGSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          EREGSD,EREGSE,EREGVD,EREGVE
      COMPLEX
     *          HREGSD,HREGSE,HREGVD,HREGVE
      COMPLEX
     *          HCEGSD,HCEGSE,HCEGVD,HCEGVE
      COMPLEX
     *          EKEREG
      COMPLEX
     *          C_ZERO
C=======================================================================
C     DIMENSION
C    *          CEG_SD(NDREGA,0:NDISOS,0:NDISOS),
C    *          CEG_VD(NDREGA,0:NDISOS,0:NDISOS),
C    *          CEG_SE(NDREGA,0:NDISOS,0:NDISOS),
C    *          CEG_VE(NDREGA,0:NDISOS,0:NDISOS)
      DIMENSION
     *          REG_SD(NDREGA),
     *          REG_VD(NDREGA),
     *          REG_SE(NDREGA),
     *          REG_VE(NDREGA)
      DIMENSION
     *          HCEGSD(NDREGA),
     *          HCEGVD(NDREGA),
     *          HCEGSE(NDREGA),
     *          HCEGVE(NDREGA)
      DIMENSION
     *          HREGSD(NDREGA),
     *          HREGVD(NDREGA),
     *          HREGSE(NDREGA),
     *          HREGVE(NDREGA)
      DIMENSION
     *          FACTOR(NDREGA)
C=======================================================================
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /REGPAR/ REGWID
      COMMON
     *       /REGFOR/ REGSTR(NDREGA,NDFORC)
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('REGENP',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES:
C        1) THE AVERAGE VALUES OF THE FINITE-RANGE REGULARIZED SKYRME
C           INTERACTION T2=-T1 FOR THE NEUTRON-PROTON TERMS
C                                                         (FOR I_REGA>0)
C        2) THE CORRESPONDING  DIRECT   MEAN FIELDS
C                                            (FOR I_REGA=2 OR  I_REGA=3)
C        3) THE CORRESPONDING EXCHANAGE MEAN FIELDS
C                                            (FOR I_REGA=2 OR  I_REGA=4)
C        ATTENTION: I_REGA > 1 IS NOT YET IMPLEMENTED
C=======================================================================
C
      IF (N3LORD.LT.0) STOP ' NEGATIVE N3LORD NOT YET ALLOWED IN REGENP'
C
C     IF (I_REGA.GT.1) STOP ' I_REGA > 1 NOT YET IMPLEMENTED IN REGENP'
C
C=======================================================================
C           HERE ARE THE NN, NP, PP, AND PN STRENGTHS
C           DERIVED IN THE NOTES 77-B
C=======================================================================
C
      NUREGA=N3LORD+1
C
C=======================================================================
C
      DO INREGA=1,NUREGA
C
         REG_SD(INREGA)=4*(-REGSTR(INREGA,3)/2-REGSTR(INREGA,4)/4)
         REG_VD(INREGA)=4*(                   -REGSTR(INREGA,4)/4)
         REG_SE(INREGA)=4*(-REGSTR(INREGA,2)/2-REGSTR(INREGA,1)/4)
         REG_VE(INREGA)=4*(                   -REGSTR(INREGA,1)/4)
C
      END DO
C
C=======================================================================
C
C     IALLOC=0
C
C=======================================================================
C     IF (.NOT.ALLOCATED(REGASV).AND.I_REGA.GE.2) THEN
C         ALLOCATE (REGASV(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
C         IF (IALLOC.NE.0) CALL NOALLO('REGASV','REGENP')
C     END IF
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      I_PART=4+N3LORD
C
C=======================================================================
C
C     IF (ISREGA.NE.1.OR.I_SLOW.EQ.1) THEN
C         XOLDEV=0.0
C     ELSE
C         XOLDEV=SLOWEV
C     END IF
C
C     XNEWEV=1.0-XOLDEV
C
C=======================================================================
C        INITIALIZING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
C     IF (I_REGA.GE.2) THEN
C
C         IF (ISREGA.NE.1) THEN
C
C             REGASV=C_ZERO
C         ELSE
C             REGASV=REGASV*XOLDEV
C
C         END IF
C
C     END IF
C
C=======================================================================
C        CALCULATING THE DIRECT TERM
C=======================================================================
C
      NXMAXX=NXMAXV(1)
      NYMAXX=NYMAXV(1)
      NZMAXX=NZMAXV(1)
C
      CALL DEFGOG(NXMAXX,NXHERM,1,REGWID,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
      CALL DEFGOG(NYMAXX,NYHERM,2,REGWID,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
      CALL DEFGOG(NZMAXX,NZHERM,3,REGWID,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
      IDENSI=0
C
      CALL GAUENE(ISIMPY,I_REGA,I_PART,IDENSI,1,1)
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE REGULARIZED
C        SKYRME FORCE
C=======================================================================
C
      HCEGSD=C_ZERO
      HCEGVD=C_ZERO
C
      DO INREGA=1,NUREGA
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE DIRECT TERM
C=======================================================================
C
            ICHARG=0
               JCHARG=1
C
               KARTEZ=0
C
               HCEGSD(INREGA)=
     *         HCEGSD(INREGA)+
     *         GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               DO KARTEZ=1,NDKART
C
                  HCEGVD(INREGA)=
     *            HCEGVD(INREGA)+
     *         GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
C           END DO
C        END DO
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE DIRECT TERM
C=======================================================================
C
C        IF (I_REGA.EQ.2.OR.I_REGA.EQ.3) THEN
C
C            DO ICHARG=0,NDISOS
C
C               DO IKET=1,LDBASE
C                  DO IBRA=1,LDBASE
C
C                     KARTEZ=0
C
C                     REGASV(IBRA,IKET,KARTEZ,ICHARG)
C    *               =REGASV(IBRA,IKET,KARTEZ,ICHARG)
C    *
C    *                   +CEG_SD(INREGA,ICHARG,  ICHARG)
C    *                   *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,  ICHARG)
C    *                                                           *XNEWEV
C    *                   +CEG_SD(INREGA,ICHARG,1-ICHARG)
C    *                   *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,1-ICHARG)
C    *                                                           *XNEWEV
C
C                     DO KARTEZ=1,NDKART
C
C                        REGASV(IBRA,IKET,KARTEZ,ICHARG)
C    *                  =REGASV(IBRA,IKET,KARTEZ,ICHARG)
C    *
C    *                      +CEG_VD(INREGA,ICHARG,  ICHARG)
C    *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,  ICHARG)
C    *                                                           *XNEWEV
C    *                      +CEG_VD(INREGA,ICHARG,1-ICHARG)
C    *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,1-ICHARG)
C    *                                                           *XNEWEV
C
C                     END DO
C
C                  END DO
C               END DO
C
C            END DO
C
C            ISREGA=1
C
C        END IF
C
      END DO
C
C=======================================================================
C        CALCULATING THE EXCHANGE TERM
C=======================================================================
C
      CALL EXCGOG(NXMAXX,
     *            GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                        GAUX41,GAUX42,GAUX43)
      CALL EXCGOG(NYMAXX,
     *            GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                        GAUY41,GAUY42,GAUY43)
      CALL EXCGOG(NZMAXX,
     *            GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                        GAUZ41,GAUZ42,GAUZ43)
C
      IDENSI=0
C
      CALL GAUENE(ISIMPY,I_REGA,I_PART,IDENSI,1,1)
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER TERMS THAT CONSTITUTE THE REGULARIZED
C        SKYRME FORCE
C=======================================================================
C
      HCEGSE=C_ZERO
      HCEGVE=C_ZERO
C
      DO INREGA=1,NUREGA
C
C=======================================================================
C        CALCULATING THE AVERAGE VALUES OF THE EXCHANGE TERM
C=======================================================================
C
            ICHARG=0
               JCHARG=1
C
               KARTEZ=0
C
               HCEGSE(INREGA)=
     *         HCEGSE(INREGA)+
     *                    GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               DO KARTEZ=1,NDKART
C
                  HCEGVE(INREGA)=
     *            HCEGVE(INREGA)+
     *                    GAUAVR(INREGA-1,KARTEZ,KARTEZ,ICHARG,JCHARG)/2
C
               END DO
C
C           END DO
C        END DO
C
C=======================================================================
C        CALCULATING THE MEAN FIELDS OF THE EXCHANGE TERM
C=======================================================================
C
C        IF (I_REGA.EQ.2.OR.I_REGA.EQ.4) THEN
C
C            DO ICHARG=0,NDISOS
C
C               DO IKET=1,LDBASE
C                  DO IBRA=1,LDBASE
C
C                     KARTEZ=0
C
C                     REGASV(IBRA,IKET,KARTEZ,ICHARG)
C    *               =REGASV(IBRA,IKET,KARTEZ,ICHARG)
C    *
C    *                   +CEG_SE(INREGA,ICHARG,  ICHARG)
C    *                   *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,  ICHARG)
C    *                                                           *XNEWEV
C    *                   +CEG_SE(INREGA,ICHARG,1-ICHARG)
C    *                   *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,1-ICHARG)
C    *                                                           *XNEWEV
C
C                     DO KARTEZ=1,NDKART
C
C                        REGASV(IBRA,IKET,KARTEZ,ICHARG)
C    *                  =REGASV(IBRA,IKET,KARTEZ,ICHARG)
C    *
C    *                      +CEG_VE(INREGA,ICHARG,  ICHARG)
C    *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,  ICHARG)
C    *                                                           *XNEWEV
C    *                      +CEG_VE(INREGA,ICHARG,1-ICHARG)
C    *                      *GAUFIL(INREGA-1,IBRA,IKET,KARTEZ,1-ICHARG)
C    *                                                           *XNEWEV
C
C                     END DO
C
C                  END DO
C               END DO
C
C            END DO
C
C            ISREGA=1
C
C        END IF
C
      END DO
C
C=======================================================================
C        CALCULATING THE TOTAL ENERGIES IN EACH REGULARIZATION ORDER
C=======================================================================
C
      DO INREGA=1,NUREGA
C
         FACTOR(INREGA)=(REGWID*SQRT(4.0D0*ATAN(1.00D0)))**3
     *                  *REGWID**(2*(INREGA-1))
C
      END DO
C
      HREGSD(1)=      HCEGSD(1)/FACTOR(1)
      HREGSD(2)=   -6*HCEGSD(1)/FACTOR(1)
     *             +4*HCEGSD(2)/FACTOR(2)
      HREGSD(3)=   60*HCEGSD(1)/FACTOR(1)
     *            -80*HCEGSD(2)/FACTOR(2)
     *            +16*HCEGSD(3)/FACTOR(3)
      HREGSD(4)= -840*HCEGSD(1)/FACTOR(1)
     *          +1680*HCEGSD(2)/FACTOR(2)
     *           -672*HCEGSD(3)/FACTOR(3)
     *            +64*HCEGSD(4)/FACTOR(4)
C
      HREGVD(1)=      HCEGVD(1)/FACTOR(1)
      HREGVD(2)=   -6*HCEGVD(1)/FACTOR(1)
     *             +4*HCEGVD(2)/FACTOR(2)
      HREGVD(3)=   60*HCEGVD(1)/FACTOR(1)
     *            -80*HCEGVD(2)/FACTOR(2)
     *            +16*HCEGVD(3)/FACTOR(3)
      HREGVD(4)= -840*HCEGVD(1)/FACTOR(1)
     *          +1680*HCEGVD(2)/FACTOR(2)
     *           -672*HCEGVD(3)/FACTOR(3)
     *            +64*HCEGVD(4)/FACTOR(4)
C
      HREGSE(1)=      HCEGSE(1)/FACTOR(1)
      HREGSE(2)=   -6*HCEGSE(1)/FACTOR(1)
     *             +4*HCEGSE(2)/FACTOR(2)
      HREGSE(3)=   60*HCEGSE(1)/FACTOR(1)
     *            -80*HCEGSE(2)/FACTOR(2)
     *            +16*HCEGSE(3)/FACTOR(3)
      HREGSE(4)= -840*HCEGSE(1)/FACTOR(1)
     *          +1680*HCEGSE(2)/FACTOR(2)
     *           -672*HCEGSE(3)/FACTOR(3)
     *            +64*HCEGSE(4)/FACTOR(4)
C
      HREGVE(1)=      HCEGVE(1)/FACTOR(1)
      HREGVE(2)=   -6*HCEGVE(1)/FACTOR(1)
     *             +4*HCEGVE(2)/FACTOR(2)
      HREGVE(3)=   60*HCEGVE(1)/FACTOR(1)
     *            -80*HCEGVE(2)/FACTOR(2)
     *            +16*HCEGVE(3)/FACTOR(3)
      HREGVE(4)= -840*HCEGVE(1)/FACTOR(1)
     *          +1680*HCEGVE(2)/FACTOR(2)
     *           -672*HCEGVE(3)/FACTOR(3)
     *            +64*HCEGVE(4)/FACTOR(4)
C
      EREGSD=C_ZERO
      EREGVD=C_ZERO
      EREGSE=C_ZERO
      EREGVE=C_ZERO
C
      DO INREGA=1,NUREGA
C
         EREGSD=EREGSD+
     *          REG_SD(INREGA)*
     *          HREGSD(INREGA)
C
         EREGVD=EREGVD+
     *          REG_VD(INREGA)*
     *          HREGVD(INREGA)
C
         EREGSE=EREGSE+
     *          REG_SE(INREGA)*
     *          HREGSE(INREGA)
C
         EREGVE=EREGVE+
     *          REG_VE(INREGA)*
     *          HREGVE(INREGA)
C
      END DO
C
C=======================================================================
C        CALCULATING THE TOTAL DIRECT AND EXCHANGE ENERGIES
C=======================================================================
C
      EREGDT=REAL(EREGSD+EREGVD)
      EREGET=REAL(EREGSE+EREGVE)
C
      EKEREG=+EREGSD+EREGVD+EREGSE+EREGVE
C
C=======================================================================
C
      CALL CPUTIM('REGENP',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PARREG(I_REGA,N3LORD)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          ILORDE(10),NLORDE(10)
C
      COMMON
     *       /GOGFOR/ GOGSTR(NDGOGA,NDFORC),GOGWID(NDGOGA),NUGOGA
      COMMON
     *       /REGPAR/ REGWID
      COMMON
     *       /REGBIN/ REGBCC(NDREGA,NDFORC),IREREG
      COMMON
     *       /REGVIN/ REGVCC(NDREGA,NDFORC)
      COMMON
     *       /REGTIN/ REGTCC(NDREGA,NDFORC)
      COMMON
     *       /REGINT/ CEGSTR(NDREGA,NDFORC)
      COMMON
     *       /REGFOR/ REGSTR(NDREGA,NDFORC)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       ILORDE  /0,2,2,4,4,4,6,6,6,6/,
     *       NLORDE  /1,1,2,1,2,3,1,2,3,4/
C
C=======================================================================
C           HERE IS THE PARAMETER SET FROM
C           Francesco.120419.fit_interaction_regularized_delta_4.pdf
C=======================================================================
C
C     DATA
C    *      ((REGSTR(INREGA,INFORC),INFORC=1,NDFORC),
C    *                              INREGA=1,2)
C    *
C    *     /-2753.40D0,  1204.52D0, -2317.53D0,  860.526D0,
C    *       443.443D0, -433.598D0,  535.098D0, -511.666D0/
CC
C     DATA
C    *      REGWID /0.844098D0/
C
C=======================================================================
C           HERE IS THE PARAMETER SET FROM Francesco
C           WITH RANGE 0.840
C=======================================================================
C
C       DATA
C     *      ((REGSTR(INREGA,INFORC),INFORC=1,NDFORC),
C     *                              INREGA=1,2)
C     *
C     *     /-2713.48D0,  1187.06D0, -2283.94D0,  848.052D0,
C     *      437.015D0, -427.313D0,  527.341D0, -504.249D0/
CC
C      DATA
C     *      REGWID /0.840000D0/
C
C=======================================================================
C           HERE IS THE PARAMETER SET FROM Francesco
C           WITH RANGE 0.845
C=======================================================================
C
C      DATA
C     *      ((REGSTR(INREGA,INFORC),INFORC=1,NDFORC),
C     *                              INREGA=1,2)
C     *
C     *     /-2762.23D0,  1208.38D0, -2324.97D0,  863.286D0,
C     *       444.866D0, -434.989D0,  536.814D0, -513.307D0/
C
C      DATA
C     *      REGWID /0.845000D0/
C
C=======================================================================
C           HERE IS THE PARAMETER SET FROM Francesco
C           WITH RANGE 0.850
C=======================================================================
C
C      DATA
C     *      ((REGSTR(INREGA,INFORC),INFORC=1,NDFORC),
C     *                              INREGA=1,2)
C     *
C     *     /-2811.55D0,  1229.96D0, -2366.48D0,  878.701D0,
C     *       452.81D0, -442.756D0,  546.400D0, -522.473D0/
C
C      DATA
C     *      REGWID /0.850000D0/
C
C=======================================================================
C           HERE IS THE PARAMETER SET FROM Francesco
C           WITH RANGE 0.855
C=======================================================================
C
C      DATA
C     *      ((REGSTR(INREGA,INFORC),INFORC=1,NDFORC),
C     *                              INREGA=1,2)
C     *
C     *     /-2861.46D0,  1251.80D0, -2408.49D0,  894.299D0,
C     *       460.847D0, -450.616D0,  556.099D0, -531.748D0/
C
C      DATA
C     *      REGWID /0.855000D0/
C
C=======================================================================
C           HERE IS THE PARAMETER SET FROM Francesco
C           WITH RANGE 0.860
C=======================================================================
C
C      DATA
C     *      ((REGSTR(INREGA,INFORC),INFORC=1,NDFORC),
C     *                              INREGA=1,2)
C     *
C     *     /-2911.96D0,  1273.89D0, -2450.99D0,  910.08D0,
C     *       468.98D0, -458.568D0,  565.913D0, -541.131D0/
C
C      DATA
C     *      REGWID /0.860000D0/
C
C=======================================================================
C
      FACTOR=(REGWID*SQRT(4.0D0*ATAN(1.00D0)))**3
C
      IF (IREREG.EQ.0) THEN
C
C=======================================================================
C           HERE WE CALCULATE THE REGULARIZED-SKYRME "B" PARAMETERS
C           FROM THE GOGNY PARAMETERS (GOGSTR).
C=======================================================================
C
          DO INFORC=1,NDFORC
C
             GMOME0 = (GOGSTR(1,INFORC)*GOGWID(1)**3
     *                +GOGSTR(2,INFORC)*GOGWID(2)**3)/REGWID**3
             GMOME2 = (GOGSTR(1,INFORC)*GOGWID(1)**5
     *                +GOGSTR(2,INFORC)*GOGWID(2)**5)/REGWID**5
             GMOME4 = (GOGSTR(1,INFORC)*GOGWID(1)**7
     *                +GOGSTR(2,INFORC)*GOGWID(2)**7)/REGWID**7
             GMOME6 = (GOGSTR(1,INFORC)*GOGWID(1)**9
     *                +GOGSTR(2,INFORC)*GOGWID(2)**9)/REGWID**9
C
             REGSTR(1,INFORC)=  GMOME0                       *FACTOR
             REGSTR(2,INFORC)=-(GMOME0-  GMOME2)             *FACTOR/4
             REGSTR(3,INFORC)= (GMOME0-2*GMOME2+  GMOME4)    *FACTOR/32
             REGSTR(4,INFORC)=-(GMOME0-3*GMOME2+3*GMOME4- GMOME6)
     *                                                       *FACTOR/384
C
             IF (N3LORD.LT.3) REGSTR(4,INFORC)=0.0D0
             IF (N3LORD.LT.2) REGSTR(3,INFORC)=0.0D0
             IF (N3LORD.LT.1) REGSTR(2,INFORC)=0.0D0
C
          END DO
C
          DO INREGA=1,4
                                    FACTO2= REGWID**(2*INREGA-2)
                                    FACTO2= FACTO2*2**(INREGA-1)
             IF (MOD(INREGA,2).EQ.0)FACTO2=-FACTO2
C
             DO INFORC=1,NDFORC
C
                REGBCC(INREGA,INFORC)=REGSTR(INREGA,INFORC)
                REGVCC(INREGA,INFORC)=REGBCC(INREGA,INFORC)*FACTO2
C
             END DO
          END DO
C
      ELSE
C
C=======================================================================
C           HERE WE COPY THE REGULARIZED-SKYRME PARAMETERS
C           FROM THE INPUT DATA.
C=======================================================================
C
          IF (IREREG.GT.NDREGA) STOP ' INCREASE NDREGA IN PARREG'
C
          REGSTR=0.0D0
C
          IF (N3LORD.GE.0) THEN
C
              DO INFORC=1,NDFORC
                 DO INREGA=1,IREREG
C
                    REGSTR(INREGA,INFORC)=REGBCC(INREGA,INFORC)
C
                 END DO
              END DO
          ELSE
              DO INFORC=1,NDFORC
                 DO INREGA=1,IREREG
C
                    REGSTR(INREGA,INFORC)=REGVCC(INREGA,INFORC)/FACTOR
C
                 END DO
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C           HERE WE RECALCULATE THE "C" PARAMETERS (CEGSTR) FROM THE
C                REGULARIZED-SKYRME "B" PARAMETERS (REGSTR).
C           NOTE THAT THE WIDTH IS INCLUDED INTO THE "C" PARAMETERS.
C=======================================================================
C
      DO INFORC=1,NDFORC
C
         CEGSTR(1,INFORC)=    (REGSTR(1,INFORC)
     *                     -6*(REGSTR(2,INFORC)
     *                    -10*(REGSTR(3,INFORC)
     *                    -14*(REGSTR(4,INFORC)))))/FACTOR
         CEGSTR(2,INFORC)=  4*(REGSTR(2,INFORC)
     *                    -20*(REGSTR(3,INFORC)
     *                    -21*(REGSTR(4,INFORC)))) /FACTOR/REGWID**2
         CEGSTR(3,INFORC)= 16*(REGSTR(3,INFORC)
     *                    -42*(REGSTR(4,INFORC)))  /FACTOR/REGWID**4
         CEGSTR(4,INFORC)= 64*(REGSTR(4,INFORC))   /FACTOR/REGWID**6
C
C        CEGSTR(2,INFORC)=CEGSTR(1,INFORC)
C        CEGSTR(2,INFORC)=0.0D0
C
C        print *,inforc,regwid,REGSTR(1,INFORC),REGSTR(2,INFORC)
C
C        print *
C        do iiii=0,30
C           rrrr=iiii*0.1d0
C           print *,inforc,iiii,(CEGSTR(1,INFORC)
C    *                          +CEGSTR(2,INFORC)*rrrr**2)*
C    *                           exp(-(rrrr/REGWID)**2)
C        end do
C
      END DO
C
C=======================================================================
C         PRINTING THE REGULARIZED FORCE PARAMETERS
C=======================================================================
C
      IF (I_REGA.GT.0) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,      1H*,77X,1H*,/,
     *          1H*,7X,''REGULARIZED FORCE DEFINITION '',
     *                 ''FOR THE SCALE (WIDTH) ='',F9.5,1X,
     *                 ''FM'',6X,1H*)')
     *    REGWID
C
          IF (IREREG.EQ.0) THEN
C
              WRITE(NFIPRI,'(
     *          1H*,9X,''THE PARAMETERS HAVE BEEN '',
     *                 ''DERIVED FROM THE GOGNY FORCE ABOVE'',9X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                    79(1H*),/,                     1H*,77X,1H*)')
C
              NUREGA=N3LORD+1
C
              WRITE(NFIPRI,'(
     *            1H*,  '' W'',2I1,''='',F13.6,''   B'',2I1,''='',F12.6,
     *                ''   H'',2I1,''='',F13.6,''   M'',2I1,''='',F12.6,
     *                                                         1X,1H*)')
     *
     *                 ((2*(INREGA-1),1,
     *                            REGVCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                                 ,INREGA=1,NUREGA)
C
              WRITE(NFIPRI,'(1H*,77X,1H*)')
C
              WRITE(NFIPRI,'(
     *            1H*,  '' B'',I1,''1='',F13.6,''   B'',I1,''2='',F12.6,
     *                ''   B'',I1,''3='',F13.6,''   B'',I1,''4='',F12.6,
     *                                                         1X,1H*)')
C
     *
     *             ((2*(INREGA-1),REGBCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                                 ,INREGA=1,NUREGA)
C
              WRITE(NFIPRI,'(1H*,77X,1H*)')
C
                  WRITE(NFIPRI,'(
     *            1H*,  '' C'',I1,''1='',F13.6,''   C'',I1,''2='',F12.6,
     *                ''   C'',I1,''3='',F13.6,''   C'',I1,''4='',F12.6,
     *                                                         1X,1H*)')
     *
     *          ((2*(INREGA-1),CEGSTR(INREGA,INFORC),INFORC=1,NDFORC)
     *                                              ,INREGA=1,NUREGA)
C
              WRITE(NFIPRI,'(1H*,77X,1H*)')
C
          ELSE
C
              IF (N3LORD.GE.0) THEN
C
                  WRITE(NFIPRI,'(1H*,2X,
     *                 ''THE T_1=-T_2 PARAMETERS HAVE BEEN READ '',
     *                 ''FROM THE INPUT FILE UP TO ORDER'',I2,3X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                    79(1H*),/,                     1H*,77X,1H*)')
     *            2*(IREREG-1)
C
                  NUREGA=IREREG
C
                  WRITE(NFIPRI,'(
     *            1H*,  '' T'',2I1,''='',F13.6,''   X'',2I1,''='',F12.6,
     *                ''   Y'',2I1,''='',F13.6,''   Z'',2I1,''='',F12.6,
     *                                                         1X,1H*)')
     *
     *                 ((2*(INREGA-1),1,
     *                            REGTCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                                 ,INREGA=1,NUREGA)
C
                  WRITE(NFIPRI,'(1H*,77X,1H*)')
C
                  WRITE(NFIPRI,'(
     *            1H*,  '' W'',2I1,''='',F13.6,''   B'',2I1,''='',F12.6,
     *                ''   H'',2I1,''='',F13.6,''   M'',2I1,''='',F12.6,
     *                                                         1X,1H*)')
     *
     *                 ((2*(INREGA-1),1,
     *                            REGVCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                                 ,INREGA=1,NUREGA)
C
                  WRITE(NFIPRI,'(1H*,77X,1H*)')
C
                  WRITE(NFIPRI,'(
     *            1H*,  '' B'',I1,''1='',F13.6,''   B'',I1,''2='',F12.6,
     *                ''   B'',I1,''3='',F13.6,''   B'',I1,''4='',F12.6,
     *                                                         1X,1H*)')
C
     *
     *             ((2*(INREGA-1),REGBCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                                 ,INREGA=1,NUREGA)
C
                  WRITE(NFIPRI,'(1H*,77X,1H*)')
C
                  WRITE(NFIPRI,'(
     *            1H*,  '' C'',I1,''1='',F13.6,''   C'',I1,''2='',F12.6,
     *                ''   C'',I1,''3='',F13.6,''   C'',I1,''4='',F12.6,
     *                                                         1X,1H*)')
     *
     *             ((2*(INREGA-1),CEGSTR(INREGA,INFORC),INFORC=1,NDFORC)
     *                                                 ,INREGA=1,NUREGA)
C
                  WRITE(NFIPRI,'(1H*,77X,1H*)')
C
              ELSE
C
                  WRITE(NFIPRI,'(1H*,2X,
     *                 ''THE T_1<>-T_2 PARAMETERS HAVE BEEN READ '',
     *                 ''FROM THE INPUT FILE UP TO ORDER'',I2,2X,1H*,/,
     *                                                   1H*,77X,1H*,/,
     *                    79(1H*),/,                     1H*,77X,1H*)')
     *            ILORDE(IREREG)
C
                  NUREGA=IREREG
C
                  WRITE(NFIPRI,'(
     *            1H*,  '' T'',2I1,''='',F13.6,''   X'',2I1,''='',F12.6,
     *                ''   Y'',2I1,''='',F13.6,''   Z'',2I1,''='',F12.6,
     *                                                         1X,1H*)')
     *
     *                  ((ILORDE(INREGA),NLORDE(INREGA),
     *                            REGTCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                                 ,INREGA=1,NUREGA)
C
                  WRITE(NFIPRI,'(1H*,77X,1H*)')
C
                  WRITE(NFIPRI,'(
     *            1H*,  '' W'',2I1,''='',F13.6,''   B'',2I1,''='',F12.6,
     *                ''   H'',2I1,''='',F13.6,''   M'',2I1,''='',F12.6,
     *                                                         1X,1H*)')
     *
     *                 ((ILORDE(INREGA),NLORDE(INREGA),
     *                            REGVCC(INREGA,INFORC),INFORC=1,NDFORC)
     *                                                 ,INREGA=1,NUREGA)
C
                  WRITE(NFIPRI,'(1H*,77X,1H*)')
C
              END IF
C
          END IF
C
          WRITE(NFIPRI,'(79(1H*),/)')
C
      END IF
C
      IPRINT=0
      IF (IPRINT.EQ.1.AND.I_REGA.GT.0.AND.N3LORD.GE.0) THEN
C
          WRITE(NFIPRI,'(''  WIDTH'',10X
     *             ,16(''    B'',2I1,10X)
     *             ,16(''    C'',2I1,10X))')
     *            ((2*(INREGA-1),INFORC,INFORC=1,NDFORC)
     *                                 ,INREGA=1,4)
     *           ,((2*(INREGA-1),INFORC,INFORC=1,NDFORC)
     *                                 ,INREGA=1,4)
          WRITE(NFIPRI,'(33D17.9)') REGWID
     *         ,((REGSTR(INREGA,INFORC),INFORC=1,NDFORC)
     *                                 ,INREGA=1,4)
     *         ,((CEGSTR(INREGA,INFORC),INFORC=1,NDFORC)
     *                                 ,INREGA=1,4)
C
          STOP ' THE CODE ONLY PRINTS THE COUPLING CONSTANTS'
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PARSEP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      DIMENSION
     *          ILORDE(10),NLORDE(10)
C
      COMMON
     *       /SEPPAR/ SEPWID(NDSEGA),SEPGAU(NDSEGA),NUSEGA
      COMMON
     *       /SEPVIN/ SEPVCC(NDSEPA,NDFORC),IRESEP
      COMMON
     *       /SEPTIN/ SEPTCC(NDSEPA,NDFORC)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       ILORDE  /0,2,2,4,4,4,6,6,6,6/,
     *       NLORDE  /1,1,2,1,2,3,1,2,3,4/
C
C=======================================================================
C         PRINTING THE SEPARABLE FORCE PARAMETERS
C=======================================================================
C
C=======================================================================
C           HERE WE COPY THE SEPARABLE PARAMETERS
C           FROM THE INPUT DATA.
C=======================================================================
C
      IF (IRESEP.GT.NDSEPA) STOP ' INCREASE NDSEPA IN PARSEP'
C
      WRITE(NFIPRI,'(79(1H*),/,      1H*,77X,1H*,/,
     *      1H*,1X,''SEPARABLE FORCE DEFINED BY THE EXPANSION '',
     *             ''OF THE FORMFACTORS ON'',I3,1X,
     *             ''GAUSSIANS'',1X,1H*)')
     *      NUSEGA
C
      WRITE(NFIPRI,'(1H*,77X,1H*)')
      WRITE(NFIPRI,'(79(1H*))')
C
      WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *      1H*,1X,''NO        WIDTH         STRENGTH     '',
     *      1H*,1X,''NO        WIDTH         STRENGTH     '',1H*,/,
     *      1H*,1X,''--        -----         --------     '',
     *      1H*,1X,''--        -----         --------     '',1H*)')
C
      DO MUSEGA=1,NUSEGA/2
C
         WRITE(NFIPRI,'(1H*,I3,D17.7,D17.7,1X,1H*,
     *                      I3,D17.7,D17.7,1X,1H*)')
     *
     *   2*MUSEGA-1,SEPWID(2*MUSEGA-1),SEPGAU(2*MUSEGA-1),
     *   2*MUSEGA  ,SEPWID(2*MUSEGA  ),SEPGAU(2*MUSEGA  )
C
      END DO
C
      IF (MOD(NUSEGA,2).EQ.1) THEN
C
         WRITE(NFIPRI,'(1H*,I3,D17.7,D17.7,1X,1H*,
     *                          1X,36(1H-),1X,1H*)')
     *   NUSEGA,SEPWID(NUSEGA),SEPGAU(NUSEGA)
C
      END IF
C
      WRITE(NFIPRI,'(1H*,77X,1H*)')
      WRITE(NFIPRI,'(79(1H*))')
      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(1H*,2X,
     *     ''THE SEPARABLE PARAMETERS HAVE BEEN READ '',
     *     ''FROM THE INPUT FILE UP TO ORDER'',I2,2X,1H*,/,
     *                                       1H*,77X,1H*,/,
     *        79(1H*),/,                     1H*,77X,1H*)')
     *     ILORDE(IRESEP)
C
      NUSEPA=IRESEP
C
      WRITE(NFIPRI,'(
     *1H*,  '' T'',2I1,''='',F13.6,''  X'',2I1,''='',F13.6,
     *    ''   Y'',2I1,''='',F13.6,''  Z'',2I1,''='',F13.6,
     *                                            1X,1H*)')
     *
     *      ((ILORDE(INSEPA),NLORDE(INSEPA),
     *                SEPTCC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                                     ,INSEPA=1,NUSEPA)
C
      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(
     *1H*,  '' W'',2I1,''='',F13.6,''  B'',2I1,''='',F13.6,
     *    ''   H'',2I1,''='',F13.6,''  M'',2I1,''='',F13.6,
     *                                            1X,1H*)')
     *
     *     ((ILORDE(INSEPA),NLORDE(INSEPA),
     *                SEPVCC(INSEPA,INFORC),INFORC=1,NDFORC)
     *                                     ,INSEPA=1,NUSEPA)
C
      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
      IPRINT=0
      IF (IPRINT.EQ.1) THEN
C
          STOP ' THE CODE ONLY PRINTS THE COUPLING CONSTANTS'
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PARFST
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /FSTFOR/ FSOSTR(NDGOGA,NDFORC),
     *                FTOSTR(NDGOGA,NDFORC),
     *                FTESTR(NDGOGA,NDFORC),FSTWID(NDGOGA)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         PRINTING THE FINITE-RANGE SPIN-ORBIT AND TENSOR PARAMETERS
C=======================================================================
C
      NREFST=1
C
      WRITE(NFIPRI,'(79(1H*),/,      1H*,77X,1H*,/,
     *      1H*,1X,''FINITE-RANGE S-O & TEN FORCE DEFINITION '',
     *             ''FOR THE SCALE (WIDTH) ='',F9.5,1X,
     *             ''FM'',1X,1H*,/,1H*,1X,
     *             ''READ FROM THE INPUT FILE UP TO ORDER'',
     *                                    I2,38X,1H*,/,
     *                                   1H*,77X,1H*,/,
     *    79(1H*),/,                     1H*,77X,1H*)')
     *    FSTWID(NREFST),NREFST
C
      WRITE(NFIPRI,'(
     *1H*,'' W'',A2,''='',F13.6,''  B'',A2,''='',F13.6,
     *  ''   H'',A2,''='',F13.6,''  M'',A2,''='',F13.6,
     *                                            1X,1H*)')
     *
     *   (('SO',FSOSTR(INFSTA,INFORC),INFORC=1,NDFORC),INFSTA=1,NREFST),
     *   (('TO',FTOSTR(INFSTA,INFORC),INFORC=1,NDFORC),INFSTA=1,NREFST),
     *   (('TE',FTESTR(INFSTA,INFORC),INFORC=1,NDFORC),INFSTA=1,NREFST)
C
      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
      IPRINT=0
      IF (IPRINT.EQ.1) THEN
C
          STOP ' THE CODE ONLY PRINTS THE COUPLING CONSTANTS'
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GOGPAI(I_SLOW,SLOWPA,ISGOGP,IGOGPA,ISIMPY,
     *                                       IN_FIX,IZ_FIX)
C=======================================================================
      USE GAUSTO
      USE GOGSTO
      USE GOGKAP
      USE MAD_PP
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          EGOGSP,EGOGVP
      COMPLEX
     *          C_ZERO,C_UNIT,CMATRI,H_PAIR,DELTAX
C=======================================================================
      ALLOCATABLE :: CMATRI(:,:),H_PAIR(:,:)
C=======================================================================
C
      DIMENSION
     *          GOG_SP(NDGOGA,0:NDISOS,0:NDISOS),
     *          GOG_VP(NDGOGA,0:NDISOS,0:NDISOS)
C
      COMMON
     *       /GOGFOR/ GOGSTR(NDGOGA,NDFORC),GOGWID(NDGOGA),NUGOGA
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /PN_GOG/ EGOGSP(0:NDISOS),EGOGVP(0:NDISOS)
     *
     *       /PGOGTT/ EGOGPT
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('GOGPAI',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES:
C        1) THE AVERAGE PAIRING ENERGY OF THE FINITE-RANGE GOGNY
C           INTERACTION                     (FOR IGOGPA>0)
C        2) THE CORRESPONDING PAIRING FIELD (FOR IGOGPA=2)
C=======================================================================
C
C=======================================================================
C           HERE ARE THE NN, NP, PP, AND PN GOGNY STRENGTHS
C           DERIVED IN THE NOTES 77-B
C=======================================================================
C
      CALL PACHAN(GOGSTR,GOG_SP,GOG_VP,NDGOGA,NUGOGA)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(GOGCHI).AND.IGOGPA.GE.2) THEN
          ALLOCATE (GOGCHI(NDBASE,NDBASE,0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGCHI','GOGPAI')
      END IF
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
      I_PART=3
C
C=======================================================================
C
      IF (ISGOGP.NE.1.OR.I_SLOW.EQ.1) THEN
          XOLDEV=0.0D0
      ELSE
          XOLDEV=SLOWPA
      END IF
C
      XNEWEV=1.0D0-XOLDEV
C
C=======================================================================
C        ZEROING THE ARRAYS THAT WILL COLLECT THE CONTRIBUTIONS COMING
C        FROM INDIVIDUAL GAUSSIANS
C=======================================================================
C
      EGOGSP(:)=C_ZERO
      EGOGVP(:)=C_ZERO
C
C=======================================================================
C        INITIALIZING ARRAYS OF PAIRING FIELDS
C=======================================================================
C
      IF (IGOGPA.GE.2) THEN
C
          IF (ISGOGP.NE.1) THEN
              GOGCHI(:,:,:,:)=C_ZERO
          ELSE
              GOGCHI(:,:,:,:)=GOGCHI(:,:,:,:)*XOLDEV
          END IF
C
      END IF
C
C=======================================================================
C        HERE BEGINS THE LOOP OVER GAUSSIANS THAT CONSTITUTE THE GOGNY
C        FORCE
C=======================================================================
C
      IDENSI=1
C
      NXMAXX=NXMAXV(1)
      NYMAXX=NYMAXV(1)
      NZMAXX=NZMAXV(1)
C
      DO INGOGA=1,NUGOGA
C
C=======================================================================
C        CALCULATING THE PAIRING TERM
C=======================================================================
C
         GOGWI0=GOGWID(INGOGA)
C
         CALL DEFGOG(NXMAXX,NXHERM,1,GOGWI0,
     *               GAU_X0,GAU_X1,GAU_X2,GAU_X4,GAU_X6,GAUX21,GAUX22,
     *                                           GAUX41,GAUX42,GAUX43)
         CALL DEFGOG(NYMAXX,NYHERM,2,GOGWI0,
     *               GAU_Y0,GAU_Y1,GAU_Y2,GAU_Y4,GAU_Y6,GAUY21,GAUY22,
     *                                           GAUY41,GAUY42,GAUY43)
         CALL DEFGOG(NZMAXX,NZHERM,3,GOGWI0,
     *               GAU_Z0,GAU_Z1,GAU_Z2,GAU_Z4,GAU_Z6,GAUZ21,GAUZ22,
     *                                           GAUZ41,GAUZ42,GAUZ43)
C
         CALL GAUOPT(ISIMPY,IGOGPA,I_PART,IDENSI)
C
C=======================================================================
C        CALCULATING THE AVERAGE PAIRING ENERGY
C=======================================================================
C
         DO ICHARG=0,NDISOS
C
            KARTEZ=0
C
            EGOGSP(ICHARG)=EGOGSP(ICHARG)
     *                    +GOG_SP(INGOGA,ICHARG,ICHARG)
     *           *GAUAVR(0,KARTEZ,KARTEZ,ICHARG,ICHARG)
C
            DO KARTEZ=1,NDKART
C
               EGOGVP(ICHARG)=EGOGVP(ICHARG)
     *                       +GOG_VP(INGOGA,ICHARG,ICHARG)
     *              *GAUAVR(0,KARTEZ,KARTEZ,ICHARG,ICHARG)
C
            END DO
C
         END DO
C
C=======================================================================
C        CALCULATING THE CONTRIBUTION TO THE PAIRING FIELD
C=======================================================================
C
         IF (IGOGPA.EQ.2) THEN
C
             DO ICHARG=0,NDISOS
C
                DO IKET=1,LDBASE
                   DO IBRA=1,LDBASE
C
                      KARTEZ=0
C
                      GOGCHI(IBRA,IKET,KARTEZ,ICHARG)
     *               =GOGCHI(IBRA,IKET,KARTEZ,ICHARG)
     *
     *               +GOG_SP(INGOGA,ICHARG,ICHARG)
     *               *GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)*XNEWEV
C
                      DO KARTEZ=1,NDKART
C
                         GOGCHI(IBRA,IKET,KARTEZ,ICHARG)
     *                  =GOGCHI(IBRA,IKET,KARTEZ,ICHARG)
     *
     *                  +GOG_VP(INGOGA,ICHARG,ICHARG)
     *                  *GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)*XNEWEV
C
                      END DO
C
                   END DO
                END DO
C
             END DO
C
             ISGOGP=1
C
         END IF
C
      END DO
C
C=======================================================================
C        CALCULATING THE TOTAL GOGNY PAIRING ENERGY
C=======================================================================
C
      EGOGPT=0.0D0
      DO ICHARG=0,NDISOS
         EGOGPT=EGOGPT+REAL(EGOGSP(ICHARG)+EGOGVP(ICHARG))
      END DO
C
      IF (IGOGPA.GE.2) THEN
C
C=======================================================================
C        CALCULATING THE PAIRING GAPS FROM THE GOGNY FORCE
C=======================================================================
C             ATTENTION! DEFINITION OF THE  PAIRING  GAP  BELOW  IMPLIES
C                        DEPENDENCE   ON   THE   GAUGE   TRANSFORMATION.
C                        THEREFORE, ONLY  ITS  ABSOLUTE  VALUE  MATTERS.
C                        THIS HAS BEEN IMPLEMENTED IN VERSION (2.89B) ON
C                        12.03.2019.
C=======================================================================
C
          DO ICHARG=0,NDISOS
C
             ALLOCATE(H_PAIR(1:NDBASE,1:NDBASE))
             ALLOCATE(CMATRI(1:NDBASE,1:NDBASE))
C
             H_PAIR(:,:)=C_ZERO
             DO KARTEZ=0,NDKART
                H_PAIR(:,:)=H_PAIR(:,:)+GOGCHI(:,:,KARTEZ,ICHARG)
             END DO
C
             CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                          C_UNIT,H_PAIR,NDBASE,
     *                   DEN_PP(:,:,0,ICHARG),NDBASE,
     *                          C_ZERO,CMATRI,NDBASE)
C
             DELTAX=C_ZERO
C
             DO I=1,LDBASE
                DELTAX=DELTAX+CMATRI(I,I)
             END DO
C
             CALL ZGEMM('T','N',LDBASE,LDBASE,LDBASE,
     *                          C_UNIT,H_PAIR,NDBASE,
     *                   DEN_PP(:,:,1,ICHARG),NDBASE,
     *                          C_ZERO,CMATRI,NDBASE)
C
             DO I=1,LDBASE
                DELTAX=DELTAX+CMATRI(I,I)
             END DO
C
             IF (ICHARG.EQ.0) DELTAN=DELTAN+ABS(DELTAX)/IN_FIX
             IF (ICHARG.EQ.1) DELTAP=DELTAP+ABS(DELTAX)/IZ_FIX
C
             DEALLOCATE(H_PAIR,CMATRI)
C
          END DO
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('GOGPAI',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GAUENE(ISIMPY,I_FIEL,I_PART,IDENSI,LTWCEN,ITWCEN)
C=======================================================================
      USE MAD_PP
      USE MAD_PM
      USE MAP_PP
      USE MAP_PM
      USE GAUSTO
      USE TWCEPP
      USE TWCEPM
      USE TBCSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          TERT41,TERT42,TERT43
      COMPLEX
     *          E_HELP(0:NDKART,0:NDISOS)
      COMPLEX
     *          D_HELP(0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS)
      COMPLEX
     *          X_HE00(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE10(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE01(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE20(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE02(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE40(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE04(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE22(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE60(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE06(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE24(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE42(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE03(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE30(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE05(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE50(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE11(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE12(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE21(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS)
C
      COMPLEX
C    *          X_0000(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_0001(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_0010(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_0002(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_0011(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0020(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_0100(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_0101(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_0110(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_1000(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_1001(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1010(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_0200(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
C    *          X_1100(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_2000(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS)
C
      COMPLEX
     *          X_0000(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0001(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0002(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0003(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0010(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0011(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0012(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0100(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0101(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0102(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0110(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0111(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0112(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0200(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0201(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0210(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0211(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0300(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_0310(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1000(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1001(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1002(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1003(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1100(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1101(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1102(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1200(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_1201(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS)
C
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL0
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL1
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL2
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL3
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL4
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL5
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL6
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL7
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL8
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL9
C
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HE00
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HE01
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HE02
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HE03
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HE10
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HE11
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HE12
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HE20
C
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE00
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE10
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE01
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE20
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE02
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE40
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE04
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE22
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE60
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE06
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE24
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE42
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE03
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE30
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE05
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE50
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE11
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE12
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE21
C
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0000
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0001
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0010
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0002
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0011
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0020
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0100
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0101
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0110
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1000
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1001
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1010
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0200
C     COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1100
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_2000
C
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0000
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0001
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0002
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0003
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0010
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0011
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0012
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0100
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0101
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0102
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0110
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0111
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0112
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0200
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0201
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0210
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0211
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0300
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_0310
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1000
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1001
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1002
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1003
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1100
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1101
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1102
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1200
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_1201
C
C=======================================================================
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /B_PHAS/ JPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
C=======================================================================
C        ATTENTION: ARRAYS TBC.4. BELOW ARE DUMMY ARRAYS KEPT  ONLY  FOR
C                   COMPATIBILITY WITH THE COMMON "GAUSIN".
C=======================================================================
      COMMON
     *       /TBCSIN/ TBC0X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC0X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC0X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC0X3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Y3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC0Z3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC1X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC1X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBC1X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBC1Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBCX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBCX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                TBCX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                TBCZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /FSTSIN/ FSTX00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                FSTX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                FSTZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
C
C=======================================================================
C
      CALL CPUTIM('GAUENE',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE AVERAGE ENERGIES AND FIELDS
C        CORRESPONDING TO  THE  FINITE-RANGE  GAUSSIAN  INTERACTION
C=======================================================================
C        THE SUBROUTINE CAN PERFORM CALCULATIONS BY ASSUMING  (IPAXYZ=1)
C        OR NOT ASSUMING (IPAXYZ=0) THAT THE FORMAFACTORS  DELIVERED  BY
C        "DEFGOG" CONSERVE PARITIES IN ALL  THREE  CARTESIAN  DIRECTIONS
C        SIMULTANEOUSLY.
C=======================================================================
C        ATTENTION:
C        BY CONSERVED PARITY WE MEAN EVEN PARITY. THE  FORMFACTORS  THAT
C        ARE PARITY ODD IN SOME CARTESIAN  DIRECTIONS  AND  PARITY  EVEN
C        IN OTHER CARTESIAN DIRECTIONS MUST BE TREATED AS PARITY BROKEN.
C=======================================================================
C        ATTENTION:
C        FOR LOOPS WHERE I_PART IS KNOWN,  THE  PARITY  CONSERVATION  OR
C        NONCONSERVATION IS HARDWIRED AND THE  "IPAXYZ"  SWITCH  IS  NOT
C        UNUSED, SEE SWITCH "I_JUMP"  FOR  LOOPS  WHERE  IT  IS  ASSUMED
C        CONSERVED.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C
      LIMSET=0
      I_JUMP=2
C
C=======================================================================
C        CALCULATION FOR THE YUKAWA INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.0) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=0
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE COULOMB EXCHANGE INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.1) THEN
C
          KARLIM=NDKART
          ICHLIM=NDISOS
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE COULOMB DIRECT INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.2) THEN
C
          KARLIM=0
          ICHLIM=NDISOS
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE GOGNY INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.3) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE REGULARIZED SKYRME INTERACTION T2=-T1
C=======================================================================
C
      IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE REGULARIZED SKYRME OR SEPARABLE INTERACTION
C        (PSEUDOPOTENTIAL)
C=======================================================================
C
      IF (I_PART.GE.8.AND.I_PART.LE.9) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
C=======================================================================
C         ATTENTION: SOME ELEMENTS OF THE N3LORD=-3 (I_PART=10) CASE ARE
C                    ALREADY PROGRAMMED, BUT THE MAIN WORK IS  N O T YET
C                    DONE.
C=======================================================================
C
      END IF
C
C=======================================================================
C         CALCULATION OF THE  INTRINSIC  PART  OF  THE  TWO-BODY-CURRENT
C         CONTRIBUTION  TO  THE  MAGNETIC  MOMENT.   IN   THE   RELATIVE
C         COORDINATES, PARITY IS EVEN OR ODD DEPENDING ON THE  CARTESIAN
C         DIRECTION, IPAXYZ=0.
C=======================================================================
C
      IF (I_PART.EQ.11) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=0
          LIMSET=1
C
      END IF
C
C=======================================================================
C         CALCULATION OF THE  S A C H S  PART  OF  THE  TWO-BODY-CURRENT
C         CONTRIBUTION  TO  THE  MAGNETIC  MOMENT.   IN   THE   RELATIVE
C         COORDINATES, PARITY IS EVEN OR ODD DEPENDING ON THE  CARTESIAN
C         DIRECTION, IPAXYZ=0.
C=======================================================================
C
      IF (I_PART.EQ.12) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=0
          LIMSET=1
C
      END IF
C
C=======================================================================
C         CALCULATION OF THE FINITE-RANGE SPIN-ORBIT OR ODD-TENSOR TERMS
C         ATTENTION: FOR SECURITY, BELOW IPAXYZ=0 IS SET: TO BE ANALYZED
C=======================================================================
C
      IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=0
          LIMSET=1
C
      END IF
C
C=======================================================================
C         ATTENTION: IN THE TWO-CENTER BASIS OPTION, PARITY IS BROKEN
C                    IN GENERAL, SO SUMMATIONS MUST CONSIDER ALL
C                    QUANTUM NUMBERS
C=======================================================================
C
      IF (ITWCEN.EQ.2) THEN
C
          IPAXYZ=0
          I_JUMP=1
C
      END IF
C
C=======================================================================
C        TESTING THE INPUT VALUE OF I_PART
C=======================================================================
C
      IF (LIMSET.NE.1)
     *    STOP 'GAUENE CALLED WITH AN INCORRECT VALUE OF I_PART'
C
C=======================================================================
C        ALLOCATING ARRAYS
C=======================================================================
C
      IALLOC=0
C
      ALLOCATE (Y_HEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Y_HEL0','GAUENE')
      ALLOCATE (Z_HE00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_HE00','GAUENE')
C
      IF (I_PART.EQ.0) THEN
          ALLOCATE (Y_HEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL1','GAUENE')
          ALLOCATE (Z_HE10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE10','GAUENE')
          ALLOCATE (Z_HE01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE01','GAUENE')
      END IF
C
      IF (I_PART.GE.5.AND.I_PART.LE.7) THEN
          ALLOCATE (Y_HEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL2','GAUENE')
          ALLOCATE (Z_HE20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE20','GAUENE')
          ALLOCATE (Z_HE02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE02','GAUENE')
          IF (I_PART.GE.6) THEN
              ALLOCATE (Y_HEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL4','GAUENE')
              ALLOCATE (Z_HE40(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE40','GAUENE')
              ALLOCATE (Z_HE04(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE04','GAUENE')
              ALLOCATE (Z_HE22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE22','GAUENE')
          END IF
          IF (I_PART.GE.7) THEN
              ALLOCATE (Y_HEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL6','GAUENE')
              ALLOCATE (Z_HE60(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE60','GAUENE')
              ALLOCATE (Z_HE06(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE06','GAUENE')
              ALLOCATE (Z_HE42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE42','GAUENE')
              ALLOCATE (Z_HE24(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE24','GAUENE')
          END IF
      END IF
      IF (I_PART.GE.8.AND.I_PART.LE.10) THEN
          ALLOCATE (Y_HEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL1','GAUENE')
          ALLOCATE (Y_HEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL2','GAUENE')
          ALLOCATE (Z_HE10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE10','GAUENE')
          ALLOCATE (Z_HE01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE01','GAUENE')
          ALLOCATE (Z_HE20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE20','GAUENE')
          ALLOCATE (Z_HE02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE02','GAUENE')
          IF (I_PART.GE.9) THEN
              ALLOCATE (Y_HEL3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL3','GAUENE')
              ALLOCATE (Y_HEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL4','GAUENE')
              ALLOCATE (Y_HEL5(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL5','GAUENE')
              ALLOCATE (Z_HE03(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE03','GAUENE')
              ALLOCATE (Z_HE30(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE30','GAUENE')
              ALLOCATE (Z_HE04(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE04','GAUENE')
              ALLOCATE (Z_HE40(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE40','GAUENE')
              ALLOCATE (Z_HE05(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE05','GAUENE')
              ALLOCATE (Z_HE50(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE50','GAUENE')
              ALLOCATE (Z_HE11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE11','GAUENE')
              ALLOCATE (Z_HE12(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE12','GAUENE')
              ALLOCATE (Z_HE21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE21','GAUENE')
              ALLOCATE (Z_HE22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE22','GAUENE')
          END IF
          IF (I_PART.GE.10) THEN
              ALLOCATE (Y_HEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL6','GAUENE')
              ALLOCATE (Y_HEL7(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL7','GAUENE')
              ALLOCATE (Y_HEL8(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL8','GAUENE')
              ALLOCATE (Y_HEL9(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL9','GAUENE')
          END IF
      END IF
      IF (I_PART.EQ.11) THEN
          ALLOCATE (Y_HEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL1','GAUENE')
          ALLOCATE (Y_HEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL2','GAUENE')
          ALLOCATE (Z_HE10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE10','GAUENE')
          ALLOCATE (Z_HE01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE01','GAUENE')
          ALLOCATE (Z_HE11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                               0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE11','GAUENE')
          ALLOCATE (Z_HE20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE20','GAUENE')
          ALLOCATE (Z_HE02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE02','GAUENE')
      END IF
      IF (I_PART.EQ.12) THEN
          ALLOCATE (Y_HE00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE00','GAUENE')
          ALLOCATE (Y_HE01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE01','GAUENE')
          ALLOCATE (Y_HE02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE02','GAUENE')
          ALLOCATE (Y_HE03(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE03','GAUENE')
          ALLOCATE (Y_HE10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE10','GAUENE')
          ALLOCATE (Y_HE11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE11','GAUENE')
          ALLOCATE (Y_HE12(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
C
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE12','GAUENE')
          ALLOCATE (Z_0001(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0001','GAUENE')
          ALLOCATE (Z_0002(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0002','GAUENE')
          ALLOCATE (Z_0003(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0003','GAUENE')
          ALLOCATE (Z_0010(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0010','GAUENE')
          ALLOCATE (Z_0011(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0011','GAUENE')
          ALLOCATE (Z_0012(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0012','GAUENE')
          ALLOCATE (Z_0100(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0100','GAUENE')
          ALLOCATE (Z_0101(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0101','GAUENE')
          ALLOCATE (Z_0102(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0102','GAUENE')
          ALLOCATE (Z_0110(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0110','GAUENE')
          ALLOCATE (Z_0111(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0111','GAUENE')
          ALLOCATE (Z_0112(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0112','GAUENE')
          ALLOCATE (Z_0200(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0200','GAUENE')
          ALLOCATE (Z_0201(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0201','GAUENE')
          ALLOCATE (Z_0210(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0210','GAUENE')
          ALLOCATE (Z_0211(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0211','GAUENE')
          ALLOCATE (Z_0300(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0300','GAUENE')
          ALLOCATE (Z_0310(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0310','GAUENE')
          ALLOCATE (Z_1000(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1000','GAUENE')
          ALLOCATE (Z_1001(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1001','GAUENE')
          ALLOCATE (Z_1002(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1002','GAUENE')
          ALLOCATE (Z_1003(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1003','GAUENE')
          ALLOCATE (Z_1100(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1100','GAUENE')
          ALLOCATE (Z_1101(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1101','GAUENE')
          ALLOCATE (Z_1102(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1102','GAUENE')
          ALLOCATE (Z_1200(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1200','GAUENE')
          ALLOCATE (Z_1201(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1201','GAUENE')
      END IF
C
      IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
          ALLOCATE (Y_HE01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE01','GAUENE')
          ALLOCATE (Y_HE10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE10','GAUENE')
          ALLOCATE (Y_HE02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE02','GAUENE')
          ALLOCATE (Y_HE11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE11','GAUENE')
          ALLOCATE (Y_HE20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HE20','GAUENE')
C
          ALLOCATE (Z_0000(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0000','GAUENE')
          ALLOCATE (Z_0001(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0001','GAUENE')
          ALLOCATE (Z_0010(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0010','GAUENE')
          ALLOCATE (Z_0002(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0002','GAUENE')
          ALLOCATE (Z_0011(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0011','GAUENE')
          ALLOCATE (Z_0020(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0020','GAUENE')
          ALLOCATE (Z_0100(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0100','GAUENE')
          ALLOCATE (Z_0101(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0101','GAUENE')
          ALLOCATE (Z_0110(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0110','GAUENE')
          ALLOCATE (Z_1000(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1000','GAUENE')
          ALLOCATE (Z_1001(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1001','GAUENE')
          ALLOCATE (Z_1010(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1010','GAUENE')
          ALLOCATE (Z_0200(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_0200','GAUENE')
          ALLOCATE (Z_1100(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_1100','GAUENE')
          ALLOCATE (Z_2000(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_2000','GAUENE')
C
      END IF
C
      IF (     ALLOCATED(GAUAVR)) DEALLOCATE(GAUAVR)
      IF (.NOT.ALLOCATED(GAUAVR)) THEN
          IF (I_PART.EQ.0) THEN
              ALLOCATE (GAUAVR(0:NDKART,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUENE')
          END IF
          IF (I_PART.EQ.1.OR.I_PART.EQ.2.OR.I_PART.EQ.3) THEN
              ALLOCATE (GAUAVR(0:0     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUENE')
          END IF
          IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
              ALLOCATE (GAUAVR(0:I_PART-4,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUENE')
          END IF
          IF (I_PART.EQ.8) THEN
              ALLOCATE (GAUAVR(0:2     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUENE')
          END IF
          IF (I_PART.EQ.9) THEN
              ALLOCATE (GAUAVR(0:5     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUENE')
          END IF
          IF (I_PART.EQ.10) THEN
              ALLOCATE (GAUAVR(0:9     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUENE')
          END IF
      END IF
      IF (     ALLOCATED(TINAVR)) DEALLOCATE(TINAVR)
      IF (.NOT.ALLOCATED(TINAVR)) THEN
          IF (I_PART.EQ.11) THEN
              ALLOCATE (TINAVR(0:NDKART,0:NDKART,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('TINAVR','GAUENE')
          END IF
          IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
              ALLOCATE (TINAVR(0:NDKART,0:NDKART,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('TINAVR','GAUENE')
          END IF
      END IF
      IF (     ALLOCATED(TSAAVR)) DEALLOCATE(TSAAVR)
      IF (.NOT.ALLOCATED(TSAAVR)) THEN
          IF (I_PART.EQ.12) THEN
              ALLOCATE (TSAAVR(0:NDKART,0:NDKART,0:NDKART,0:NDKART,
     *                         0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('TSAAVR','GAUENE')
          END IF
      END IF
C=======================================================================
C         ATTENTION: SEE COMMENTS IN GAUOPT
C=======================================================================
      IF (     ALLOCATED(GAUFIL)) DEALLOCATE(GAUFIL)
      IF (.NOT.ALLOCATED(GAUFIL).AND.I_FIEL.GE.2) THEN
          IF (I_PART.EQ.0) THEN
              ALLOCATE (GAUFIL(0:NDKART,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUENE')
          END IF
          IF (I_PART.EQ.1.OR.I_PART.EQ.2.OR.I_PART.EQ.3) THEN
              ALLOCATE (GAUFIL(0:0     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUENE')
          END IF
          IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
              ALLOCATE (GAUFIL(0:I_PART-4,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUENE')
          END IF
          IF (I_PART.EQ.8) THEN
              ALLOCATE (GAUFIL(0:2     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUENE')
          END IF
          IF (I_PART.EQ.9) THEN
              ALLOCATE (GAUFIL(0:5     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUENE')
          END IF
          IF (I_PART.EQ.10) THEN
              ALLOCATE (GAUFIL(0:9     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUENE')
          END IF
          IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
              ALLOCATE (GAUFIL(0:0     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUENE')
          END IF
      END IF
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE ENERGIES
C=======================================================================
C
      IF (I_PART.LE.10)                  GAUAVR=C_ZERO
      IF (I_PART.EQ.11)                  TINAVR=C_ZERO
      IF (I_PART.EQ.12)                  TSAAVR=C_ZERO
      IF (I_PART.GE.13.AND.I_PART.LE.16) TINAVR=C_ZERO
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      IF (I_FIEL.GE.2) THEN
C
          GAUFIL=C_ZERO
C
      END IF
C
C=======================================================================
C        SPECIFYING INDEX OF THE CENTRE
C=======================================================================
C
      IF (I_PART.NE.1) THEN
          I  =IND4HI(LTWCEN) !MP  PARTICLE "1"
          J  =IND4HK(LTWCEN) !M   PARTICLE "2"
          IP =IND4HL(LTWCEN) !NP  PARTICLE "1"
          JP =IND4HJ(LTWCEN) !N   PARTICLE "2"
      ELSE !EXCHANGE CASE
          I  =IND4HI(LTWCEN)
          J  =IND4HK(LTWCEN)
          JP =IND4HL(LTWCEN)
          IP =IND4HJ(LTWCEN)
      END IF
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      DO NX=0,NXMAXV(JP)
         DO MX=0,NXMAXV(J)
C
C=======================================================================
C        HERE BEGINS CALCULATION OF THE AVERAGE ENERGIES
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
            DO NZ=0,LZOFXV(NX,JP)
               DO MZ=0,LZOFXV(MX,J)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                  DO NY=0,LYOZXV(NZ,NX,JP)
                     DO MY=0,LYOZXV(MZ,MX,J)
C
                        IBRA=INDICE(NX,NY,NZ,JP)
                        IKET=INDICE(MX,MY,MZ,J)
C
                        IF (IDENSI.EQ.0) THEN
C
C=======================================================================
C        HERE THE PARTICLE "2" DENSITY MATRIX IS STORED
C=======================================================================
C        ATTENTION TWO-CENTER CONDITION NOT INTENDED
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  D_HELP(NY,MY,KARTEZ,ICHARG)=
     *
     *                            DEN_PP(IBRA,IKET, 0,ICHARG)*
     *                                              IPHAPP(MY,NY,KARTEZ)
     *                           +DEN_PP(IBRA,IKET, 1,ICHARG)*
     *                                              IPHAMM(MY,NY,KARTEZ)
C
                                  IF (ISIMPY.NE.1)
     *
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)=
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)
     *
     *                           +DEN_PM(IBRA,IKET, 0,ICHARG)*
     *                                              IPHAMP(MY,NY,KARTEZ)
     *                           +DEN_PM(IBRA,IKET, 1,ICHARG)*
     *                                              IPHAPM(MY,NY,KARTEZ)
C
                               END DO
                            END DO
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  D_HELP(NY,MY,KARTEZ,ICHARG)=
     *
     *      TWC_PP(IBRA+LDBATW(1)*(JP-1),IKET+LDBATW(1)*(J-1),0,ICHARG)*
     *                                             IPHAPP(MY,NY,KARTEZ)
     *     +TWC_PP(IBRA+LDBATW(1)*(JP-1),IKET+LDBATW(1)*(J-1),1,ICHARG)*
     *                                             IPHAMM(MY,NY,KARTEZ)
C
                                  IF (ISIMPY.NE.1)
     *
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)=
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)
     *
     *     +TWC_PM(IBRA+LDBATW(1)*(JP-1),IKET+LDBATW(1)*(J-1),0,ICHARG)*
     *                                             IPHAMP(MY,NY,KARTEZ)
     *     +TWC_PM(IBRA+LDBATW(1)*(JP-1),IKET+LDBATW(1)*(J-1),1,ICHARG)*
     *                                             IPHAPM(MY,NY,KARTEZ)
C
                               END DO
                            END DO
C
      END IF
C
                            D_HELP(NY,MY,3,0)=D_HELP(NY,MY,3,0)*UNIT_I
                            D_HELP(NY,MY,3,1)=D_HELP(NY,MY,3,1)*UNIT_I
C
                        ELSE
C
C=======================================================================
C        HERE THE "KET" PAIRING TENSOR IS STORED
C=======================================================================
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  D_HELP(NY,MY,KARTEZ,ICHARG)=
     *
     *                           +CHI_PM(IBRA,IKET, 0,ICHARG)*
     *                                              JPHAPM(NY,MY,KARTEZ)
     *                           +CHI_PM(IBRA,IKET, 1,ICHARG)*
     *                                              JPHAMP(NY,MY,KARTEZ)
C
                                  IF (ISIMPY.NE.1)
     *
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)=
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)
     *
     *                           +CHI_PP(IBRA,IKET, 0,ICHARG)*
     *                                              JPHAPP(NY,MY,KARTEZ)
     *                           +CHI_PP(IBRA,IKET, 1,ICHARG)*
     *                                              JPHAMM(NY,MY,KARTEZ)
C
                               END DO
                            END DO
C
                            D_HELP(NY,MY,3,0)=D_HELP(NY,MY,3,0)*UNIT_I
                            D_HELP(NY,MY,3,1)=D_HELP(NY,MY,3,1)*UNIT_I
C
                        END IF
C
                     END DO
                  END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                  DO NPY=0,NYMAXV(IP)
                     DO MPY=0,NYMAXV(I)
C
                        DO KARTEZ=0,NDKART
                           DO ICHARG=0,NDISOS
C
                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
             IF (I_PART.EQ.0)
     *                        Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
             IF (I_PART.GE.5.AND.I_PART.LE.7) THEN
                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
             IF (I_PART.GE.6) Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
             IF (I_PART.GE.7) Y_HEL6(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
             END IF
             IF (I_PART.GE.8.AND.I_PART.LE.10) THEN
                              Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                 IF (I_PART.GE.9) THEN
                              Y_HEL3(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HEL5(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                 END IF
                 IF (I_PART.GE.10) THEN
                              Y_HEL6(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HEL7(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HEL8(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HEL9(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                 END IF
             END IF
             IF (I_PART.EQ.11) THEN
                              Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
             END IF
             IF (I_PART.EQ.12) THEN
                              Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE03(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE12(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
             END IF
             IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
                              Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
                              Y_HE20(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=C_ZERO
             END IF
C
                           END DO
                        END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                        IF (I_PART.EQ.0) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     DO MY=0,LYOZXV(MZ,MX,J)
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                    Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y1(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4)
     *                                                              THEN
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     IPARIT=MOD(MPY+NPY+NY,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MY=IPARIT,LYOZXV(MZ,MX,J),I_JUMP
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.5) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     IPARIT=MOD(MPY+NPY+NY,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MY=IPARIT,LYOZXV(MZ,MX,J),I_JUMP
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                    Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y2(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.6) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     IPARIT=MOD(MPY+NPY+NY,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MY=IPARIT,LYOZXV(MZ,MX,J),I_JUMP
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                    Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y2(MPY,MY,NPY,NY)
C
                                    Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y4(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.7) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     IPARIT=MOD(MPY+NPY+NY,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MY=IPARIT,LYOZXV(MZ,MX,J),I_JUMP
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                    Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y2(MPY,MY,NPY,NY)
C
                                    Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y4(MPY,MY,NPY,NY)
C
                                    Y_HEL6(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL6(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y6(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.8) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     IPARIT=MOD(MPY+NPY+NY,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MY=IPARIT,LYOZXV(MZ,MX,J),I_JUMP
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                    Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAUY21(MPY,MY,NPY,NY)
C
                                    Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAUY22(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.9) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     IPARIT=MOD(MPY+NPY+NY,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MY=IPARIT,LYOZXV(MZ,MX,J),I_JUMP
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                    Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAUY21(MPY,MY,NPY,NY)
C
                                    Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAUY22(MPY,MY,NPY,NY)
C
                                    Y_HEL3(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL3(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAUY41(MPY,MY,NPY,NY)
C
                                    Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAUY42(MPY,MY,NPY,NY)
C
                                    Y_HEL5(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL5(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *GAUY43(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.11) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     DO MY=0,LYOZXV(MZ,MX,J)
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC0Y0(MPY,MY,NPY,NY)
C
                                    Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC0Y1(MPY,MY,NPY,NY)
C
                                    Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC0Y2(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.12) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     DO MY=0,LYOZXV(MZ,MX,J)
C
C                                    NO C.O.M COMPONENT Y AND POWERS
C                                    0,1,2,3 OF THE RELATIVE COMPONENT Y
C
                                    Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC0Y0(MPY,MY,NPY,NY)
C
                                    Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC0Y1(MPY,MY,NPY,NY)
C
                                    Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC0Y2(MPY,MY,NPY,NY)
C
                                    Y_HE03(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE03(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC0Y3(MPY,MY,NPY,NY)
C
C                                    C.O.M COMPONENT Y AND POWERS 0,1,2
C                                    OF THE RELATIVE COMPONENT Y
C
                                    Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC1Y0(MPY,MY,NPY,NY)
C
                                    Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC1Y1(MPY,MY,NPY,NY)
C
                                    Y_HE12(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE12(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *TBC1Y2(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NY=0,LYOZXV(NZ,NX,JP)
                                     DO MY=0,LYOZXV(MZ,MX,J)
C
                                    Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *FSTY00(MPY,MY,NPY,NY)
C
                                    Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *FSTY01(MPY,MY,NPY,NY)
C
                                    Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *FSTY10(MPY,MY,NPY,NY)
C
                                    Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *FSTY02(MPY,MY,NPY,NY)
C
                                    Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *FSTY11(MPY,MY,NPY,NY)
C
                                    Y_HE20(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                              Y_HE20(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                                     +D_HELP(NY,MY,KARTEZ,ICHARG)
     *                                     *FSTY20(MPY,MY,NPY,NY)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                     END DO
                  END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
            DO NPY=0,NYMAXV(IP)
               DO MPY=0,NYMAXV(I)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                  DO NPZ=0,LZOFYV(NPY,IP)
                     DO MPZ=0,LZOFYV(MPY,I)
C
                        DO KARTEZ=0,NDKART
                           DO ICHARG=0,NDISOS
C
                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.EQ.0) Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.EQ.0) Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
C
           IF (I_PART.GE.5.AND.I_PART.LE.7) THEN
                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.GE.6) Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.GE.6) Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.GE.6) Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.GE.7) Z_HE60(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.GE.7) Z_HE06(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.GE.7) Z_HE24(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           IF (I_PART.GE.7) Z_HE42(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           END IF
C
           IF (I_PART.GE.8.AND.I_PART.LE.10) THEN
                            Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
               IF (I_PART.GE.9) THEN
                            Z_HE03(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE30(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE05(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE50(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE12(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE21(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
               END IF
           END IF
           IF (I_PART.EQ.11) THEN
                            Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           END IF
           IF (I_PART.EQ.12) THEN
                            Z_0001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0003(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0011(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0012(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0102(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0110(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0111(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0112(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0201(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0210(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0211(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0300(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0310(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1003(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1102(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1201(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           END IF
           IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
                            Z_0000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0011(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0020(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0110(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_0200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_1100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
                            Z_2000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=C_ZERO
           END IF
C
                           END DO
                        END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                        IF (I_PART.EQ.0) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,1)
                                     DO MZ=0,LZOFXV(MX,1)
C
                                  Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z1(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4)
     *                                                              THEN
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,JP)
                                     IPARIT=MOD(MPZ+NPZ+NZ,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MZ=IPARIT,LZOFXV(MX,J),I_JUMP
C
                                  Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.5) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,JP)
                                     IPARIT=MOD(MPZ+NPZ+NZ,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MZ=IPARIT,LZOFXV(MX,J),I_JUMP
C
                                  Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z2(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.6) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,JP)
                                     IPARIT=MOD(MPZ+NPZ+NZ,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MZ=IPARIT,LZOFXV(MX,J),I_JUMP
C
                                  Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z2(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z4(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z2(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.7) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,JP)
                                     IPARIT=MOD(MPZ+NPZ+NZ,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MZ=IPARIT,LZOFXV(MX,J),I_JUMP
C
                                  Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z2(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z4(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z2(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE60(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE60(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL6(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE06(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE06(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z6(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE24(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE24(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z4(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE42(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE42(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z2(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.8) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,JP)
                                     IPARIT=MOD(MPZ+NPZ+NZ,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MZ=IPARIT,LZOFXV(MX,J),I_JUMP
C
                                  Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ21(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ22(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.9) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,JP)
                                     IPARIT=MOD(MPZ+NPZ+NZ,2)
                                     IF (ITWCEN.EQ.2) IPARIT=0
                                     DO MZ=IPARIT,LZOFXV(MX,J),I_JUMP
C
                                  Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ21(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ22(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE30(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE30(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL3(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE03(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE03(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ41(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL4(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ42(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE50(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE50(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL5(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE05(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE05(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ43(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ21(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE12(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE12(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ22(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE21(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE21(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ21(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *GAUZ22(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.11) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,1)
                                     DO MZ=0,LZOFXV(MX,1)
C
                                  Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z1(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL2(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z2(MPZ,MZ,NPZ,NZ)
C
                                  Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL1(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z1(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.EQ.12) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,1)
                                     DO MZ=0,LZOFXV(MX,1)
C
C                                 NO C.O.M. COMPONENT Z AND NO POWERS
C                                 OF RELATIVE COMPONENTS Z
C
                                  Z_0001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_0002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_0003(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0003(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE03(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_0010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_0011(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0011(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_0012(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0012(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE12(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z0(MPZ,MZ,NPZ,NZ)
C
C                                 NO C.O.M. COMPONENT Z AND POWER 1
C                                 OF THE RELATIVE COMPONENT Z
C
                                  Z_0100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z1(MPZ,MZ,NPZ,NZ)
C
                                  Z_0101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z1(MPZ,MZ,NPZ,NZ)
C
                                  Z_0102(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0102(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z1(MPZ,MZ,NPZ,NZ)
C
                                  Z_0110(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0110(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z1(MPZ,MZ,NPZ,NZ)
C
                                  Z_0111(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0111(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z1(MPZ,MZ,NPZ,NZ)
C
                                  Z_0112(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0112(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE12(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z1(MPZ,MZ,NPZ,NZ)
C
C                                 NO C.O.M. COMPONENT Z AND POWER 2
C                                 OF THE RELATIVE COMPONENT Z
C
                                  Z_0200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z2(MPZ,MZ,NPZ,NZ)
C
                                  Z_0201(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0201(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z2(MPZ,MZ,NPZ,NZ)
C
                                  Z_0210(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0210(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z2(MPZ,MZ,NPZ,NZ)
C
                                  Z_0211(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0211(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z2(MPZ,MZ,NPZ,NZ)
C
C                                 NO C.O.M. COMPONENT Z AND POWER 3
C                                 OF THE RELATIVE COMPONENT Z
C
                                  Z_0300(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0300(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z3(MPZ,MZ,NPZ,NZ)
C
                                  Z_0310(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0310(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC0Z3(MPZ,MZ,NPZ,NZ)
C
C                                 POWER 1 OF THE C.O.M. COMPONENT Z AND
C                                 NO RELATIVE COMPONENT Z
C
                                  Z_1000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_1001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_1002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z0(MPZ,MZ,NPZ,NZ)
C
                                  Z_1003(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1003(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE03(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z0(MPZ,MZ,NPZ,NZ)
C
C                                 POWER 1 OF THE C.O.M. COMPONENT Z AND
C                                 POWER 1 OF THE RELATIVE COMPONENT Z
C
                                  Z_1100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z1(MPZ,MZ,NPZ,NZ)
C
                                  Z_1101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z1(MPZ,MZ,NPZ,NZ)
C
                                  Z_1102(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1102(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z1(MPZ,MZ,NPZ,NZ)
C
C                                 POWER 1 OF THE C.O.M. COMPONENT Z AND
C                                 POWER 2 OF THE RELATIVE COMPONENT Z
C
                                  Z_1200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE00(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z2(MPZ,MZ,NPZ,NZ)
C
                                  Z_1201(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1201(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *TBC1Z2(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
                        IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
C
                            DO KARTEZ=0,KARLIM
                               DO ICHARG=ICHLIM,NDISOS
C
                                  DO NZ=0,LZOFXV(NX,1)
                                     DO MZ=0,LZOFXV(MX,1)
C
                                  Z_0000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ00(MPZ,MZ,NPZ,NZ)
C
                                  Z_0001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ01(MPZ,MZ,NPZ,NZ)
C
                                  Z_0010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ10(MPZ,MZ,NPZ,NZ)
C
                                  Z_0002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ02(MPZ,MZ,NPZ,NZ)
C
                                  Z_0011(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0011(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ11(MPZ,MZ,NPZ,NZ)
C
                                  Z_0020(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0020(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ20(MPZ,MZ,NPZ,NZ)
C
                                  Z_0100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ00(MPZ,MZ,NPZ,NZ)
C
                                  Z_0101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ01(MPZ,MZ,NPZ,NZ)
C
                                  Z_0110(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0110(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE01(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ10(MPZ,MZ,NPZ,NZ)
C
                                  Z_1000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ00(MPZ,MZ,NPZ,NZ)
C
                                  Z_1001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ01(MPZ,MZ,NPZ,NZ)
C
                                  Z_1010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE10(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ10(MPZ,MZ,NPZ,NZ)
C
                                  Z_0200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_0200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE02(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ00(MPZ,MZ,NPZ,NZ)
C
                                  Z_1100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_1100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE11(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ00(MPZ,MZ,NPZ,NZ)
C
                                  Z_2000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                            Z_2000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                             +Y_HE20(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
     *                             *FSTZ00(MPZ,MZ,NPZ,NZ)
C
                                     END DO
                                  END DO
C
                               END DO
                            END DO
C
                        END IF
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                     END DO
                  END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
            DO NPX=0,NXMAXV(IP)
               IPARIT=MOD(NX+MX+NPX,2)*IPAXYZ
               DO MPX=IPARIT,NXMAXV(I),IPAXYZ+1
C
                  X_HE00(:,:,:,:)=C_ZERO
                  X_HE10(:,:,:,:)=C_ZERO
                  X_HE01(:,:,:,:)=C_ZERO
                  X_HE20(:,:,:,:)=C_ZERO
                  X_HE02(:,:,:,:)=C_ZERO
                  X_HE40(:,:,:,:)=C_ZERO
                  X_HE04(:,:,:,:)=C_ZERO
                  X_HE22(:,:,:,:)=C_ZERO
                  X_HE60(:,:,:,:)=C_ZERO
                  X_HE06(:,:,:,:)=C_ZERO
                  X_HE24(:,:,:,:)=C_ZERO
                  X_HE42(:,:,:,:)=C_ZERO
                  X_HE03(:,:,:,:)=C_ZERO
                  X_HE30(:,:,:,:)=C_ZERO
                  X_HE04(:,:,:,:)=C_ZERO
                  X_HE40(:,:,:,:)=C_ZERO
                  X_HE05(:,:,:,:)=C_ZERO
                  X_HE50(:,:,:,:)=C_ZERO
                  X_HE11(:,:,:,:)=C_ZERO
                  X_HE12(:,:,:,:)=C_ZERO
                  X_HE21(:,:,:,:)=C_ZERO
C
                  X_0020(:,:,:,:)=C_ZERO
                  X_2000(:,:,:,:)=C_ZERO
                  X_1010(:,:,:,:)=C_ZERO
C
                  X_0000(:,:,:,:)=C_ZERO
                  X_0001(:,:,:,:)=C_ZERO
                  X_0002(:,:,:,:)=C_ZERO
                  X_0003(:,:,:,:)=C_ZERO
                  X_0010(:,:,:,:)=C_ZERO
                  X_0011(:,:,:,:)=C_ZERO
                  X_0012(:,:,:,:)=C_ZERO
                  X_0100(:,:,:,:)=C_ZERO
                  X_0101(:,:,:,:)=C_ZERO
                  X_0102(:,:,:,:)=C_ZERO
                  X_0110(:,:,:,:)=C_ZERO
                  X_0111(:,:,:,:)=C_ZERO
                  X_0112(:,:,:,:)=C_ZERO
                  X_0200(:,:,:,:)=C_ZERO
                  X_0201(:,:,:,:)=C_ZERO
                  X_0210(:,:,:,:)=C_ZERO
                  X_0211(:,:,:,:)=C_ZERO
                  X_0300(:,:,:,:)=C_ZERO
                  X_0310(:,:,:,:)=C_ZERO
                  X_1000(:,:,:,:)=C_ZERO
                  X_1001(:,:,:,:)=C_ZERO
                  X_1002(:,:,:,:)=C_ZERO
                  X_1003(:,:,:,:)=C_ZERO
                  X_1100(:,:,:,:)=C_ZERO
                  X_1101(:,:,:,:)=C_ZERO
                  X_1102(:,:,:,:)=C_ZERO
                  X_1200(:,:,:,:)=C_ZERO
                  X_1201(:,:,:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                  DO NPY=0,LYOFXV(NPX,IP)
                     DO MPY=0,LYOFXV(MPX,I)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                        DO NPZ=0,LZOXYV(NPX,NPY,IP)
                           DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                              IBRA=INDICE(NPX,NPY,NPZ,IP)
                              IKET=INDICE(MPX,MPY,MPZ,I)
C
                              IF (IDENSI.EQ.0) THEN
C
C=======================================================================
C        HERE THE PARTICLE "1" DENSITY MATRIX IS STORED
C=======================================================================
C        THE "IF" THAT FOLLOWS IS NOT INDENTED
C=======================================================================
C
                              IF (ITWCEN.EQ.1) THEN
C
                                  DO KARTEP=0,KARLIM
                                     DO ICHARP=ICHLIM,NDISOS
C
                                        E_HELP(KARTEP,ICHARP)=
     *
     *                                  DEN_PP(IBRA,IKET,0,ICHARP)*
     *                                            IPHAPP(MPY,NPY,KARTEP)
     *                                 +DEN_PP(IBRA,IKET,1,ICHARP)*
     *                                            IPHAMM(MPY,NPY,KARTEP)
C
                                        IF(ISIMPY.NE.1)
     *
     *                                  E_HELP(KARTEP,ICHARP)=
     *                                  E_HELP(KARTEP,ICHARP)
     *
     *                                 +DEN_PM(IBRA,IKET,0,ICHARP)*
     *                                            IPHAMP(MPY,NPY,KARTEP)
     *                                 +DEN_PM(IBRA,IKET,1,ICHARP)*
     *                                            IPHAPM(MPY,NPY,KARTEP)
C
                                     END DO
                                  END DO
C
                              ELSEIF (ITWCEN.EQ.2) THEN
C
                                  DO KARTEP=0,KARLIM
                                     DO ICHARP=ICHLIM,NDISOS
C
                                        E_HELP(KARTEP,ICHARP)=
     *
     *      TWC_PP(IBRA+LDBATW(1)*(IP-1),IKET+LDBATW(1)*(I-1),0,ICHARP)*
     *                                           IPHAPP(MPY,NPY,KARTEP)
     *     +TWC_PP(IBRA+LDBATW(1)*(IP-1),IKET+LDBATW(1)*(I-1),1,ICHARP)*
     *                                           IPHAMM(MPY,NPY,KARTEP)
C
                                        IF(ISIMPY.NE.1)
     *
     *                                  E_HELP(KARTEP,ICHARP)=
     *                                  E_HELP(KARTEP,ICHARP)
     *
     *     +TWC_PM(IBRA+LDBATW(1)*(IP-1),IKET+LDBATW(1)*(I-1),0,ICHARP)*
     *                                           IPHAMP(MPY,NPY,KARTEP)
     *     +TWC_PM(IBRA+LDBATW(1)*(IP-1),IKET+LDBATW(1)*(I-1),1,ICHARP)*
     *                                           IPHAPM(MPY,NPY,KARTEP)
C
                                     END DO
                                  END DO
C
                              END IF
C
                                  E_HELP(3,0)=E_HELP(3,0)*UNIT_I
                                  E_HELP(3,1)=E_HELP(3,1)*UNIT_I
C
                              ELSE
C
C=======================================================================
C        HERE THE "BRA" COMPLEX-CONJUGATE PAIRING TENSOR IS STORED
C=======================================================================
C
                                  DO KARTEP=0,KARLIM
                                     DO ICHARP=ICHLIM,NDISOS
C
                                        E_HELP(KARTEP,ICHARP)=
     *
     *                                 +CHI_PM(IBRA,IKET,0,ICHARP)*
     *                                            JPHAPM(NPY,MPY,KARTEP)
     *                                 +CHI_PM(IBRA,IKET,1,ICHARP)*
     *                                            JPHAMP(NPY,MPY,KARTEP)
C
                                        IF(ISIMPY.NE.1)
     *
     *                                  E_HELP(KARTEP,ICHARP)=
     *                                  E_HELP(KARTEP,ICHARP)
     *
     *                                 +CHI_PP(IBRA,IKET,0,ICHARP)*
     *                                            JPHAPP(NPY,MPY,KARTEP)
     *                                 +CHI_PP(IBRA,IKET,1,ICHARP)*
     *                                            JPHAMM(NPY,MPY,KARTEP)
C
                                     END DO
                                  END DO
C
                                  E_HELP(3,0)=E_HELP(3,0)*UNIT_I
                                  E_HELP(3,1)=E_HELP(3,1)*UNIT_I
C
                                  E_HELP=CONJG(E_HELP)
C
                              END IF
C
C=======================================================================
C        HERE THE PARTICLE "1" DENSITY MATRIX IS SUMMED UP
C=======================================================================
C
                              IF (I_PART.EQ.0) THEN
C
                                  DO KARTEP=0,KARLIM
                                     DO KARTEZ=0,KARLIM
                                        DO ICHARP=ICHLIM,NDISOS
                                           DO ICHARG=ICHLIM,NDISOS
C
                                    X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
                                  END DO
C
                              END IF
C
                              IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                                  DO KARTEP=0,KARLIM
                                     DO KARTEZ=0,KARLIM
                                        DO ICHARP=ICHLIM,NDISOS
                                           DO ICHARG=ICHLIM,NDISOS
C
                                    X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
                                  END DO
C
                              END IF
C
                              IF (I_PART.EQ.5) THEN
C
                                  DO KARTEZ=0,KARLIM
                                     DO ICHARP=ICHLIM,NDISOS
                                        DO ICHARG=ICHLIM,NDISOS
C
                                    X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
C
                              END IF
C
                              IF (I_PART.EQ.6) THEN
C
                                  DO KARTEZ=0,KARLIM
                                     DO ICHARP=ICHLIM,NDISOS
                                        DO ICHARG=ICHLIM,NDISOS
C
                                    X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
C
                              END IF
C
                              IF (I_PART.EQ.7) THEN
C
                                  DO KARTEZ=0,KARLIM
                                     DO ICHARP=ICHLIM,NDISOS
                                        DO ICHARG=ICHLIM,NDISOS
C
                                    X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE60(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE60(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE60(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE06(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE06(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE06(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE24(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE24(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE24(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE42(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE42(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE42(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
C
                              END IF
C
                              IF (I_PART.EQ.8) THEN
C
                                  DO KARTEZ=0,KARLIM
                                     DO ICHARP=ICHLIM,NDISOS
                                        DO ICHARG=ICHLIM,NDISOS
C
                                    X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE10(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE10(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE01(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE01(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
C
                              END IF
C
                              IF (I_PART.EQ.9) THEN
C
                                  DO KARTEZ=0,KARLIM
                                     DO ICHARP=ICHLIM,NDISOS
                                        DO ICHARG=ICHLIM,NDISOS
C
                                    X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE10(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE10(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE01(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE01(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE30(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE30(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE30(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE03(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE03(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE03(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE50(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE50(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE50(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE05(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE05(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE05(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE11(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE11(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE12(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE12(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE12(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE21(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE21(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE21(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEZ,ICHARP)
     *                           *Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
C
                              END IF
C
                              IF (I_PART.EQ.11) THEN
C
                                  DO KARTEP=0,KARLIM
                                     DO KARTEZ=0,KARLIM
                                        DO ICHARP=ICHLIM,NDISOS
                                           DO ICHARG=ICHLIM,NDISOS
C
                                    X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE20(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE20(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE02(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE02(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_HE11(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE11(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
                                  END DO
C
                              END IF
C
                              IF (I_PART.EQ.12) THEN
C
                                  DO KARTEP=0,KARLIM
                                     DO KARTEZ=0,KARLIM
                                        DO ICHARP=ICHLIM,NDISOS
                                           DO ICHARG=ICHLIM,NDISOS
C
                                    X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0002(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0002(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0003(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0003(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0003(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0011(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0011(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0011(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0012(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0012(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0012(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0101(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0101(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0102(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0102(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0102(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0110(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0111(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0111(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0111(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0112(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0112(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0112(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0200(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0200(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0201(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0201(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0201(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0210(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0210(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0210(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0211(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0211(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0211(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0300(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0300(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0300(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0310(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0310(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0310(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1002(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1002(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1003(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1003(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1003(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1100(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1101(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1101(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1102(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1102(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1102(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1200(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1200(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1201(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1201(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1201(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
                                  END DO
C
                              END IF
C
                              IF (I_PART.GE.13.AND.I_PART.LE.16) THEN
C
                                  DO KARTEP=0,KARLIM
                                     DO KARTEZ=0,KARLIM
                                        DO ICHARP=ICHLIM,NDISOS
                                           DO ICHARG=ICHLIM,NDISOS
C
                                    X_0000(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0002(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0002(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0002(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0011(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0011(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0011(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0020(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0020(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0020(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0101(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0101(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0101(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0110(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1001(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1010(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1010(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_0200(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_0200(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_0200(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_1100(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_1100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_1100(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                    X_2000(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_2000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_2000(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                           END DO
                                        END DO
                                     END DO
                                  END DO
C
                              END IF
C
                           END DO
                        END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                     END DO
                  END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C        HERE THE AVERAGE ENERGIES ARE SUMMED UP
C=======================================================================
C
                  IF (I_PART.EQ.0) THEN
C
                      DO KARTEP=0,KARLIM
                         DO KARTEZ=0,KARLIM
                            DO ICHARP=ICHLIM,NDISOS
                               DO ICHARG=ICHLIM,NDISOS
C
                               GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X1(MPX,MX,NPX,NX)
C
                               GAUAVR(2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                      DO KARTEP=0,KARLIM
                         DO KARTEZ=0,KARLIM
                            DO ICHARP=ICHLIM,NDISOS
                               DO ICHARG=ICHLIM,NDISOS
C
                               GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.5) THEN
C
                      DO KARTEZ=0,KARLIM
                         DO ICHARP=ICHLIM,NDISOS
                            DO ICHARG=ICHLIM,NDISOS
C
                               GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                           END DO
                        END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.6) THEN
C
                      DO KARTEZ=0,KARLIM
                         DO ICHARP=ICHLIM,NDISOS
                            DO ICHARG=ICHLIM,NDISOS
C
                               GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(2,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(2,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X4(MPX,MX,NPX,NX)
     *
     *                          +X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)*2
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)*2
     *
     *                          +X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)*2
C
                           END DO
                        END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.7) THEN
C
                      DO KARTEZ=0,KARLIM
                         DO ICHARP=ICHLIM,NDISOS
                            DO ICHARG=ICHLIM,NDISOS
C
                               GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(2,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(2,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X4(MPX,MX,NPX,NX)
     *
     *                          +X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)*2
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)*2
     *
     *                          +X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)*2
C
                               GAUAVR(3,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(3,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X6(MPX,MX,NPX,NX)
     *
     *                          +X_HE60(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE06(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE24(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)*3
     *
     *                          +X_HE42(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)*3
     *
     *                          +X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)*3
     *
     *                          +X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)*3
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X4(MPX,MX,NPX,NX)*3
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X4(MPX,MX,NPX,NX)*3
     *
     *                          +X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X2(MPX,MX,NPX,NX)*6
C
                           END DO
                        END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.8) THEN
C
                      DO KARTEZ=0,KARLIM
                         DO ICHARP=ICHLIM,NDISOS
                            DO ICHARG=ICHLIM,NDISOS
C
                               GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX21(MPX,MX,NPX,NX)
     *
     *                          +X_HE10(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE01(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(2,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(2,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX22(MPX,MX,NPX,NX)
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                           END DO
                        END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.9) THEN
C
                      DO KARTEZ=0,KARLIM
                         DO ICHARP=ICHLIM,NDISOS
                            DO ICHARG=ICHLIM,NDISOS
C
                               GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(0,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(1,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX21(MPX,MX,NPX,NX)
     *
     *                          +X_HE10(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE01(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(2,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(2,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX22(MPX,MX,NPX,NX)
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(3,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(3,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX41(MPX,MX,NPX,NX)
     *
     *                          +X_HE30(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE03(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE01(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX21(MPX,MX,NPX,NX)*2
     *
     *                          +X_HE10(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX21(MPX,MX,NPX,NX)*2
     *
     *                          +X_HE11(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)*2
C
                               GAUAVR(4,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(4,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX42(MPX,MX,NPX,NX)
     *
     *                          +X_HE40(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE04(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE01(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX22(MPX,MX,NPX,NX)
     *
     *                          +X_HE10(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX22(MPX,MX,NPX,NX)
     *
     *                          +X_HE12(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX21(MPX,MX,NPX,NX)
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX21(MPX,MX,NPX,NX)
     *
     *                          +X_HE21(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
C
                               GAUAVR(5,KARTEZ,KARTEZ,ICHARP,ICHARG)=
     *                         GAUAVR(5,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          +X_HE00(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX43(MPX,MX,NPX,NX)
     *
     *                          +X_HE50(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE05(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)
     *
     *                          +X_HE02(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX22(MPX,MX,NPX,NX)*2
     *
     *                          +X_HE20(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAUX22(MPX,MX,NPX,NX)*2
     *
     *                          +X_HE22(KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                          *GAU_X0(MPX,MX,NPX,NX)*2
C
                           END DO
                        END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.11) THEN
C
                      DO KARTEP=0,KARLIM
                         DO KARTEZ=0,KARLIM
                            DO ICHARP=ICHLIM,NDISOS
                               DO ICHARG=ICHLIM,NDISOS
C
                                TINAVR(0,0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(0,0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
                                TINAVR(1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X2(MPX,MX,NPX,NX)
C
                                TINAVR(2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_HE20(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
                                TINAVR(3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_HE02(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
                                TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                                TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                                TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_HE11(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.12) THEN
C
                      DO KARTEP=0,KARLIM
                         DO KARTEZ=0,KARLIM
                            DO ICHARP=ICHLIM,NDISOS
                               DO ICHARG=ICHLIM,NDISOS
C
C                     TERMS DEFINING THE SACHS FORMFACTORS NOS. 3 AND 5
C
                            TSAAVR(1,2,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,2,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X0(MPX,MX,NPX,NX)
C
                            TSAAVR(1,3,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,3,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X0(MPX,MX,NPX,NX)
C
                            TSAAVR(2,1,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,1,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(2,3,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,3,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
                            TSAAVR(3,1,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,1,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(3,2,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,2,0,0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
C                     TERMS DEFINING THE SACHS FORMFACTOR NO. 4
C
C                     HERE WE CALCULATE THE X-X TERM, INDICES 1,1
C
                            TSAAVR(1,2,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,2,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X2(MPX,MX,NPX,NX)
C
                            TSAAVR(1,3,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,3,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X2(MPX,MX,NPX,NX)
C
                            TSAAVR(2,1,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,1,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X3(MPX,MX,NPX,NX)
C
                            TSAAVR(2,3,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,3,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X2(MPX,MX,NPX,NX)
C
                            TSAAVR(3,1,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,1,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X3(MPX,MX,NPX,NX)
C
                            TSAAVR(3,2,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,2,1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X2(MPX,MX,NPX,NX)
C
C                     HERE WE CALCULATE THE Y-Y TERM, INDICES 2,2
C
                            TSAAVR(1,2,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,2,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0003(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X0(MPX,MX,NPX,NX)
C
                            TSAAVR(1,3,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,3,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0102(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X0(MPX,MX,NPX,NX)
C
                            TSAAVR(2,1,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,1,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0012(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(2,3,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,3,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0112(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
                            TSAAVR(3,1,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,1,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1002(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(3,2,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,2,2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1003(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
C                     HERE WE CALCULATE THE Z-Z TERM, INDICES 3,3
C
                            TSAAVR(1,2,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,2,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0201(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X0(MPX,MX,NPX,NX)
C
                            TSAAVR(1,3,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,3,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0300(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X0(MPX,MX,NPX,NX)
C
                            TSAAVR(2,1,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,1,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0210(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(2,3,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,3,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0310(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
                            TSAAVR(3,1,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,1,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1200(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(3,2,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,2,3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1201(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
C                     HERE WE CALCULATE THE X-Y TERM, INDICES 1,2
C
                            TSAAVR(1,2,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,2,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0002(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X1(MPX,MX,NPX,NX)
C
                            TSAAVR(1,3,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,3,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0101(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X1(MPX,MX,NPX,NX)
C
                            TSAAVR(2,1,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,1,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0011(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X2(MPX,MX,NPX,NX)
C
                            TSAAVR(2,3,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,3,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0111(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(3,1,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,1,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X2(MPX,MX,NPX,NX)
C
                            TSAAVR(3,2,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,2,1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1002(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
C                     HERE WE CALCULATE THE Y-Z TERM, INDICES 2,3
C
                            TSAAVR(1,2,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,2,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0102(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X0(MPX,MX,NPX,NX)
C
                            TSAAVR(1,3,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,3,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0201(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X0(MPX,MX,NPX,NX)
C
                            TSAAVR(2,1,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,1,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0111(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(2,3,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,3,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0211(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
                            TSAAVR(3,1,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,1,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1101(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(3,2,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,2,2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1102(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X0(MPX,MX,NPX,NX)
C
C                     HERE WE CALCULATE THE X-Z TERM, INDICES 1,3
C
                            TSAAVR(1,2,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,2,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0101(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X1(MPX,MX,NPX,NX)
C
                            TSAAVR(1,3,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(1,3,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0200(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC1X1(MPX,MX,NPX,NX)
C
                            TSAAVR(2,1,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,1,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X2(MPX,MX,NPX,NX)
C
                            TSAAVR(2,3,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(2,3,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0210(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                            TSAAVR(3,1,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,1,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X2(MPX,MX,NPX,NX)
C
                            TSAAVR(3,2,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                      TSAAVR(3,2,1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1101(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *TBC0X1(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.13) THEN
C
                      DO KARTEP=0,KARLIM
                         DO KARTEZ=0,KARLIM
                            DO ICHARP=ICHLIM,NDISOS
                               DO ICHARG=ICHLIM,NDISOS
C
                                TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX10(MPX,MX,NPX,NX)
C
                                TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(3,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(3,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX01(MPX,MX,NPX,NX)
C
                                TINAVR(2,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX01(MPX,MX,NPX,NX)
C
                                TINAVR(3,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(3,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX10(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.14) THEN
C
                      DO KARTEP=0,KARLIM
                         DO KARTEZ=0,KARLIM
                            DO ICHARP=ICHLIM,NDISOS
                               DO ICHARG=ICHLIM,NDISOS
C
                                TINAVR(1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX11(MPX,MX,NPX,NX)
C
                                TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX10(MPX,MX,NPX,NX)
C
                                TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX10(MPX,MX,NPX,NX)
C
                                TINAVR(2,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX01(MPX,MX,NPX,NX)
C
                                TINAVR(2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(3,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(3,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX01(MPX,MX,NPX,NX)
C
                                TINAVR(3,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(3,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0110(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0011(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.15) THEN
C
                      DO KARTEP=0,KARLIM
                         DO KARTEZ=0,KARLIM
                            DO ICHARP=ICHLIM,NDISOS
                               DO ICHARG=ICHLIM,NDISOS
C
                                TINAVR(1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX20(MPX,MX,NPX,NX)
C
                                TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX10(MPX,MX,NPX,NX)
C
                                TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX10(MPX,MX,NPX,NX)
C
                                TINAVR(2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_2000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_1010(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0020(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
                  END IF
C
                  IF (I_PART.EQ.16) THEN
C
                      DO KARTEP=0,KARLIM
                         DO KARTEZ=0,KARLIM
                            DO ICHARP=ICHLIM,NDISOS
                               DO ICHARG=ICHLIM,NDISOS
C
                                TINAVR(1,1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0000(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX02(MPX,MX,NPX,NX)
C
                                TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0100(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX01(MPX,MX,NPX,NX)
C
                                TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(1,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0001(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX01(MPX,MX,NPX,NX)
C
                                TINAVR(2,2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0200(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(2,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0101(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                                TINAVR(3,3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                          TINAVR(3,3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             +X_0002(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                             *FSTX00(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
                  END IF
C
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
            IF (I_FIEL.GE.2) THEN
C
C=======================================================================
C        HERE BEGINS CALCULATION OF THE AVERAGE FIELDS
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
                DO NPX=0,NXMAXV(IP)
                   IPARIT=MOD(NX+MX+NPX,2)*IPAXYZ
                   DO MPX=IPARIT,NXMAXV(I),IPAXYZ+1
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                      DO NPY=0,LYOFXV(NPX,IP)
                         DO MPY=0,LYOFXV(MPX,I)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                            IF (I_PART.EQ.0) THEN
C
                                DO KARTEZ=0,KARLIM
                                   DO ICHARG=ICHLIM,NDISOS
C
                                      DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                         DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
                                       GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X1(MPX,MX,NPX,NX)
C
                                       GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                         END DO
                                      END DO
C
                                   END DO
                                END DO
C
                            END IF
C
                            IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                                DO KARTEZ=0,KARLIM
                                   DO ICHARG=ICHLIM,NDISOS
C
                                      DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                         DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
                                       GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                         END DO
                                      END DO
C
                                   END DO
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.5) THEN
C
                                DO KARTEZ=0,KARLIM
                                   DO ICHARG=ICHLIM,NDISOS
C
                                      DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                         DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
                                       GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                         END DO
                                      END DO
C
                                   END DO
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.6) THEN
C
                                DO KARTEZ=0,KARLIM
                                   DO ICHARG=ICHLIM,NDISOS
C
                                      DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                         DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
                                       GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X4(MPX,MX,NPX,NX)
     *
     *                            +Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)*2
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)*2
     *
     *                            +Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)*2
C
                                         END DO
                                      END DO
C
                                   END DO
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.7) THEN
C
                                DO KARTEZ=0,KARLIM
                                   DO ICHARG=ICHLIM,NDISOS
C
                                      DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                         DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
                                       GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X4(MPX,MX,NPX,NX)
     *
     *                            +Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)*2
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)*2
     *
     *                            +Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)*2
C
                                       GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X6(MPX,MX,NPX,NX)
     *
     *                            +Z_HE60(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE06(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE42(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)*3
     *
     *                            +Z_HE24(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)*3
     *
     *                            +Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)*3
     *
     *                            +Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)*3
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X4(MPX,MX,NPX,NX)*3
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X4(MPX,MX,NPX,NX)*3
     *
     *                            +Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X2(MPX,MX,NPX,NX)*6
C
                                         END DO
                                      END DO
C
                                   END DO
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.8) THEN
C
                                DO KARTEZ=0,KARLIM
                                   DO ICHARG=ICHLIM,NDISOS
C
                                      DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                         DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
                                       GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX21(MPX,MX,NPX,NX)
     *
     *                            +Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX22(MPX,MX,NPX,NX)
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                         END DO
                                      END DO
C
                                   END DO
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.9) THEN
C
                                DO KARTEZ=0,KARLIM
                                   DO ICHARG=ICHLIM,NDISOS
C
                                      DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                         DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
                                       GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX21(MPX,MX,NPX,NX)
     *
     *                            +Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX22(MPX,MX,NPX,NX)
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX41(MPX,MX,NPX,NX)
     *
     *                            +Z_HE30(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE03(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX21(MPX,MX,NPX,NX)*2
     *
     *                            +Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX21(MPX,MX,NPX,NX)*2
     *
     *                            +Z_HE11(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)*2
C
                                       GAUFIL(4,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(4,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX42(MPX,MX,NPX,NX)
     *
     *                            +Z_HE40(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE04(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE01(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX22(MPX,MX,NPX,NX)
     *
     *                            +Z_HE10(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX22(MPX,MX,NPX,NX)
     *
     *                            +Z_HE12(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX21(MPX,MX,NPX,NX)
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX21(MPX,MX,NPX,NX)
     *
     *                            +Z_HE21(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(5,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(5,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX43(MPX,MX,NPX,NX)
     *
     *                            +Z_HE50(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE05(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)
     *
     *                            +Z_HE02(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX22(MPX,MX,NPX,NX)*2
     *
     *                            +Z_HE20(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAUX22(MPX,MX,NPX,NX)*2
     *
     *                            +Z_HE22(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
     *                            *GAU_X0(MPX,MX,NPX,NX)*2
C
                                         END DO
                                      END DO
C
                                   END DO
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.13) THEN
C
                                DO ICHARG=ICHLIM,NDISOS
C
                                   DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                      DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
C                                        THE SCALAR S-O FIELD
C
                                         GAUFIL(0,IBRA,IKET,0,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,0,ICHARG)
     *
     *                                 +Z_1001(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 -Z_0110(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0010(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
     *
     *                                 -Z_0001(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 +Z_0100(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 -Z_1000(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
C
C                                        THE VECTOR S-O FIELD
C
                                         GAUFIL(0,IBRA,IKET,1,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,1,ICHARG)
     *
     *                                 +Z_1001(MPY,MPZ,NPY,NPZ,0,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 -Z_0110(MPY,MPZ,NPY,NPZ,0,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
C
                                         GAUFIL(0,IBRA,IKET,2,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,2,ICHARG)
     *
     *                                 +Z_0010(MPY,MPZ,NPY,NPZ,0,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
     *
     *                                 -Z_0001(MPY,MPZ,NPY,NPZ,0,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
C
                                         GAUFIL(0,IBRA,IKET,3,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,3,ICHARG)
     *
     *                                 +Z_0100(MPY,MPZ,NPY,NPZ,0,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 -Z_1000(MPY,MPZ,NPY,NPZ,0,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
C
                                      END DO
                                   END DO
C
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.14) THEN
C
                                DO ICHARG=ICHLIM,NDISOS
C
                                   DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                      DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
C                                        THE VECTOR T-O FIELD K'* X K
C
C                                        SIGMA_1 TIMES SIGMA_2
C
C                                        FACTORS OF 3/2 BELOW COMBINE:
C                                        - FACTOR OF 3/2 IN THE S12
C
                                         GAUFIL(0,IBRA,IKET,1,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,1,ICHARG)
     *
     *                                +(Z_0000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX11(MPX,MX,NPX,NX)
     *
     *                                 +Z_0100(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 +Z_0001(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX))*1.5D0
C
                                         GAUFIL(0,IBRA,IKET,2,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,2,ICHARG)
     *
     *                                +(Z_1000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
     *
     *                                 +Z_1100(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_1001(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*1.5D0
C
                                         GAUFIL(0,IBRA,IKET,3,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,3,ICHARG)
     *
     *                                +(Z_0010(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
     *
     *                                 +Z_0110(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0011(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*1.5D0
C
C                                        SIGMA_2 TIMES SIGMA_1
C
C                                        FACTORS OF 3/2 BELOW COMBINE:
C                                        - FACTOR OF 3/2 IN THE S12
C
                                         GAUFIL(0,IBRA,IKET,1,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,1,ICHARG)
     *
     *                                +(Z_0000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX11(MPX,MX,NPX,NX)
     *
     *                                 +Z_1000(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
     *
     *                                 +Z_0010(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX))*1.5D0
C
                                         GAUFIL(0,IBRA,IKET,2,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,2,ICHARG)
     *
     *                                +(Z_0100(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 +Z_1100(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0110(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*1.5D0
C
                                         GAUFIL(0,IBRA,IKET,3,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,3,ICHARG)
     *
     *                                +(Z_0001(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 +Z_1001(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0011(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*1.5D0
C
C                                        THE VECTOR T-O FIELD
C
C                                        SIGMA_1 DOT SIGMA_2
C
C                                        FACTORS OF -1 BELOW COMES FROM:
C                                        - FACTOR OF (-1) IN THE S12
C
                                         GAUFIL(0,IBRA,IKET,1,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,1,ICHARG)
     *
     *                                -(Z_0000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX11(MPX,MX,NPX,NX)
     *
     *                                 +Z_1100(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0011(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))
C
                                         GAUFIL(0,IBRA,IKET,2,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,2,ICHARG)
     *
     *                                -(Z_0000(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX11(MPX,MX,NPX,NX)
     *
     *                                 +Z_1100(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0011(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))
C
                                         GAUFIL(0,IBRA,IKET,3,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,3,ICHARG)
     *
     *                                -(Z_0000(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX11(MPX,MX,NPX,NX)
     *
     *                                 +Z_1100(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0011(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))
C
                                     END DO
                                   END DO
C
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.15) THEN
C
                                DO ICHARG=ICHLIM,NDISOS
C
                                   DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                      DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
C                                        THE VECTOR T-E FIELD K'* X K'*
C
C                                        SIGMA_1 TIMES SIGMA_2
C                                       +SIGMA_2 TIMES SIGMA_1
C
C                                        FACTORS OF -3/2 BELOW COMBINE:
C                                        - FACTOR OF 3/2 IN THE S12
C                                        - FACTOR OF 2 FROM THE SUM
C                                          OF TWO ORDERS OF SPIN ABOVE
C                                        - FACTOR OF 1/2 FROM THE TWO
C                                          TERMS IN THE EVEN TENSOR
C                                        - FACTOR OF -1 EQUAL i^2 FROM
C                                          BOTH MOMENTA
C
                                         GAUFIL(0,IBRA,IKET,1,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,1,ICHARG)
     *
     *                                -(Z_0000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX20(MPX,MX,NPX,NX)
     *
     *                                 +Z_1000(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 +Z_0010(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX))*1.5D0
C
                                         GAUFIL(0,IBRA,IKET,2,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,2,ICHARG)
     *
     *                                -(Z_1000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 +Z_2000(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_1010(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*1.5D0
C
                                         GAUFIL(0,IBRA,IKET,3,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,3,ICHARG)
     *
     *                                -(Z_0010(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX10(MPX,MX,NPX,NX)
     *
     *                                 +Z_1010(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0020(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*1.5D0
C
C                                       THE VECTOR T-E FIELD K'* DOT K'*
C
C                                        SIGMA_1 DOT SIGMA_2
C
C                                        FACTORS OF 1/2 BELOW COMBINE:
C                                        - FACTOR OF (-1) IN THE S12
C                                        - FACTOR OF 1/2 FROM THE TWO
C                                          TERMS IN THE EVEN TENSOR
C                                        - FACTOR OF -1 EQUAL i^2 FROM
C                                          BOTH MOMENTA
C
                                         GAUFIL(0,IBRA,IKET,1,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,1,ICHARG)
     *
     *                                +(Z_0000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX20(MPX,MX,NPX,NX)
     *
     *                                 +Z_2000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0020(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*0.5D0
C
                                         GAUFIL(0,IBRA,IKET,2,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,2,ICHARG)
     *
     *                                +(Z_0000(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX20(MPX,MX,NPX,NX)
     *
     *                                 +Z_2000(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0020(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*0.5D0
C
                                         GAUFIL(0,IBRA,IKET,3,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,3,ICHARG)
     *
     *                                +(Z_0000(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX20(MPX,MX,NPX,NX)
     *
     *                                 +Z_2000(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0020(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*0.5D0
C
                                     END DO
                                   END DO
C
                                END DO
C
                            END IF
C
                            IF (I_PART.EQ.16) THEN
C
                                DO ICHARG=ICHLIM,NDISOS
C
                                   DO NPZ=0,LZOXYV(NPX,NPY,IP)
                                      DO MPZ=0,LZOXYV(MPX,MPY,I)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,I)
                                         IKET=INDICE(NPX,NPY,NPZ,IP)
C
C                                        THE VECTOR T-E FIELD K X K
C
C                                        SIGMA_1 TIMES SIGMA_2
C                                       +SIGMA_2 TIMES SIGMA_1
C
C                                        FACTORS OF -3/2 BELOW COMBINE:
C                                        - FACTOR OF 3/2 IN THE S12
C                                        - FACTOR OF 2 FROM THE SUM
C                                          OF TWO ORDERS OF SPIN ABOVE
C                                        - FACTOR OF 1/2 FROM THE TWO
C                                          TERMS IN THE EVEN TENSOR
C                                        - FACTOR OF -1 EQUAL i^2 FROM
C                                          BOTH MOMENTA
C
                                         GAUFIL(0,IBRA,IKET,1,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,1,ICHARG)
     *
     *                                -(Z_0000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX02(MPX,MX,NPX,NX)
     *
     *                                 +Z_0100(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
     *
     *                                 +Z_0001(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX))*1.5D0
C
                                         GAUFIL(0,IBRA,IKET,2,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,2,ICHARG)
     *
     *                                -(Z_0100(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
     *
     *                                 +Z_0200(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0101(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*1.5D0
C
                                         GAUFIL(0,IBRA,IKET,3,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,3,ICHARG)
     *
     *                                -(Z_0001(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX01(MPX,MX,NPX,NX)
     *
     *                                 +Z_0101(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0002(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*1.5D0
C
C                                        THE VECTOR T-E FIELD K DOT K
C
C                                        SIGMA_1 DOT SIGMA_2
C
C                                        FACTORS OF 1/2 BELOW COMBINE:
C                                        - FACTOR OF (-1) IN THE S12
C                                        - FACTOR OF 1/2 FROM THE TWO
C                                          TERMS IN THE EVEN TENSOR
C                                        - FACTOR OF -1 EQUAL i^2 FROM
C                                          BOTH MOMENTA
C
                                         GAUFIL(0,IBRA,IKET,1,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,1,ICHARG)
     *
     *                                +(Z_0000(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX02(MPX,MX,NPX,NX)
     *
     *                                 +Z_0200(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0002(MPY,MPZ,NPY,NPZ,1,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*0.5D0
C
                                         GAUFIL(0,IBRA,IKET,2,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,2,ICHARG)
     *
     *                                +(Z_0000(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX02(MPX,MX,NPX,NX)
     *
     *                                 +Z_0200(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0002(MPY,MPZ,NPY,NPZ,2,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*0.5D0
C
                                         GAUFIL(0,IBRA,IKET,3,ICHARG)
     *                                  =GAUFIL(0,IBRA,IKET,3,ICHARG)
     *
     *                                +(Z_0000(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX02(MPX,MX,NPX,NX)
     *
     *                                 +Z_0200(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX)
     *
     *                                 +Z_0002(MPY,MPZ,NPY,NPZ,3,ICHARG)
     *                                 *FSTX00(MPX,MX,NPX,NX))*0.5D0
C
                                     END DO
                                   END DO
C
                                END DO
C
                            END IF
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                         END DO
                      END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                   END DO
                END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C=======================================================================
C        HERE ENDS CALCULATION OF THE AVERAGE FIELDS
C=======================================================================
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C=======================================================================
C        HERE WE RECOMBINE THE CALCULATED TERMS INTO THOSE CORRESPONDING
C        TO THE SELECTED TYPE OF COUPLING CONSTANTS
C=======================================================================
C
      IF (I_PART.EQ.9) THEN
C
          DO KARTEZ=0,KARLIM
             DO ICHARP=ICHLIM,NDISOS
                DO ICHARG=ICHLIM,NDISOS
C
                   TERT41=GAUAVR(3,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                   +GAUAVR(5,KARTEZ,KARTEZ,ICHARP,ICHARG)
C
                   TERT42=GAUAVR(4,KARTEZ,KARTEZ,ICHARP,ICHARG)*2
C
                   TERT43=GAUAVR(3,KARTEZ,KARTEZ,ICHARP,ICHARG)
     *                   -GAUAVR(5,KARTEZ,KARTEZ,ICHARP,ICHARG)
C
                   GAUAVR(3,KARTEZ,KARTEZ,ICHARP,ICHARG)=TERT41
                   GAUAVR(4,KARTEZ,KARTEZ,ICHARP,ICHARG)=TERT42
                   GAUAVR(5,KARTEZ,KARTEZ,ICHARP,ICHARG)=TERT43
C
               END DO
            END DO
          END DO
C
          DO KARTEZ=0,KARLIM
             DO ICHARG=ICHLIM,NDISOS
                DO IBRA=1,LDBASE
                   DO IKET=1,LDBASE
C
                      TERT41=GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                      +GAUFIL(5,IBRA,IKET,KARTEZ,ICHARG)
C
                      TERT42=GAUFIL(4,IBRA,IKET,KARTEZ,ICHARG)*2
C
                      TERT43=GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                      -GAUFIL(5,IBRA,IKET,KARTEZ,ICHARG)
C
                      GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)=TERT41
                      GAUFIL(4,IBRA,IKET,KARTEZ,ICHARG)=TERT42
                      GAUFIL(5,IBRA,IKET,KARTEZ,ICHARG)=TERT43
C
                   END DO
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
                       DEALLOCATE (Y_HEL0,Z_HE00)
      IF (I_PART.EQ.0) DEALLOCATE (Y_HEL1,Z_HE10,Z_HE01)
      IF (I_PART.GE.5.AND.I_PART.LE.7) THEN
                       DEALLOCATE (Y_HEL2,Z_HE20,Z_HE02)
      IF (I_PART.GE.6) DEALLOCATE (Y_HEL4,Z_HE40,Z_HE04,Z_HE22)
      IF (I_PART.GE.7) DEALLOCATE (Y_HEL6,Z_HE60,Z_HE06,Z_HE42,Z_HE24)
      END IF
      IF (I_PART.EQ.8.AND.I_PART.LE.10) THEN
                       DEALLOCATE (Y_HEL1,Z_HE10,Z_HE01)
                       DEALLOCATE (Y_HEL2,Z_HE20,Z_HE02)
          IF (I_PART.GE.9) THEN
                       DEALLOCATE (Y_HEL3,Z_HE30,Z_HE03,Z_HE12,Z_HE21)
                       DEALLOCATE (Y_HEL4,Z_HE40,Z_HE04,Z_HE11,Z_HE22)
                       DEALLOCATE (Y_HEL5,Z_HE50,Z_HE05)
          END IF
      END IF
      IF (I_PART.EQ.11)
     *    DEALLOCATE (Y_HEL1,Y_HEL2,Z_HE10,Z_HE01,Z_HE11,Z_HE20)
C
C=======================================================================
C
      CALL CPUTIM('GAUENE',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GAUDIQ(ISIMPY,I_FIEL,I_PART,IDENSI,DIQCOF)
C=======================================================================
      USE MAD_PP
      USE MAD_PM
      USE MAP_PP
      USE MAP_PM
      USE GAUSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDOSC2=(NDOSCI+1)*(NDOSCI+1))
C=======================================================================
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          TERT41,TERT42,TERT43
      COMPLEX
     *          D_HELP(0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS),
     *          D_HXZ0(0:NDKART,0:NDISOS),
     *          D_HXZ1(0:NDKART,0:NDISOS)
C
      COMPLEX
     *          E_HELP(0:NDKART,0:NDISOS)
C
      COMPLEX
     *          GAXVEC,GAYVEC,GAZVEC,
     *          GAXVEI,GAYVEI,GAZVEI
      COMPLEX
     *          GPXVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GPYVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GPZVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GMXVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GMYVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GMZVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GPXVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GPYVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GPZVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GMXVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GMYVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GMZVEI(NDOSC2,0:NDOSCI,0:NDOSCI)
C
      COMPLEX
     *          SYMAUX(0:NDKART,0:NDISOS),
     *          ASYAUX(0:NDKART,0:NDISOS)
C
      INTEGER
     *          YPZP(0:NDOSC2),
     *          YPZM(0:NDOSC2),
     *          YMZP(0:NDOSC2),
     *          YMZM(0:NDOSC2),
     *          YPZPXP(0:NDOSC2,0:NDOSC2),
     *          YPZPXM(0:NDOSC2,0:NDOSC2),
     *          YPZMXP(0:NDOSC2,0:NDOSC2),
     *          YMZPXP(0:NDOSC2,0:NDOSC2),
     *          YPZMXM(0:NDOSC2,0:NDOSC2),
     *          YMZMXP(0:NDOSC2,0:NDOSC2),
     *          YMZPXM(0:NDOSC2,0:NDOSC2),
     *          YMZMXM(0:NDOSC2,0:NDOSC2)
C
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: Y_HXZ0
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: Y_HXZ1
C
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HX00
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HX01
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HX10
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HX11
C
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: X_H000
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: X_H001
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: X_H010
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: X_H100
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: X_H011
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: X_H110
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: X_H101
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: X_H111
C
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: X_FX00
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: X_FX01
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: X_FX10
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: X_FX11
C
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: Z_FXZ0
      COMPLEX, DIMENSION(:,:,:,:,:),   ALLOCATABLE :: Z_FXZ1
C
      DIMENSION
     *          GPXEIG(NDOSC2),GPYEIG(NDOSC2),GPZEIG(NDOSC2),
     *          GMXEIG(NDOSC2),GMYEIG(NDOSC2),GMZEIG(NDOSC2)
C=======================================================================
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /B_PHAS/ JPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /GA_DIQ/ GAXEIG(NDOSC2),GAYEIG(NDOSC2),GAZEIG(NDOSC2),
     *
     *                GAXVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAYVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAZVEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *
     *                GAXVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAYVEI(NDOSC2,0:NDOSCI,0:NDOSCI),
     *                GAZVEI(NDOSC2,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /MNDDIQ/ KXDDIQ(0:NDOSCI,0:NDOSCI),LXDDIQ(NDOSC2,2),NXDDIQ,
     *                KYDDIQ(0:NDOSCI,0:NDOSCI),LYDDIQ(NDOSC2,2),NYDDIQ,
     *                KZDDIQ(0:NDOSCI,0:NDOSCI),LZDDIQ(NDOSC2,2),NZDDIQ
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('GAUDIQ',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE AVERAGE ENERGIES AND FIELDS
C        CORRESPONDING TO  THE  FINITE-RANGE  GAUSSIAN  INTERACTION
C=======================================================================
C        THE SUBROUTINE CAN PERFORM CALCULATIONS BY ASSUMING  (IPAXYZ=1)
C        OR NOT ASSUMING (IPAXYZ=0) THAT THE FORMAFACTORS  DELIVERED  BY
C        "DEFGOG" CONSERVE PARITIES IN ALL  THREE  CARTESIAN  DIRECTIONS
C        SIMULTANEOUSLY
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C
      LIMSET=0
C
C=======================================================================
C        CALCULATION FOR THE YUKAWA INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.0) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=0
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE COULOMB EXCHANGE INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.1) THEN
C
          KARLIM=NDKART
          ICHLIM=NDISOS
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE COULOMB DIRECT INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.2) THEN
C
          KARLIM=0
          ICHLIM=NDISOS
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE GOGNY INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.3) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE REGULARIZED SKYRME INTERACTION T2=-T1
C=======================================================================
C
      IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE REGULARIZED SKYRME OR SEPARABLE INTERACTION
C        (PSEUDOPOTENTIAL)
C=======================================================================
C
      IF (I_PART.GE.8.AND.I_PART.LE.9) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
C=======================================================================
C         ATTENTION: SOME ELEMENTS OF THE N3LORD=-3 (I_PART=10) CASE ARE
C                    ALREADY PROGRAMMED, BUT THE MAIN WORK IS  N O T YET
C                    DONE.
C=======================================================================
C
      END IF
C
C=======================================================================
C        TESTING THE INPUT VALUE OF I_PART
C=======================================================================
C
      IF (LIMSET.NE.1)
     *    STOP 'GAUDIQ CALLED WITH AN INCORRECT VALUE OF I_PART'
C
C=======================================================================
C     COUNTING THE EIGENVALUES WITH ABSOLUTE VALUE GREATER THAN DIQCOF
C=======================================================================
C
C                               ATTENTION!
C     DIQCOF IS DEFINED AS A CUT-OFF RELATIVE TO THE LARGEST EIGENVALUE,
C     SO WE SCALE GA_EIG WHEN SELECTING THE INDICES WE ITERATE ON.
C     IN OTHER WORDS, WE SELECT |\lambda / \lambda_max| >= \lambda_c .
C
      IDIQ1D=0
C
      DO NJ=1,NYDDIQ
C
         IF (ABS(GAYEIG(NJ)/GAYEIG(1)).GE.DIQCOF) THEN
             IDIQ1D=IDIQ1D+1
         END IF
C
      END DO
C
      NDIQ1D=IDIQ1D
C
C=======================================================================
C        SEPARATING THE SYMMETRIC AND ANTI-SYMMETRIC PARTS OF
C                 THE EIGENVECTORS IN THE X DIRECTION
C=======================================================================
C
      GPXEIG(:)=0.0D0
      GMXEIG(:)=0.0D0
C
C=======================================================================
C        BELOW STARTS THE COUNTERS FOR SYMMETRIC/ANTI-SYMM EIGENVECTORS
C=======================================================================
C
      NIP=0
      NIM=0
C
      DO NI=1,NDIQ1D
C
         DIFPLU=0.0D0
         DIFMIN=0.0D0
C
C=======================================================================
C        GETTING THE MAXIMUM SUM/DIFFERENCE OF NP<->N EIGENVECTORS
C=======================================================================
C
         DO N=0,NXMAXV(1)
            DO NP=N,NXMAXV(1)
C
               DIFPLU=MAX(DIFPLU,ABS(GAXVEC(NI,NP,N) + GAXVEC(NI,N,NP)))
               DIFMIN=MAX(DIFMIN,ABS(GAXVEC(NI,NP,N) - GAXVEC(NI,N,NP)))
C
            END DO
         END DO
C
C=======================================================================
C                     STORES THE SYMMETRIC EIGENVECTORS
C=======================================================================
C
         IF (DIFPLU.GT.DIFMIN) THEN
C
             NIP=NIP+1
C
             DO N=0,NXMAXV(1)
C
                DO NP=0,NXMAXV(1)
C
C                  FACTOR OF 2 OUTSIDE THE DIAGONAL ONLY
                   GPXVEC(NIP,NP,N)=GAXVEC(NI,N,NP)
                   GPXVEI(NIP,NP,N)=GAXVEI(NI,NP,N) + GAXVEI(NI,NP,N)
C
                END DO
C
                GPXVEC(NIP,N,N)=GAXVEC(NI,N,N)
                GPXVEI(NIP,N,N)=GAXVEI(NI,N,N)
C
             END DO
C
             GPXEIG(NIP)=GAXEIG(NI)
C
C=======================================================================
C               STORES THE ANTI-SYMMETRIC EIGENVECTORS
C=======================================================================
C
         ELSE
C
             NIM=NIM+1
C
             DO N=0,NXMAXV(1)
                DO NP=0,NXMAXV(1)
C                  ! GMXVEC IS TRANSPOSED
                   GMXVEC(NIM,NP,N)=GAXVEC(NI,N,NP)
                   GMXVEI(NIM,NP,N)=GAXVEI(NI,NP,N) - GAXVEI(NI,N,NP)
C
                END DO
             END DO
C
             GMXEIG(NIM)=GAXEIG(NI)
C
         END IF
C
      END DO
C
C=======================================================================
C        SEPARATING THE SYMMETRIC AND ANTI-SYMMETRIC PARTS OF
C                 THE EIGENVECTORS IN THE Y DIRECTION
C=======================================================================
C
      GPYEIG(:)=0.0D0
      GMYEIG(:)=0.0D0
C
C=======================================================================
C        BELOW STARTS THE COUNTERS FOR SYMMETRIC/ANTI-SYMM EIGENVECTORS
C=======================================================================
C
      NJP=0
      NJM=0
C
      DO NI=1,NDIQ1D
C
         DIFPLU=0.0D0
         DIFMIN=0.0D0
C
C=======================================================================
C        GETTING THE MAXIMUM SUM/DIFFERENCE OF NP<->N EIGENVECTORS
C=======================================================================
C
         DO N=0,NYMAXV(1)
            DO NP=N,NYMAXV(1)
C
               DIFPLU=MAX(DIFPLU,ABS(GAYVEC(NI,NP,N) + GAYVEC(NI,N,NP)))
               DIFMIN=MAX(DIFMIN,ABS(GAYVEC(NI,NP,N) - GAYVEC(NI,N,NP)))
C
            END DO
         END DO
C
C=======================================================================
C                     STORES THE SYMMETRIC EIGENVECTORS
C=======================================================================
C
         IF (DIFPLU.GT.DIFMIN) THEN
C
             NJP=NJP+1
C
             DO N=0,NYMAXV(1)
C
                DO NP=0,NYMAXV(1)
C
                   GPYVEC(NJP,NP,N)=GAYVEC(NI,N,NP)
                   GPYVEI(NJP,NP,N)=GAYVEI(NI,NP,N) + GAYVEI(NI,N,NP)
C
                END DO
C
C               FACTOR OF 2 OUTSIDE THE DIAGONAL ONLY
                GPYVEC(NJP,N,N)=GAYVEC(NI,N,N)
                GPYVEI(NJP,N,N)=GAYVEI(NI,N,N)
C
             END DO
C
             GPYEIG(NJP)=GAYEIG(NI)
C
C=======================================================================
C               STORES THE ANTI-SYMMETRIC EIGENVECTORS
C=======================================================================
C
         ELSE
C
             NJM=NJM+1
C
             DO N=0,NYMAXV(1)
                DO NP=0,NYMAXV(1)
C
                   ! GMYVEC IS TRANSPOSED
                   GMYVEC(NJM,NP,N)=GAYVEC(NI,N,NP)
                   GMYVEI(NJM,NP,N)=GAYVEI(NI,NP,N) - GAYVEI(NI,N,NP)
C
                END DO
             END DO
C
             GMYEIG(NJM)=GAYEIG(NI)
C
         END IF
C
      END DO
C
C=======================================================================
C        SEPARATING THE SYMMETRIC AND ANTI-SYMMETRIC PARTS OF
C                 THE EIGENVECTORS IN THE Z DIRECTION
C=======================================================================
C
      GPZEIG(:)=0.0D0
      GMZEIG(:)=0.0D0
C
C=======================================================================
C        BELOW STARTS THE COUNTERS FOR SYMMETRIC/ANTI-SYMM EIGENVECTORS
C=======================================================================
C
      NLP=0
      NLM=0
C
      DO NI=1,NDIQ1D
C
         DIFPLU=0.0D0
         DIFMIN=0.0D0
C
C=======================================================================
C        GETTING THE MAXIMUM SUM/DIFFERENCE OF NP<->N EIGENVECTORS
C=======================================================================
C
         DO N=0,NZMAXV(1)
            DO NP=N,NZMAXV(1)
C
               DIFPLU=MAX(DIFPLU,ABS(GAZVEC(NI,NP,N) + GAZVEC(NI,N,NP)))
               DIFMIN=MAX(DIFMIN,ABS(GAZVEC(NI,NP,N) - GAZVEC(NI,N,NP)))
C
            END DO
         END DO
C
C=======================================================================
C                     STORES THE SYMMETRIC EIGENVECTORS
C=======================================================================
C
         IF (DIFPLU.GT.DIFMIN) THEN
C
             NLP=NLP+1
C
             DO N=0,NZMAXV(1)
C
                DO NP=0,NZMAXV(1)
C
                   GPZVEC(NLP,NP,N)=GAZVEC(NI,N,NP)
                   GPZVEI(NLP,NP,N)=GAZVEI(NI,NP,N) + GAZVEI(NI,N,NP)
C
                END DO
C
C               FACTOR OF 2 OUTSIDE THE DIAGONAL ONLY
                GPZVEC(NLP,N,N)=GAZVEC(NI,N,N)
                GPZVEI(NLP,N,N)=GAZVEI(NI,N,N)
C
             END DO
C
             GPZEIG(NLP)=GAZEIG(NI)
C
C=======================================================================
C               STORES THE ANTI-SYMMETRIC EIGENVECTORS
C=======================================================================
C
         ELSE
C
             NLM=NLM+1
C
             DO N=0,NZMAXV(1)
                DO NP=0,NZMAXV(1)
C
                   ! GMZVEC IS TRANSPOSED
                   GMZVEC(NLM,NP,N)=GAZVEC(NI,N,NP)
                   GMZVEI(NLM,NP,N)=GAZVEI(NI,NP,N) - GAZVEI(NI,N,NP)
C
                END DO
             END DO
C
             GMZEIG(NLM)=GAZEIG(NI)
C
         END IF
C
      END DO
C
C=======================================================================
C     COUNTING THE EIGENVALUES WITH ABSOLUTE VALUE GREATER THAN DIQCOF
C=======================================================================
C
      YPZP(:)    =0
      YPZM(:)    =0
      YMZP(:)    =0
      YMZM(:)    =0
C
      YPZPXP(:,:)=0
      YPZPXM(:,:)=0
      YPZMXM(:,:)=0
      YPZMXP(:,:)=0
      YMZPXP(:,:)=0
      YMZPXM(:,:)=0
      YMZMXM(:,:)=0
      YMZMXP(:,:)=0
C
C                               ATTENTION!
C     DIQCOF IS DEFINED AS A CUT-OFF RELATIVE TO THE LARGEST EIGENVALUE,
C     SO WE SCALE GA_EIG WHEN SELECTING THE INDICES WE ITERATE ON.
C     IN OTHER WORDS, WE SELECT |\lambda / \lambda_max| >= \lambda_c .
C
C=======================================================================
C                     FOR A PRODUCT OF TWO EIGENVALUES
C=======================================================================
C
C                       SYMMETRIC Y AND SYMMETRIC Z
      DO NJ=1,NJP
C
         IDIQ2D=0
C
         DO NL=1,NLP
C
            IF (ABS(GPYEIG(NJ)*GPZEIG(NL) / (GPYEIG(1)*GPZEIG(1)))
     *                                                .GT.DIQCOF) THEN
                IDIQ2D=IDIQ2D+1
            ELSE
                EXIT
            END IF
C
         END DO
C
         YPZP(NJ)=IDIQ2D
C
      END DO
C
C                       SYMMETRIC Y AND ANTI-SYMMETRIC Z
      DO NJ=1,NJP
C
         IDIQ2D=0
C
         DO NL=1,NLM
C
            IF (ABS(GPYEIG(NJ)*GMZEIG(NL) / (GPYEIG(1)*GMZEIG(1)))
     *                                                .GT.DIQCOF) THEN
                IDIQ2D=IDIQ2D+1
            ELSE
                EXIT
            END IF
C
         END DO
C
         YPZM(NJ)=IDIQ2D
C
      END DO
C
C                       ANTI-SYMMETRIC Y AND SYMMETRIC Z
      DO NJ=1,NJM
C
         IDIQ2D=0
C
         DO NL=1,NLP
C
            IF (ABS(GMYEIG(NJ)*GPZEIG(NL) / (GMYEIG(1)*GPZEIG(1)))
     *                                                .GT.DIQCOF) THEN
                IDIQ2D=IDIQ2D+1
            ELSE
                EXIT
            END IF
C
         END DO
C
         YMZP(NJ)=IDIQ2D
C
      END DO
C
C                   ANTI-SYMMETRIC Y AND ANTI-SYMMETRIC Z
      DO NJ=1,NJM
C
         IDIQ2D=0
C
         DO NL=1,NLM
C
            IF (ABS(GMYEIG(NJ)*GMZEIG(NL) / (GMYEIG(1)*GMZEIG(1)))
     *                                                .GT.DIQCOF) THEN
                IDIQ2D=IDIQ2D+1
            ELSE
                EXIT
            END IF
C
         END DO
C
         YMZM(NJ)=IDIQ2D
C
      END DO
C
C=======================================================================
C                  FOR A PRODUCT OF THREE EIGENVALUES
C=======================================================================
C
C             SYMMETRIC Y, SYMMETRIC Z AND SYMMETRIC X
      DO NJ=1,NJP
         DO NL=1,YPZP(NJ)
C
            IDIQ3D=0
C
            DO NI=1,NIP
C
               IF (ABS(GPXEIG(NI)*GPYEIG(NJ)*GPZEIG(NL) /
     *                (GPXEIG(1) *GPYEIG(1) *GPZEIG(1))).GT.DIQCOF) THEN
                   IDIQ3D=IDIQ3D+1
               ELSE
                   EXIT
               END IF
C
            END DO
C
            YPZPXP(NL,NJ)=IDIQ3D
C
         END DO
      END DO
C
C             SYMMETRIC Y, SYMMETRIC Z AND ANTI-SYMMETRIC X
      DO NJ=1,NJP
         DO NL=1,YPZP(NJ)
C
            IDIQ3D=0
C
            DO NI=1,NIM
C
               IF (ABS(GMXEIG(NI)*GPYEIG(NJ)*GPZEIG(NL) /
     *                (GMXEIG(1) *GPYEIG(1) *GPZEIG(1))).GT.DIQCOF) THEN
                   IDIQ3D=IDIQ3D+1
               ELSE
                   EXIT
               END IF
C
            END DO
C
            YPZPXM(NL,NJ)=IDIQ3D
C
         END DO
      END DO
C
C             SYMMETRIC Y, ANTI-SYMMETRIC Z AND SYMMETRIC X
      DO NJ=1,NJP
         DO NL=1,YPZM(NJ)
C
            IDIQ3D=0
C
            DO NI=1,NIP
C
               IF (ABS(GPXEIG(NI)*GPYEIG(NJ)*GMZEIG(NL) /
     *                (GPXEIG(1) *GPYEIG(1) *GMZEIG(1))).GT.DIQCOF) THEN
                      IDIQ3D=IDIQ3D+1
                  ELSE
                      EXIT
                  END IF
C
            END DO
C
            YPZMXP(NL,NJ)=IDIQ3D
C
         END DO
      END DO
C
C             SYMMETRIC Y, ANTI-SYMMETRIC Z AND ANTI-SYMMETRIC X
      DO NJ=1,NJP
         DO NL=1,YPZM(NJ)
C
            IDIQ3D=0
C
            DO NI=1,NIM
C
               IF (ABS(GMXEIG(NI)*GPYEIG(NJ)*GMZEIG(NL) /
     *                (GMXEIG(1) *GPYEIG(1) *GMZEIG(1))).GT.DIQCOF) THEN
                      IDIQ3D=IDIQ3D+1
                  ELSE
                      EXIT
                  END IF
C
            END DO
C
            YPZMXM(NL,NJ)=IDIQ3D
C
         END DO
      END DO
C
C            ANTI-SYMMETRIC Y, SYMMETRIC Z AND SYMMETRIC X
      DO NJ=1,NJM
         DO NL=1,YMZP(NJ)
C
            IDIQ3D=0
C
            DO NI=1,NIP
C
               IF (ABS(GPXEIG(NI)*GMYEIG(NJ)*GPZEIG(NL) /
     *                (GPXEIG(1) *GMYEIG(1) *GPZEIG(1))).GT.DIQCOF) THEN
                   IDIQ3D=IDIQ3D+1
               ELSE
                   EXIT
               END IF
C
            END DO
C
            YMZPXP(NL,NJ)=IDIQ3D
C
         END DO
      END DO
C
C             ANTI-SYMMETRIC Y, SYMMETRIC Z AND ANTI-SYMMETRIC X
      DO NJ=1,NJM
         DO NL=1,YMZP(NJ)
C
            IDIQ3D=0
C
            DO NI=1,NIM
C
               IF (ABS(GMXEIG(NI)*GMYEIG(NJ)*GPZEIG(NL) /
     *                (GMXEIG(1) *GMYEIG(1) *GPZEIG(1))).GT.DIQCOF) THEN
                   IDIQ3D=IDIQ3D+1
               ELSE
                   EXIT
               END IF
C
            END DO
C
            YMZPXM(NL,NJ)=IDIQ3D
C
         END DO
      END DO
C
C             ANTI-SYMMETRIC Y, ANTI-SYMMETRIC Z AND SYMMETRIC X
      DO NJ=1,NJM
         DO NL=1,YMZM(NJ)
C
            IDIQ3D=0
C
            DO NI=1,NIP
C
               IF (ABS(GPXEIG(NI)*GMYEIG(NJ)*GMZEIG(NL) /
     *                (GPXEIG(1) *GMYEIG(1) *GMZEIG(1))).GT.DIQCOF) THEN
                      IDIQ3D=IDIQ3D+1
                  ELSE
                      EXIT
                  END IF
C
            END DO
C
            YMZMXP(NL,NJ)=IDIQ3D
C
         END DO
      END DO
C
C             ANTI-SYMMETRIC Y, ANTI-SYMMETRIC Z AND ANTI-SYMMETRIC X
      DO NJ=1,NJM
         DO NL=1,YMZM(NJ)
C
            IDIQ3D=0
C
            DO NI=1,NIM
C
               IF (ABS(GMXEIG(NI)*GMYEIG(NJ)*GMZEIG(NL) /
     *                (GMXEIG(1) *GMYEIG(1) *GMZEIG(1))).GT.DIQCOF) THEN
                      IDIQ3D=IDIQ3D+1
                  ELSE
                      EXIT
                  END IF
C
            END DO
C
            YMZMXM(NL,NJ)=IDIQ3D
C
         END DO
      END DO
C
C=======================================================================
C        ALLOCATING THE OTHER ARRAYS
C=======================================================================
C
      IALLOC=0
C
      ALLOCATE (Y_HXZ0(0:NDOSCI,0:NDOSCI,0:NJP,0:NDKART,0:NDISOS),
     *                                                  STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Y_HXZ0','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (Y_HXZ1(0:NDOSCI,0:NDOSCI,0:NJM,0:NDKART,0:NDISOS),
     *                                                  STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Y_HXZ1','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (Z_HX00(0:NDOSCI,0:NDOSCI,0:NLP,0:NJP,0:NDKART,
     *                                         0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_HX00','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (Z_HX01(0:NDOSCI,0:NDOSCI,0:NLP,0:NJM,0:NDKART,
     *                                         0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_HX01','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (Z_HX10(0:NDOSCI,0:NDOSCI,0:NLM,0:NJP,0:NDKART,
     *                                         0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_HX10','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (Z_HX11(0:NDOSCI,0:NDOSCI,0:NLM,0:NJM,0:NDKART,
     *                                         0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_HX11','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_H000(0:NIP,0:NLP,0:NJP,0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_H000','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_H001(0:NIP,0:NLP,0:NJM,0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_H001','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_H010(0:NIP,0:NLM,0:NJP,0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_H010','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_H100(0:NIM,0:NLP,0:NJP,0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_H100','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_H011(0:NIP,0:NLM,0:NJM,0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_H011','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_H110(0:NIM,0:NLM,0:NJP,0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_H110','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_H101(0:NIM,0:NLP,0:NJM,0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_H101','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_H111(0:NIM,0:NLM,0:NJM,0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_H111','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_FX00(0:NLP,0:NJP,0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS),
     *                                                     STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_FX00','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_FX01(0:NLP,0:NJM,0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS),
     *                                                     STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_FX01','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_FX10(0:NLM,0:NJP,0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS),
     *                                                     STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_FX10','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (X_FX11(0:NLM,0:NJM,0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS),
     *                                                     STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('X_FX11','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (Z_FXZ0(0:NJP,0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS),
     *                                                      STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_FXZ0','GAUDIQ')
C
      IALLOC=0
C
      ALLOCATE (Z_FXZ1(0:NJM,0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS),
     *                                                      STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_FXZ1','GAUDIQ')
C
      IF (     ALLOCATED(GAUAVR)) DEALLOCATE(GAUAVR)
      IF (.NOT.ALLOCATED(GAUAVR)) THEN
          IF (I_PART.EQ.0) THEN
              ALLOCATE (GAUAVR(0:NDKART,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUDIQ')
          END IF
          IF (I_PART.EQ.1.OR.I_PART.EQ.2.OR.I_PART.EQ.3) THEN
              ALLOCATE (GAUAVR(0:0     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUDIQ')
          END IF
          IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
              ALLOCATE (GAUAVR(0:I_PART-4,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUDIQ')
          END IF
          IF (I_PART.EQ.8) THEN
              ALLOCATE (GAUAVR(0:2     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUDIQ')
          END IF
          IF (I_PART.EQ.9) THEN
              ALLOCATE (GAUAVR(0:5     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUDIQ')
          END IF
          IF (I_PART.EQ.10) THEN
              ALLOCATE (GAUAVR(0:9     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUDIQ')
          END IF
      END IF
C=======================================================================
C         ATTENTION: SEE COMMENTS IN GAUOPT
C=======================================================================
      IF (     ALLOCATED(GAUFIL)) DEALLOCATE(GAUFIL)
      IF (.NOT.ALLOCATED(GAUFIL).AND.I_FIEL.GE.2) THEN
          IF (I_PART.EQ.0) THEN
              ALLOCATE (GAUFIL(0:NDKART,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUDIQ')
          END IF
          IF (I_PART.EQ.1.OR.I_PART.EQ.2.OR.I_PART.EQ.3) THEN
              ALLOCATE (GAUFIL(0:0     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUDIQ')
          END IF
          IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
              ALLOCATE (GAUFIL(0:I_PART-4,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUDIQ')
          END IF
          IF (I_PART.EQ.8) THEN
              ALLOCATE (GAUFIL(0:2     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUDIQ')
          END IF
          IF (I_PART.EQ.9) THEN
              ALLOCATE (GAUFIL(0:5     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUDIQ')
          END IF
          IF (I_PART.EQ.10) THEN
              ALLOCATE (GAUFIL(0:9     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUDIQ')
          END IF
      END IF
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE ENERGIES
C=======================================================================
C
      GAUAVR=C_ZERO
C
C     INDEX ORDER BELOW IS XZY. 0 STANDS FOR SYMMETRIC, 1 FOR ANTI-SYMM
C
      X_H000(:,:,:,:,:)=C_ZERO
      X_H001(:,:,:,:,:)=C_ZERO
      X_H010(:,:,:,:,:)=C_ZERO
      X_H100(:,:,:,:,:)=C_ZERO
      X_H011(:,:,:,:,:)=C_ZERO
      X_H110(:,:,:,:,:)=C_ZERO
      X_H101(:,:,:,:,:)=C_ZERO
      X_H111(:,:,:,:,:)=C_ZERO
C
      Z_HX00(:,:,:,:,:,:)=C_ZERO
      Z_HX01(:,:,:,:,:,:)=C_ZERO
      Z_HX10(:,:,:,:,:,:)=C_ZERO
      Z_HX11(:,:,:,:,:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      DO NX=0,NXMAXV(1)
         DO MX=0,NXMAXV(1)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
            Y_HXZ0(:,:,:,:,:)=C_ZERO
            Y_HXZ1(:,:,:,:,:)=C_ZERO
C
            DO NZ=0,LZOFXV(NX,1)
               DO MZ=0,LZOFXV(MX,1)
C
                  D_HELP(:,:,:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                  DO NY=0,LYOZXV(NZ,NX,1)
                     DO MY=0,LYOZXV(MZ,MX,1)
C
C
                        IBRA=INDICE(NX,NY,NZ,1)
                        IKET=INDICE(MX,MY,MZ,1)
C
                        IF (IDENSI.EQ.0) THEN
C
C=======================================================================
C        HERE THE PARTICLE "2" DENSITY MATRIX IS STORED
C=======================================================================
C
                            DO KARTEZ=0,NDKART
                               DO ICHARG=0,NDISOS
C
                                  D_HELP(NY,MY,KARTEZ,ICHARG)=
     *
     *                            DEN_PP(IBRA,IKET, 0,ICHARG)*
     *                                              IPHAPP(MY,NY,KARTEZ)
     *                           +DEN_PP(IBRA,IKET, 1,ICHARG)*
     *                                              IPHAMM(MY,NY,KARTEZ)
C
                                  IF (ISIMPY.NE.1)
     *
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)=
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)
     *
     *                           +DEN_PM(IBRA,IKET, 0,ICHARG)*
     *                                              IPHAMP(MY,NY,KARTEZ)
     *                           +DEN_PM(IBRA,IKET, 1,ICHARG)*
     *                                              IPHAPM(MY,NY,KARTEZ)
C
                               END DO
                            END DO
C
                            D_HELP(NY,MY,3,0)=D_HELP(NY,MY,3,0)*UNIT_I
                            D_HELP(NY,MY,3,1)=D_HELP(NY,MY,3,1)*UNIT_I
C
                        ELSE
C
C=======================================================================
C        HERE THE "KET" PAIRING TENSOR IS STORED
C=======================================================================
C
                            DO KARTEZ=0,NDKART
                               DO ICHARG=0,NDISOS
C
                                  D_HELP(NY,MY,KARTEZ,ICHARG)=
     *
     *                           +CHI_PM(IBRA,IKET, 0,ICHARG)*
     *                                              JPHAPM(NY,MY,KARTEZ)
     *                           +CHI_PM(IBRA,IKET, 1,ICHARG)*
     *                                              JPHAMP(NY,MY,KARTEZ)
C
                                  IF (ISIMPY.NE.1)
     *
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)=
     *                            D_HELP(NY,MY,KARTEZ,ICHARG)
     *
     *                           +CHI_PP(IBRA,IKET, 0,ICHARG)*
     *                                              JPHAPP(NY,MY,KARTEZ)
     *                           +CHI_PP(IBRA,IKET, 1,ICHARG)*
     *                                              JPHAMM(NY,MY,KARTEZ)
C
                               END DO
                            END DO
C
                            D_HELP(NY,MY,3,0)=D_HELP(NY,MY,3,0)*UNIT_I
                            D_HELP(NY,MY,3,1)=D_HELP(NY,MY,3,1)*UNIT_I
C
                        END IF
C
C=======================================================================
C        HERE ENDS LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                     END DO
                  END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C            WITHOUT THE TRIANGLE OVER ALLOWED SYMMETRIC INDICES
C=======================================================================
C
                  DO NY=0,LYOZXV(NZ,NX,1)
                     DO MY=0,LYOZXV(MZ,MX,1)
C
                     IF(MY.GT.NY.AND.MY.LE.(MIN(LYOZXV(NZ,NX,1),
     *                                          LYOZXV(MZ,MX,1)))) CYCLE
C
C=======================================================================
C        HERE WE SEPARATE THE SYMMETRIC AND ANTI-SYMMETRIC Y PARTS
C                   OF THE DENSITY MATRIX/PAIRING TENSOR
C=======================================================================
C
                        DO KARTEZ=0,NDKART
                           DO ICHARG=0,NDISOS
C
                              D_HXZ0(KARTEZ,ICHARG) = 0.5 *
     *                       (D_HELP(NY,MY,KARTEZ,ICHARG) +
     *                        D_HELP(MY,NY,KARTEZ,ICHARG))
C
                              D_HXZ1(KARTEZ,ICHARG) = 0.5 *
     *                       (D_HELP(NY,MY,KARTEZ,ICHARG) -
     *                        D_HELP(MY,NY,KARTEZ,ICHARG))
C
                           END DO
                        END DO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
                        DO NJ=1,NJP
C
                           IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                               DO KARTEZ=0,NDKART
                                  DO ICHARG=0,NDISOS
C
C                                    SYMMETRIC Y
C
                                     Y_HXZ0(MZ,NZ,NJ,KARTEZ,ICHARG)=
     *                               Y_HXZ0(MZ,NZ,NJ,KARTEZ,ICHARG)
     *                                       +D_HXZ0(KARTEZ,ICHARG)
     *                                            *GPYVEI(NJ,MY,NY)
C
                                  END DO
                               END DO
C
                           END IF
C
                        END DO
C
C=======================================================================
C         ABOVE ENDS THE LOOP OVER SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
                        DO NJ=1,NJM
C
                           IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                               DO KARTEZ=0,NDKART
                                  DO ICHARG=0,NDISOS
C
C                                    ANTI-SYMMETRIC Y
C
                                     Y_HXZ1(MZ,NZ,NJ,KARTEZ,ICHARG)=
     *                               Y_HXZ1(MZ,NZ,NJ,KARTEZ,ICHARG)
     *                                       +D_HXZ1(KARTEZ,ICHARG)
     *                                            *GMYVEI(NJ,MY,NY)
C
                                  END DO
                               END DO
C
                           END IF
C
                        END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C         BELOW END LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                     END DO
                  END DO
C
C=======================================================================
C         BELOW END LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
            DO NZ=0,LZOFXV(NX,1)
               DO MZ=0,LZOFXV(MX,1)
C
C=======================================================================
C                   SKIPPING THE SYMMETRIC TRIANGLE
C=======================================================================
C
            IF (MZ.GT.NZ.AND.MZ.LE.MIN(LZOFXV(NX,1),LZOFXV(MX,1))) CYCLE
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
                  DO NJ=1,NJP
C
C=======================================================================
C               STORING THE Z SYMMETRIC AND ANTISYMMETRIC PARTS
C=======================================================================
C
                     DO KARTEZ=0,NDKART
                        DO ICHARG=0,NDISOS
C
                           SYMAUX(KARTEZ,ICHARG) = 0.5 *
     *                    (Y_HXZ0(MZ,NZ,NJ,KARTEZ,ICHARG) +
     *                     Y_HXZ0(NZ,MZ,NJ,KARTEZ,ICHARG))
C
                           ASYAUX(KARTEZ,ICHARG) = 0.5 *
     *                    (Y_HXZ0(MZ,NZ,NJ,KARTEZ,ICHARG) -
     *                     Y_HXZ0(NZ,MZ,NJ,KARTEZ,ICHARG))
C
                        END DO
                     END DO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                     DO NL=1,YPZP(NJ)
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEZ=0,NDKART
                               DO ICHARG=0,NDISOS
C
C                                    SYMMETRIC Y AND Z
C
                                  Z_HX00(MX,NX,NL,NJ,KARTEZ,ICHARG)=
     *                            Z_HX00(MX,NX,NL,NJ,KARTEZ,ICHARG)
     *                           +SYMAUX(KARTEZ,ICHARG)
     *                           *GPZVEI(NL,MZ,NZ)
C
                               END DO
                            END DO
C
                        END IF
C
                     END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                     DO NL=1,YPZM(NJ)
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEZ=0,NDKART
                               DO ICHARG=0,NDISOS
C
C                                    SYMMETRIC Y, ANTI-SYMMETRIC Z
C
                                  Z_HX10(MX,NX,NL,NJ,KARTEZ,ICHARG)=
     *                            Z_HX10(MX,NX,NL,NJ,KARTEZ,ICHARG)
     *                           +ASYAUX(KARTEZ,ICHARG)
     *                           *GMZVEI(NL,MZ,NZ)
C

                               END DO
                            END DO
C
                        END IF
C
                     END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
                  DO NJ=1,NJM
C
C=======================================================================
C               STORING THE Z SYMMETRIC AND ANTISYMMETRIC PARTS
C=======================================================================
C
                     DO KARTEZ=0,NDKART
                        DO ICHARG=0,NDISOS
C
                           SYMAUX(KARTEZ,ICHARG) = 0.5 *
     *                    (Y_HXZ1(MZ,NZ,NJ,KARTEZ,ICHARG) +
     *                     Y_HXZ1(NZ,MZ,NJ,KARTEZ,ICHARG))
C
                           ASYAUX(KARTEZ,ICHARG) = 0.5 *
     *                    (Y_HXZ1(MZ,NZ,NJ,KARTEZ,ICHARG) -
     *                     Y_HXZ1(NZ,MZ,NJ,KARTEZ,ICHARG))
C
                        END DO
                     END DO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                     DO NL=1,YMZP(NJ)
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEZ=0,NDKART
                               DO ICHARG=0,NDISOS
C
C                                    SYMMETRIC Y AND Z
C
                                  Z_HX01(MX,NX,NL,NJ,KARTEZ,ICHARG)=
     *                            Z_HX01(MX,NX,NL,NJ,KARTEZ,ICHARG)
     *                           +SYMAUX(KARTEZ,ICHARG)
     *                           *GPZVEI(NL,MZ,NZ)
C
                               END DO
                            END DO
C
                        END IF
C
                     END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                     DO NL=1,YMZM(NJ)
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEZ=0,NDKART
                               DO ICHARG=0,NDISOS
C
C                                    SYMMETRIC Y, ANTI-SYMMETRIC Z
C
                                  Z_HX11(MX,NX,NL,NJ,KARTEZ,ICHARG)=
     *                            Z_HX11(MX,NX,NL,NJ,KARTEZ,ICHARG)
     *                           +ASYAUX(KARTEZ,ICHARG)
     *                           *GMZVEI(NL,MZ,NZ)
C

                               END DO
                            END DO
C
                        END IF
C
                     END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C=======================================================================
C       HERE BEGIN LOOPS OVER HALF PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      DO NX=0,NXMAXV(1)
         DO MX=0,NX
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
            DO NJ=1,NJP
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
               DO NL=1,YPZP(NJ)
C
C=======================================================================
C        COMPUTING THE SYMMETRIC AND ANTI-SYMMETRIC PARTS OF THE Z ARRAY
C=======================================================================
C
                  DO KARTEZ=0,NDKART
                     DO ICHARG=0,NDISOS
C
                        SYMAUX(KARTEZ,ICHARG) = 0.5 *
     *                 (Z_HX00(MX,NX,NL,NJ,KARTEZ,ICHARG) +
     *                  Z_HX00(NX,MX,NL,NJ,KARTEZ,ICHARG))
C
                        ASYAUX(KARTEZ,ICHARG) = 0.5 *
     *                 (Z_HX00(MX,NX,NL,NJ,KARTEZ,ICHARG) -
     *                  Z_HX00(NX,MX,NL,NJ,KARTEZ,ICHARG))
C
                     END DO
                  END DO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YPZPXP(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               X_H000(NI,NL,NJ,KARTEZ,ICHARG)=
     *                         X_H000(NI,NL,NJ,KARTEZ,ICHARG)
     *                        +SYMAUX(KARTEZ,ICHARG)
     *                        *GPXVEI(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YPZPXM(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               X_H100(NI,NL,NJ,KARTEZ,ICHARG)=
     *                         X_H100(NI,NL,NJ,KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
     *                        *GMXVEI(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
               END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
               DO NL=1,YPZM(NJ)
C
C=======================================================================
C        COMPUTING THE SYMMETRIC AND ANTI-SYMMETRIC PARTS OF THE Z ARRAY
C=======================================================================
C
                  DO KARTEZ=0,NDKART
                     DO ICHARG=0,NDISOS
C
                        SYMAUX(KARTEZ,ICHARG) = 0.5 *
     *                 (Z_HX10(MX,NX,NL,NJ,KARTEZ,ICHARG) +
     *                  Z_HX10(NX,MX,NL,NJ,KARTEZ,ICHARG))
C
                        ASYAUX(KARTEZ,ICHARG) = 0.5 *
     *                 (Z_HX10(MX,NX,NL,NJ,KARTEZ,ICHARG) -
     *                  Z_HX10(NX,MX,NL,NJ,KARTEZ,ICHARG))
C
                     END DO
                  END DO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YPZMXP(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               X_H010(NI,NL,NJ,KARTEZ,ICHARG)=
     *                         X_H010(NI,NL,NJ,KARTEZ,ICHARG)
     *                        +SYMAUX(KARTEZ,ICHARG)
     *                        *GPXVEI(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YPZMXM(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               X_H110(NI,NL,NJ,KARTEZ,ICHARG)=
     *                         X_H110(NI,NL,NJ,KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
     *                        *GMXVEI(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
               END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
            END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
            DO NJ=1,NJM
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
               DO NL=1,YMZP(NJ)
C
C=======================================================================
C        COMPUTING THE SYMMETRIC AND ANTI-SYMMETRIC PARTS OF THE Z ARRAY
C=======================================================================
C
                  DO KARTEZ=0,NDKART
                     DO ICHARG=0,NDISOS
C
                        SYMAUX(KARTEZ,ICHARG) = 0.5 *
     *                 (Z_HX01(MX,NX,NL,NJ,KARTEZ,ICHARG) +
     *                  Z_HX01(NX,MX,NL,NJ,KARTEZ,ICHARG))
C
                        ASYAUX(KARTEZ,ICHARG) = 0.5 *
     *                 (Z_HX01(MX,NX,NL,NJ,KARTEZ,ICHARG) -
     *                  Z_HX01(NX,MX,NL,NJ,KARTEZ,ICHARG))
C
                     END DO
                  END DO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YMZPXP(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               X_H001(NI,NL,NJ,KARTEZ,ICHARG)=
     *                         X_H001(NI,NL,NJ,KARTEZ,ICHARG)
     *                        +SYMAUX(KARTEZ,ICHARG)
     *                        *GPXVEI(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YMZPXM(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               X_H101(NI,NL,NJ,KARTEZ,ICHARG)=
     *                         X_H101(NI,NL,NJ,KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
     *                        *GMXVEI(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
               END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
               DO NL=1,YMZM(NJ)
C
C=======================================================================
C        COMPUTING THE SYMMETRIC AND ANTI-SYMMETRIC PARTS OF THE Z ARRAY
C=======================================================================
C
                  DO KARTEZ=0,NDKART
                     DO ICHARG=0,NDISOS
C
                        SYMAUX(KARTEZ,ICHARG) = 0.5 *
     *                 (Z_HX11(MX,NX,NL,NJ,KARTEZ,ICHARG) +
     *                  Z_HX11(NX,MX,NL,NJ,KARTEZ,ICHARG))
C
                        ASYAUX(KARTEZ,ICHARG) = 0.5 *
     *                 (Z_HX11(MX,NX,NL,NJ,KARTEZ,ICHARG) -
     *                  Z_HX11(NX,MX,NL,NJ,KARTEZ,ICHARG))
C
                     END DO
                  END DO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YMZMXP(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               X_H011(NI,NL,NJ,KARTEZ,ICHARG)=
     *                         X_H011(NI,NL,NJ,KARTEZ,ICHARG)
     *                        +SYMAUX(KARTEZ,ICHARG)
     *                        *GPXVEI(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YMZMXM(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               X_H111(NI,NL,NJ,KARTEZ,ICHARG)=
     *                         X_H111(NI,NL,NJ,KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
     *                        *GMXVEI(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
               END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
            END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C        ABOVE END LOOPS OVER HALF PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C        HERE BEGINS CALCULATION OF FIELDS ON THE HO BASIS
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      GAUFIL=C_ZERO
C
C=======================================================================
C        IN THE LOOPS BELOW, WE STORE THE SUM OVER SYMMETRIC INDICES
C        IN SYMAUX(:,:) AND THE ANTISYMMETRIC IN ASYAUX(:,:). WE THEN
C        COMPUTE THE ARRAYS WITH INDICES M,N BY SUMMING AND N,M BY
C        SUBTRACTING THE AUXILIARY ARRAYS.
C=======================================================================
C
      X_FX00(:,:,:,:,:,:)=C_ZERO ! INDICES (NL,NJ,MX,NX,KARTEZ,ICHARG)
      X_FX01(:,:,:,:,:,:)=C_ZERO
      X_FX10(:,:,:,:,:,:)=C_ZERO
      X_FX10(:,:,:,:,:,:)=C_ZERO
C
C=======================================================================
C      HERE BEGINS LOOPS OVER HALF PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      DO NX=0,NXMAXV(1)
         DO MX=0,NX
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
            DO NJ=1,NJP
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
               DO NL=1,YPZP(NJ)
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  SYMAUX(:,:)=C_ZERO
                  ASYAUX(:,:)=C_ZERO
C
                  DO NI=1,YPZPXP(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               SYMAUX(KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +X_H000(NI,NL,NJ,KARTEZ,ICHARG)
     *                        *GPXVEC(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YPZPXM(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               ASYAUX(KARTEZ,ICHARG)=
     *                         ASYAUX(KARTEZ,ICHARG)
     *                        +X_H100(NI,NL,NJ,KARTEZ,ICHARG)
     *                        *GMXVEC(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C         FILLING THE ARRAYS USING THE SYMMETRIES OF THE EIGENVECTORS
C=======================================================================
C
                  DO KARTEZ=0,NDKART
                     DO ICHARG=0,NDISOS
C
                        X_FX00(NL,NJ,MX,NX,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
C
                        X_FX00(NL,NJ,NX,MX,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        -ASYAUX(KARTEZ,ICHARG)
C
                     END DO
                  END DO
C
               END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
               DO NL=1,YPZM(NJ)
C
                  SYMAUX(:,:)=C_ZERO
                  ASYAUX(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YPZMXP(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               SYMAUX(KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +X_H010(NI,NL,NJ,KARTEZ,ICHARG)
     *                        *GPXVEC(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YPZMXM(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               ASYAUX(KARTEZ,ICHARG)=
     *                         ASYAUX(KARTEZ,ICHARG)
     *                        +X_H110(NI,NL,NJ,KARTEZ,ICHARG)
     *                        *GMXVEC(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C         FILLING THE ARRAYS USING THE SYMMETRIES OF THE EIGENVECTORS
C=======================================================================
C
                  DO KARTEZ=0,NDKART
                     DO ICHARG=0,NDISOS
C
                        X_FX10(NL,NJ,MX,NX,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
C
                        X_FX10(NL,NJ,NX,MX,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        -ASYAUX(KARTEZ,ICHARG)
C
                     END DO
                  END DO
C
               END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
            END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
            DO NJ=1,NJM
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
               DO NL=1,YMZP(NJ)
C
                  SYMAUX(:,:)=C_ZERO
                  ASYAUX(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YMZPXP(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               SYMAUX(KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +X_H001(NI,NL,NJ,KARTEZ,ICHARG)
     *                        *GPXVEC(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YMZPXM(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               ASYAUX(KARTEZ,ICHARG)=
     *                         ASYAUX(KARTEZ,ICHARG)
     *                        +X_H101(NI,NL,NJ,KARTEZ,ICHARG)
     *                        *GMXVEC(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C         FILLING THE ARRAYS USING THE SYMMETRIES OF THE EIGENVECTORS
C=======================================================================
C
                  DO KARTEZ=0,NDKART
                     DO ICHARG=0,NDISOS
C
                        X_FX01(NL,NJ,MX,NX,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
C
                        X_FX01(NL,NJ,NX,MX,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        -ASYAUX(KARTEZ,ICHARG)
C
                     END DO
                  END DO
C
               END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
               DO NL=1,YMZM(NJ)
C
                  SYMAUX(:,:)=C_ZERO
                  ASYAUX(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YMZMXP(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               SYMAUX(KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +X_H011(NI,NL,NJ,KARTEZ,ICHARG)
     *                        *GPXVEC(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
                  DO NI=1,YMZMXM(NL,NJ)
C
                     IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               ASYAUX(KARTEZ,ICHARG)=
     *                         ASYAUX(KARTEZ,ICHARG)
     *                        +X_H111(NI,NL,NJ,KARTEZ,ICHARG)
     *                        *GMXVEC(NI,MX,NX)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC X EIGENVECTORS
C=======================================================================
C
C=======================================================================
C         FILLING THE ARRAYS USING THE SYMMETRIES OF THE EIGENVECTORS
C=======================================================================
C
                  DO KARTEZ=0,NDKART
                     DO ICHARG=0,NDISOS
C
                        X_FX11(NL,NJ,MX,NX,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
C
                        X_FX11(NL,NJ,NX,MX,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        -ASYAUX(KARTEZ,ICHARG)
C
                     END DO
                  END DO
C
               END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
            END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C        ABOVE END LOOPS OVER HALF PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      DO NX=0,NXMAXV(1)
         DO MX=0,NXMAXV(1)
C
            Z_FXZ0(:,:,:,:,:)=C_ZERO  ! INDICES (NJ,MZ,NZ,KARTEZ,ICHARG)
            Z_FXZ1(:,:,:,:,:)=C_ZERO  !     SUM OVER NL
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
            DO NJ=1,NJP
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
               DO NZ=0,LZOFXV(NX,1)
                  DO MZ=0,LZOFXV(MX,1)
C
C=======================================================================
C                   SKIPPING THE SYMMETRIC TRIANGLE
C=======================================================================
C
            IF (MZ.GT.NZ.AND.MZ.LE.MIN(LZOFXV(NX,1),LZOFXV(MX,1))) CYCLE
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                     SYMAUX(:,:)=C_ZERO
                     ASYAUX(:,:)=C_ZERO
C
                     DO NL=1,YPZP(NJ)
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEZ=0,NDKART
                                DO ICHARG=0,NDISOS
C
                                   SYMAUX(KARTEZ,ICHARG)=
     *                             SYMAUX(KARTEZ,ICHARG)
     *                            +X_FX00(NL,NJ,MX,NX,KARTEZ,ICHARG)
     *                            *GPZVEC(NL,MZ,NZ)
C
                                END DO
                            END DO
C
                        END IF
C
                     END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                     DO NL=1,YPZM(NJ)
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEZ=0,NDKART
                                DO ICHARG=0,NDISOS
C
                                   ASYAUX(KARTEZ,ICHARG)=
     *                             ASYAUX(KARTEZ,ICHARG)
     *                            +X_FX10(NL,NJ,MX,NX,KARTEZ,ICHARG)
     *                            *GMZVEC(NL,MZ,NZ)
C
                                END DO
                            END DO
C
                        END IF
C
                     END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C         FILLING THE ARRAYS USING THE SYMMETRIES OF THE EIGENVECTORS
C=======================================================================
C
                     DO KARTEZ=0,NDKART
                        DO ICHARG=0,NDISOS
C
                           Z_FXZ0(NJ,MZ,NZ,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
C
                        END DO
                     END DO
C
         IF (MZ.LT.NZ .AND. MZ.LT.MIN(LZOFXV(NX,1),LZOFXV(MX,1))) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               Z_FXZ0(NJ,NZ,MZ,KARTEZ,ICHARG)=
     *                             SYMAUX(KARTEZ,ICHARG)
     *                            -ASYAUX(KARTEZ,ICHARG)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
               END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
            END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
            DO NJ=1,NJM
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
               DO NZ=0,LZOFXV(NX,1)
                  DO MZ=0,LZOFXV(MX,1)
C
C=======================================================================
C                   SKIPPING THE SYMMETRIC TRIANGLE
C=======================================================================
C
            IF (MZ.GT.NZ.AND.MZ.LE.MIN(LZOFXV(NX,1),LZOFXV(MX,1))) CYCLE
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  YMMETRIC Z EIGENVECTORS
C=======================================================================
C
                     SYMAUX(:,:)=C_ZERO
                     ASYAUX(:,:)=C_ZERO
C
                     DO NL=1,YMZP(NJ)
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEZ=0,NDKART
                                DO ICHARG=0,NDISOS
C
                                   SYMAUX(KARTEZ,ICHARG)=
     *                             SYMAUX(KARTEZ,ICHARG)
     *                            +X_FX01(NL,NJ,MX,NX,KARTEZ,ICHARG)
     *                            *GPZVEC(NL,MZ,NZ)
C
                                END DO
                            END DO
C
                        END IF
C
                     END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
                     DO NL=1,YMZM(NJ)
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEZ=0,NDKART
                                DO ICHARG=0,NDISOS
C
                                   ASYAUX(KARTEZ,ICHARG)=
     *                             ASYAUX(KARTEZ,ICHARG)
     *                            +X_FX11(NL,NJ,MX,NX,KARTEZ,ICHARG)
     *                            *GMZVEC(NL,MZ,NZ)
C
                                END DO
                            END DO
C
                        END IF

C
                     END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  ANTI-SYMMETRIC Z EIGENVECTORS
C=======================================================================
C
C=======================================================================
C         FILLING THE ARRAYS USING THE SYMMETRIES OF THE EIGENVECTORS
C=======================================================================
C
                     DO KARTEZ=0,NDKART
                        DO ICHARG=0,NDISOS
C
                           Z_FXZ1(NJ,MZ,NZ,KARTEZ,ICHARG)=
     *                         SYMAUX(KARTEZ,ICHARG)
     *                        +ASYAUX(KARTEZ,ICHARG)
C
                        END DO
                     END DO
C
         IF (MZ.LT.NZ .AND. MZ.LT.MIN(LZOFXV(NX,1),LZOFXV(MX,1))) THEN
C
                         DO KARTEZ=0,NDKART
                            DO ICHARG=0,NDISOS
C
                               Z_FXZ1(NJ,NZ,MZ,KARTEZ,ICHARG)=
     *                             SYMAUX(KARTEZ,ICHARG)
     *                            -ASYAUX(KARTEZ,ICHARG)
C
                            END DO
                         END DO
C
                     END IF
C
                  END DO
               END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
            END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
            DO NZ=0,LZOFXV(NX,1)
               DO MZ=0,LZOFXV(MX,1)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                  DO NY=0,LYOZXV(NZ,NX,1)
                     DO MY=0,LYOZXV(MZ,MX,1)
C
C=======================================================================
C                   SKIPPING THE SYMMETRIC TRIANGLE
C=======================================================================
C
                     IF(MY.GT.NY.AND.MY.LE.(MIN(LYOZXV(NZ,NX,1),
     *                                          LYOZXV(MZ,MX,1)))) CYCLE
C
                        IBRA=INDICE(NX,NY,NZ,1)
                        IKET=INDICE(MX,MY,MZ,1)
C
                        SYMAUX(:,:)=C_ZERO
                        ASYAUX(:,:)=C_ZERO
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE  SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
                        DO NJ=1,NJP
C
                           IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                               DO KARTEZ=0,NDKART
                                  DO ICHARG=0,NDISOS
C
                                     SYMAUX(KARTEZ,ICHARG)=
     *                               SYMAUX(KARTEZ,ICHARG)
     *                              +Z_FXZ0(NJ,MZ,NZ,KARTEZ,ICHARG)
     *                                           *GPYVEC(NJ,MY,NY)
C
                                  END DO
                               END DO
C
                           END IF
C
                        END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE  SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C        HERE BEGINS LOOP OVER THE ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
                        DO NJ=1,NJM
C
                           IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                               DO KARTEZ=0,NDKART
                                  DO ICHARG=0,NDISOS
C
                                     ASYAUX(KARTEZ,ICHARG)=
     *                               ASYAUX(KARTEZ,ICHARG)
     *                              +Z_FXZ1(NJ,MZ,NZ,KARTEZ,ICHARG)
     *                                           *GMYVEC(NJ,MY,NY)
C
                                  END DO
                               END DO
C
                           END IF
C
                        END DO
C
C=======================================================================
C         ABOVE ENDS LOOP OVER THE ANTI-SYMMETRIC Y EIGENVECTORS
C=======================================================================
C
C=======================================================================
C         FILLING THE ARRAYS USING THE SYMMETRIES OF THE EIGENVECTORS
C=======================================================================
C
                        DO KARTEZ=0,NDKART
                           DO ICHARG=0,NDISOS
C
                              GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)=
     *                        SYMAUX(KARTEZ,ICHARG)
     *                       +ASYAUX(KARTEZ,ICHARG)
C
                           END DO
                        END DO
C
                        IF (MY.LT.NY) THEN
C
                            IBRA_T=INDICE(NX,MY,NZ,1)  !  MY <-> NY
                            IKET_T=INDICE(MX,NY,MZ,1)
C
                            IF (IBRA_T .NE.0 .AND. IKET_T .NE. 0) THEN
C
                                DO KARTEZ=0,NDKART
                                   DO ICHARG=0,NDISOS
C
                                GAUFIL(0,IBRA_T,IKET_T,KARTEZ,ICHARG)=
     *                             SYMAUX(KARTEZ,ICHARG)
     *                            -ASYAUX(KARTEZ,ICHARG)
C
                                   END DO
                                END DO
C
                            END IF
                        END IF
C
                     END DO
                  END DO
C
C=======================================================================
C         ABOVE END LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                  DO NY=0,LYOZXV(NZ,NX,1)
                     DO MY=0,LYOZXV(MZ,MX,1)
C
                        IBRA=INDICE(NX,NY,NZ,1)
                        IKET=INDICE(MX,MY,MZ,1)
C
                        IF (IDENSI.EQ.0) THEN
C
C=======================================================================
C        HERE THE PARTICLE "1" DENSITY MATRIX IS STORED
C=======================================================================
C
                            DO KARTEP=0,NDKART
                               DO ICHARP=0,NDISOS
C
                                  E_HELP(KARTEP,ICHARP)=
     *
     *                            DEN_PP(IKET,IBRA,0,ICHARP)*
     *                                      IPHAPP(NY,MY,KARTEP)
     *                           +DEN_PP(IKET,IBRA,1,ICHARP)*
     *                                      IPHAMM(NY,MY,KARTEP)
C
                                  IF(ISIMPY.NE.1)
     *
     *                            E_HELP(KARTEP,ICHARP)=
     *                            E_HELP(KARTEP,ICHARP)
     *
     *                            +DEN_PM(IKET,IBRA,0,ICHARP)*
     *                                 IPHAMP(NY,MY,KARTEP)
     *                            +DEN_PM(IKET,IBRA,1,ICHARP)*
     *                                 IPHAPM(NY,MY,KARTEP)
C
                               END DO
                            END DO
C
                            E_HELP(3,0)=E_HELP(3,0)*UNIT_I
                            E_HELP(3,1)=E_HELP(3,1)*UNIT_I
C
                            ELSE
C
C=======================================================================
C        HERE THE "BRA" COMPLEX-CONJUGATE PAIRING TENSOR IS STORED
C=======================================================================
C
                            DO KARTEP=0,NDKART
                               DO ICHARP=0,NDISOS
C
                                  E_HELP(KARTEP,ICHARP)=
     *
     *                           +CHI_PM(IKET,IBRA,0,ICHARP)*
     *                                      JPHAPM(MY,NY,KARTEP)
     *                                 +CHI_PM(IKET,IBRA,1,ICHARP)*
     *                                      JPHAMP(MY,NY,KARTEP)
C
                                  IF(ISIMPY.NE.1)
     *
     *                            E_HELP(KARTEP,ICHARP)=
     *                            E_HELP(KARTEP,ICHARP)
     *
     *                             +CHI_PP(IKET,IBRA,0,ICHARP)*
     *                                  JPHAPP(MY,NY,KARTEP)
     *                             +CHI_PP(IKET,IBRA,1,ICHARP)*
     *                                  JPHAMM(MY,NY,KARTEP)
C
                               END DO
                            END DO
C
                            E_HELP(3,0)=E_HELP(3,0)*UNIT_I
                            E_HELP(3,1)=E_HELP(3,1)*UNIT_I
C
                            E_HELP=CONJG(E_HELP)
C
                        END IF
C
C=======================================================================
C        HERE THE AVERAGE ENERGIES ARE SUMMED UP
C=======================================================================
C
                        IF (I_PART.GE.1.AND.I_PART.LE.4) THEN
C
                            DO KARTEP=0,NDKART
                               DO KARTEZ=0,NDKART
                                  DO ICHARP=0,NDISOS
                                     DO ICHARG=0,NDISOS
C
                                  GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                            GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                               +GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                           *E_HELP(KARTEP,ICHARP)
C
                                     END DO
                                  END DO
                               END DO
                            END DO
C
                        END IF
C
C
                     END DO
                  END DO
C
C=======================================================================
C         ABOVE END LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      DEALLOCATE (Y_HXZ0,Y_HXZ1)
      DEALLOCATE (Z_HX00,Z_HX01,Z_HX10,Z_HX11)
      DEALLOCATE (X_FX00,X_FX01,X_FX10,X_FX11)
      DEALLOCATE (Z_FXZ0,Z_FXZ1)
      DEALLOCATE (X_H000,X_H001,X_H010,X_H100,X_H011,X_H110,
     *                                        X_H101,X_H111)
C
C=======================================================================
C
      CALL CPUTIM('GAUDIQ',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GAUTHC(ISIMPY,I_PART)
C=======================================================================
      USE MAD_PP
      USE MAD_PM
      USE GAUSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO,UNIT_I
      COMPLEX
     *          D_HELP(0:NDOSCI,0:NDOSCI,0:NDKART,0:NDISOS)
      COMPLEX
     *          D1HELP(0:NDOSCI,0:2*NDOSCI+NDORDE,0:NDKART,0:NDISOS)
      COMPLEX
     *          D2HELP(0:2*NDOSCI+NDORDE,
     *                 0:2*NDOSCI+NDORDE,0:NDKART,0:NDISOS)
      COMPLEX
     *          X_HE00(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE10(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE01(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE20(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE02(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE40(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE04(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE22(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE60(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE06(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE24(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE42(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE03(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE30(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE05(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE50(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE11(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE12(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE21(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS)
C
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL0
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL1
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL2
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL3
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL4
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL5
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL6
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL7
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL8
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Y_HEL9
C
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE00
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE10
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE01
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE20
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE02
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE40
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE04
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE22
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE60
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE06
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE24
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE42
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE03
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE30
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE05
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE50
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE11
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE12
      COMPLEX, DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: Z_HE21
C
C=======================================================================
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /MATTHC/ DENTHC(0:NDORDE,
     *                         0:NDOSCI,0:2*NDOSCI+NDORDE,1:NDKART),
     *                POTTHC(0:2*NDOSCI,0:2*NDOSCI+NDORDE,1:NDKART),
     *                NUMTHC(1:NDKART)
      COMMON
     *       /INTTHC/ GA_THC(0:2*NDOSCI+NDORDE,
     *                       0:2*NDOSCI+NDORDE,1:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('GAUTHC',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE AVERAGE ENERGIES AND FIELDS
C        CORRESPONDING TO  THE  FINITE-RANGE  GAUSSIAN  INTERACTION
C        IT USES THE TENSOR HYPERCONTRACTION METHOD,  PRL111-132505
C=======================================================================
C        THE SUBROUTINE CAN PERFORM CALCULATIONS BY ASSUMING  (IPAXYZ=1)
C        OR NOT ASSUMING (IPAXYZ=0) THAT THE FORMAFACTORS  DELIVERED  BY
C        "DEFGOG" CONSERVE PARITIES IN ALL  THREE  CARTESIAN  DIRECTIONS
C        SIMULTANEOUSLY
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C
      LIMSET=0
C
C=======================================================================
C        CALCULATION FOR THE YUKAWA INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.0) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=0
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE COULOMB EXCHANGE INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.1) THEN
C
          KARLIM=NDKART
          ICHLIM=NDISOS
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE COULOMB DIRECT INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.2) THEN
C
          KARLIM=0
          ICHLIM=NDISOS
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE GOGNY INTERACTION
C=======================================================================
C
      IF (I_PART.EQ.3) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE REGULARIZED SKYRME INTERACTION T2=-T1
C=======================================================================
C
      IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
      END IF
C
C=======================================================================
C        CALCULATION FOR THE REGULARIZED SKYRME INTERACTION
C        (PSEUDOPOTENTIAL)
C=======================================================================
C
      IF (I_PART.GE.8.AND.I_PART.LE.9) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          IPAXYZ=1
          LIMSET=1
C
C=======================================================================
C         ATTENTION: SOME ELEMENTS OF THE N3LORD=-3 (I_PART=10) CASE ARE
C                    ALREADY PROGRAMMED, BUT THE MAIN WORK IS  N O T YET
C                    DONE.
C=======================================================================
C
      END IF
C
C=======================================================================
C        TESTING THE INPUT VALUE OF I_PART
C=======================================================================
C
      IF (LIMSET.NE.1)
     *    STOP 'GAUTHC CALLED WITH AN INCORRECT VALUE OF I_PART'
C
C=======================================================================
C        ALLOCATING ARRAYS
C=======================================================================
C
      IALLOC=0
C
      ALLOCATE (Y_HEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Y_HEL0','GAUTHC')
      ALLOCATE (Z_HE00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_HE00','GAUTHC')
C
      IF (I_PART.EQ.0) THEN
          ALLOCATE (Y_HEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL1','GAUTHC')
          ALLOCATE (Z_HE10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE10','GAUTHC')
          ALLOCATE (Z_HE01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE01','GAUTHC')
      END IF
C
      IF (I_PART.GE.5.AND.I_PART.LE.7) THEN
          ALLOCATE (Y_HEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL2','GAUTHC')
          ALLOCATE (Z_HE20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE20','GAUTHC')
          ALLOCATE (Z_HE02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE02','GAUTHC')
          IF (I_PART.GE.6) THEN
              ALLOCATE (Y_HEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL4','GAUTHC')
              ALLOCATE (Z_HE40(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE40','GAUTHC')
              ALLOCATE (Z_HE04(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE04','GAUTHC')
              ALLOCATE (Z_HE22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE22','GAUTHC')
          END IF
          IF (I_PART.GE.7) THEN
              ALLOCATE (Y_HEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL6','GAUTHC')
              ALLOCATE (Z_HE60(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE60','GAUTHC')
              ALLOCATE (Z_HE06(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE06','GAUTHC')
              ALLOCATE (Z_HE42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE42','GAUTHC')
              ALLOCATE (Z_HE24(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE24','GAUTHC')
          END IF
      END IF
      IF (I_PART.GE.8.AND.I_PART.LE.10) THEN
          ALLOCATE (Y_HEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL1','GAUTHC')
          ALLOCATE (Y_HEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL2','GAUTHC')
          ALLOCATE (Z_HE10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE10','GAUTHC')
          ALLOCATE (Z_HE01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE01','GAUTHC')
          ALLOCATE (Z_HE20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE20','GAUTHC')
          ALLOCATE (Z_HE02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE02','GAUTHC')
          IF (I_PART.GE.9) THEN
              ALLOCATE (Y_HEL3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL3','GAUTHC')
              ALLOCATE (Y_HEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL4','GAUTHC')
              ALLOCATE (Y_HEL5(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL5','GAUTHC')
              ALLOCATE (Z_HE03(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE03','GAUTHC')
              ALLOCATE (Z_HE30(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE30','GAUTHC')
              ALLOCATE (Z_HE04(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE04','GAUTHC')
              ALLOCATE (Z_HE40(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE40','GAUTHC')
              ALLOCATE (Z_HE05(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE05','GAUTHC')
              ALLOCATE (Z_HE50(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE50','GAUTHC')
              ALLOCATE (Z_HE11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE11','GAUTHC')
              ALLOCATE (Z_HE12(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE12','GAUTHC')
              ALLOCATE (Z_HE21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE21','GAUTHC')
              ALLOCATE (Z_HE22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Z_HE22','GAUTHC')
          END IF
          IF (I_PART.GE.10) THEN
              ALLOCATE (Y_HEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL6','GAUTHC')
              ALLOCATE (Y_HEL7(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL7','GAUTHC')
              ALLOCATE (Y_HEL8(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL8','GAUTHC')
              ALLOCATE (Y_HEL9(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('Y_HEL9','GAUTHC')
          END IF
      END IF
C
      IF (     ALLOCATED(GAUAVR)) DEALLOCATE(GAUAVR)
      IF (.NOT.ALLOCATED(GAUAVR)) THEN
          IF (I_PART.EQ.0) THEN
              ALLOCATE (GAUAVR(0:NDKART,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUTHC')
          END IF
          IF (I_PART.EQ.1.OR.I_PART.EQ.2.OR.I_PART.EQ.3) THEN
              ALLOCATE (GAUAVR(0:0     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUTHC')
          END IF
          IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
              ALLOCATE (GAUAVR(0:I_PART-4,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUTHC')
          END IF
          IF (I_PART.EQ.8) THEN
              ALLOCATE (GAUAVR(0:2     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUTHC')
          END IF
          IF (I_PART.EQ.9) THEN
              ALLOCATE (GAUAVR(0:5     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUTHC')
          END IF
          IF (I_PART.EQ.10) THEN
              ALLOCATE (GAUAVR(0:9     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUTHC')
          END IF
      END IF
C=======================================================================
C         ATTENTION: SEE COMMENTS IN GAUOPT
C=======================================================================
      IF (     ALLOCATED(GAUFIL)) DEALLOCATE(GAUFIL)
      IF (.NOT.ALLOCATED(GAUFIL)) THEN
          IF (I_PART.EQ.0) THEN
              ALLOCATE (GAUFIL(0:NDKART,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUTHC')
          END IF
          IF (I_PART.EQ.1.OR.I_PART.EQ.2.OR.I_PART.EQ.3) THEN
              ALLOCATE (GAUFIL(0:0     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUTHC')
          END IF
          IF (I_PART.GE.4.AND.I_PART.LE.7) THEN
              ALLOCATE (GAUFIL(0:I_PART-4,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUTHC')
          END IF
          IF (I_PART.EQ.8) THEN
              ALLOCATE (GAUFIL(0:2     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUTHC')
          END IF
          IF (I_PART.EQ.9) THEN
              ALLOCATE (GAUFIL(0:5     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUTHC')
          END IF
          IF (I_PART.EQ.10) THEN
              ALLOCATE (GAUFIL(0:9     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUTHC')
          END IF
      END IF
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE ENERGIES
C=======================================================================
C
      GAUAVR=C_ZERO
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      GAUFIL=C_ZERO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      CALL CPU_TIME(ATIME)
      TSTART=ATIME
      PRINT '('' SIZE(Z_HO00)='',I15)',SIZE(Z_HE00)
      ATIMEY=0.0D0
      ATIMEZ=0.0D0
      ATIMEX=0.0D0
      ATIME0=ATIME
C
      DO NX=0,NXMAXV(1)
         DO MX=0,NXMAXV(1)
C
C=======================================================================
C        HERE BEGINS CALCULATION OF THE AVERAGE FIELDS
C=======================================================================
C
                             Y_HEL0=C_ZERO
            IF (I_PART.EQ.0) Y_HEL1=C_ZERO
            IF (I_PART.GE.5.AND.I_PART.LE.7) THEN
                             Y_HEL2=C_ZERO
            IF (I_PART.GE.6) Y_HEL4=C_ZERO
            IF (I_PART.GE.7) Y_HEL6=C_ZERO
            END IF
            IF (I_PART.GE.8.AND.I_PART.LE.10) THEN
                             Y_HEL1=C_ZERO
                             Y_HEL2=C_ZERO
                IF (I_PART.GE.9) THEN
                             Y_HEL3=C_ZERO
                             Y_HEL4=C_ZERO
                             Y_HEL5=C_ZERO
                END IF
                IF (I_PART.GE.10) THEN
                             Y_HEL6=C_ZERO
                             Y_HEL7=C_ZERO
                             Y_HEL8=C_ZERO
                             Y_HEL9=C_ZERO
                END IF
            END IF
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
            DO NZ=0,LZOFXV(NX,1)
               DO MZ=0,LZOFXV(MX,1)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                  DO NY=0,LYOZXV(NZ,NX,1)
                     DO MY=0,LYOZXV(MZ,MX,1)
C
                        IBRA=INDICE(NX,NY,NZ,1)
                        IKET=INDICE(MX,MY,MZ,1)
C
C=======================================================================
C        HERE THE PARTICLE "2" DENSITY MATRIX IS STORED
C=======================================================================
C
                        DO KARTEZ=0,KARLIM
                           DO ICHARG=ICHLIM,NDISOS
C
                              D_HELP(NY,MY,KARTEZ,ICHARG)=
     *
     *                        DEN_PP(IBRA,IKET, 0,ICHARG)*
     *                                              IPHAPP(MY,NY,KARTEZ)
     *                       +DEN_PP(IBRA,IKET, 1,ICHARG)*
     *                                              IPHAMM(MY,NY,KARTEZ)
C
                              IF (ISIMPY.NE.1)
     *
     *                        D_HELP(NY,MY,KARTEZ,ICHARG)=
     *                        D_HELP(NY,MY,KARTEZ,ICHARG)
     *
     *                       +DEN_PM(IBRA,IKET, 0,ICHARG)*
     *                                              IPHAMP(MY,NY,KARTEZ)
     *                       +DEN_PM(IBRA,IKET, 1,ICHARG)*
     *                                              IPHAPM(MY,NY,KARTEZ)
C
                           END DO
                        END DO
C
                        D_HELP(NY,MY,3,0)=D_HELP(NY,MY,3,0)*UNIT_I
                        D_HELP(NY,MY,3,1)=D_HELP(NY,MY,3,1)*UNIT_I
C
                     END DO
                  END DO
C
      CALL CPU_TIME(ATIME)
C      PRINT '(''  NX='',I2,''  MX='',I2,''  NZ='',I2,''  MZ='',I2,
C     *        ''  NL='',I2,''  ML='',I2,''  KL='',I2,''  YM='',I2,
C     *           F8.1)',
C     *           NX,MX,NZ,MZ,
C     *           LYOZXV(NZ,NX,1),LYOZXV(MZ,MX,1),NUMTHC(2),NYMAXX,
C     *           ATIME-TSTART
                 ATIMEY=ATIMEY+ATIME-ATIME0
                 ATIME0=ATIME
C
                  D1HELP=C_ZERO
C
                  DO NY=0,LYOZXV(NZ,NX,1)
                     DO MY=0,LYOZXV(MZ,MX,1)
                        DO KY=0,NUMTHC(2)
C
                           DO KARTEZ=0,KARLIM
                              DO ICHARG=ICHLIM,NDISOS
C
                                 D1HELP(NY,KY,KARTEZ,ICHARG)=
     *                           D1HELP(NY,KY,KARTEZ,ICHARG)+
     *                           D_HELP(NY,MY,KARTEZ,ICHARG)*
     *                           DENTHC(0,MY,KY,2)
C
                              END DO
                           END DO
C
                        END DO
                     END DO
                  END DO
C
                  D2HELP=C_ZERO
C
                  DO NY=0,LYOZXV(NZ,NX,1)
                     DO LY=0,NUMTHC(2)
                        DO KY=0,NUMTHC(2)
C
                           DO KARTEZ=0,KARLIM
                              DO ICHARG=ICHLIM,NDISOS
C
                                 D2HELP(LY,KY,KARTEZ,ICHARG)=
     *                           D2HELP(LY,KY,KARTEZ,ICHARG)+
     *                           D1HELP(NY,KY,KARTEZ,ICHARG)*
     *                           DENTHC(0,NY,LY,2)
C
                              END DO
                           END DO
C
                        END DO
                     END DO
                  END DO
C
                  DO LY=0,NUMTHC(2)
                     DO KY=0,NUMTHC(2)
C
                        DO KARTEZ=0,KARLIM
                           DO ICHARG=ICHLIM,NDISOS
C
                              D2HELP(LY,KY,KARTEZ,ICHARG)=
     *                        D2HELP(LY,KY,KARTEZ,ICHARG)*
     *                        GA_THC(LY,KY,2)
C
                           END DO
                        END DO
C
                     END DO
                  END DO
C
                  D1HELP=C_ZERO
C
                  DO MPY=0,NYMAXV(1)
                     DO LY=0,NUMTHC(2)
                        DO KY=0,NUMTHC(2)
C
                           DO KARTEZ=0,KARLIM
                              DO ICHARG=ICHLIM,NDISOS
C
                                 D1HELP(MPY,KY,KARTEZ,ICHARG)=
     *                           D1HELP(MPY,KY,KARTEZ,ICHARG)+
     *                           D2HELP( LY,KY,KARTEZ,ICHARG)*
     *                           DENTHC(0,MPY,LY,2)
C
                              END DO
                           END DO
C
                        END DO
                     END DO
                  END DO
C
                  D_HELP=C_ZERO
C
                  DO MPY=0,NYMAXV(1)
                     DO NPY=0,NYMAXV(1)
                        DO KY=0,NUMTHC(2)
C
                           DO KARTEZ=0,KARLIM
                              DO ICHARG=ICHLIM,NDISOS
C
                                 D_HELP(MPY,NPY,KARTEZ,ICHARG)=
     *                           D_HELP(MPY,NPY,KARTEZ,ICHARG)+
     *                           D1HELP(MPY, KY,KARTEZ,ICHARG)*
     *                           DENTHC(0,NPY, KY,2)
C
                              END DO
                           END DO
C
                        END DO
C
                        DO KARTEZ=0,KARLIM
                           DO ICHARG=ICHLIM,NDISOS
C
                              Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)=
     *                        D_HELP(MPY,   NPY,   KARTEZ,ICHARG)
C
                           END DO
                        END DO
C
                     END DO
                  END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
C                            Z_HE00=C_ZERO
            IF (I_PART.EQ.0) Z_HE10=C_ZERO
            IF (I_PART.EQ.0) Z_HE01=C_ZERO
C
            IF (I_PART.GE.5.AND.I_PART.LE.7) THEN
                             Z_HE20=C_ZERO
                             Z_HE02=C_ZERO
            IF (I_PART.GE.6) Z_HE40=C_ZERO
            IF (I_PART.GE.6) Z_HE04=C_ZERO
            IF (I_PART.GE.6) Z_HE22=C_ZERO
            IF (I_PART.GE.7) Z_HE60=C_ZERO
            IF (I_PART.GE.7) Z_HE06=C_ZERO
            IF (I_PART.GE.7) Z_HE24=C_ZERO
            IF (I_PART.GE.7) Z_HE42=C_ZERO
            END IF
C
            IF (I_PART.GE.8.AND.I_PART.LE.10) THEN
                             Z_HE10=C_ZERO
                             Z_HE01=C_ZERO
                             Z_HE20=C_ZERO
                             Z_HE02=C_ZERO
                IF (I_PART.GE.9) THEN
                             Z_HE03=C_ZERO
                             Z_HE30=C_ZERO
                             Z_HE04=C_ZERO
                             Z_HE40=C_ZERO
                             Z_HE05=C_ZERO
                             Z_HE50=C_ZERO
                             Z_HE11=C_ZERO
                             Z_HE12=C_ZERO
                             Z_HE21=C_ZERO
                             Z_HE22=C_ZERO
                END IF
            END IF
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
            DO NPY=0,NYMAXV(1)
               DO MPY=0,NYMAXV(1)
C
                  D_HELP=C_ZERO
C
                  DO NZ=0,LZOFXV(NX,1)
                     DO MZ=0,LZOFXV(MX,1)
C
                        DO KARTEZ=0,KARLIM
                           DO ICHARG=ICHLIM,NDISOS
C
                              D_HELP(    NZ,    MZ,KARTEZ,ICHARG)=
     *                        Y_HEL0(MPY,NZ,NPY,MZ,KARTEZ,ICHARG)
C
                           END DO
                        END DO
C
C
                     END DO
                  END DO
C
      CALL CPU_TIME(ATIME)
C      PRINT '(''  NX='',I2,''  MX='',I2,'' NPY='',I2,'' MPY='',I2,
C     *        ''  NL='',I2,''  ML='',I2,''  KL='',I2,''     '',2X,
C     *           F8.1)',
C     *           NX,MX,NPY,MPY,
C     *           LZOFXV(NX,1),LZOFXV(MX,1),NUMTHC(3),
C     *           ATIME-TSTART
                 ATIMEZ=ATIMEZ+ATIME-ATIME0
                 ATIME0=ATIME
C
                  D1HELP=C_ZERO
C
                  DO NZ=0,LZOFXV(NX,1)
                     DO MZ=0,LZOFXV(MX,1)
                        DO KZ=0,NUMTHC(3)
C
                           DO KARTEZ=0,KARLIM
                              DO ICHARG=ICHLIM,NDISOS
C
                                 D1HELP(NZ,KZ,KARTEZ,ICHARG)=
     *                           D1HELP(NZ,KZ,KARTEZ,ICHARG)+
     *                           D_HELP(NZ,MZ,KARTEZ,ICHARG)*
     *                           DENTHC(0,MZ,KZ,3)
C
                              END DO
                           END DO
C
                        END DO
                     END DO
                  END DO
C
                  D2HELP=C_ZERO
C
                  DO NZ=0,LZOFXV(NX,1)
                     DO LZ=0,NUMTHC(3)
                        DO KZ=0,NUMTHC(3)
C
                           DO KARTEZ=0,KARLIM
                              DO ICHARG=ICHLIM,NDISOS
C
                                 D2HELP(LZ,KZ,KARTEZ,ICHARG)=
     *                           D2HELP(LZ,KZ,KARTEZ,ICHARG)+
     *                           D1HELP(NZ,KZ,KARTEZ,ICHARG)*
     *                           DENTHC(0,NZ,LZ,3)
C
                              END DO
                           END DO
C
                        END DO
                     END DO
                  END DO
C
                  DO LZ=0,NUMTHC(3)
                     DO KZ=0,NUMTHC(3)
C
                        DO KARTEZ=0,KARLIM
                           DO ICHARG=ICHLIM,NDISOS
C
                              D2HELP(LZ,KZ,KARTEZ,ICHARG)=
     *                        D2HELP(LZ,KZ,KARTEZ,ICHARG)*
     *                        GA_THC(LZ,KZ,3)
C
                           END DO
                        END DO
C
                     END DO
                  END DO
C
                  D1HELP=C_ZERO
C
                  DO MPZ=0,LZOFYV(MPY,1)
                     DO LZ=0,NUMTHC(3)
                        DO KZ=0,NUMTHC(3)
C
                           DO KARTEZ=0,KARLIM
                              DO ICHARG=ICHLIM,NDISOS
C
                                 D1HELP(MPZ,KZ,KARTEZ,ICHARG)=
     *                           D1HELP(MPZ,KZ,KARTEZ,ICHARG)+
     *                           D2HELP( LZ,KZ,KARTEZ,ICHARG)*
     *                           DENTHC(0,MPZ,LZ,3)
C
                              END DO
                           END DO
C
                        END DO
                     END DO
                  END DO
C
                  D_HELP=C_ZERO
C
                  DO MPZ=0,LZOFYV(MPY,1)
                     DO NPZ=0,LZOFYV(NPY,1)
                        DO KZ=0,NUMTHC(3)
C
                           DO KARTEZ=0,KARLIM
                              DO ICHARG=ICHLIM,NDISOS
C
                                 D_HELP(MPZ,NPZ,KARTEZ,ICHARG)=
     *                           D_HELP(MPZ,NPZ,KARTEZ,ICHARG)+
     *                           D1HELP(MPZ, KZ,KARTEZ,ICHARG)*
     *                           DENTHC(0,NPZ, KZ,3)
C
                              END DO
                           END DO
C
                        END DO
C
                        DO KARTEZ=0,KARLIM
                           DO ICHARG=ICHLIM,NDISOS
C
                            Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)=
     *                      D_HELP(    MPZ,    NPZ,KARTEZ,ICHARG)
C
                           END DO
                        END DO
C
                     END DO
                  END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
            DO MPY=0,NYMAXV(1)
               DO NPY=0,NYMAXV(1)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                  DO MPZ=0,LZOFYV(MPY,1)
                     DO NPZ=0,LZOFYV(NPY,1)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      CALL CPU_TIME(ATIME)
C      PRINT '('' MPY='',I2,'' NPY='',I2,'' MPZ='',I2,'' NPZ='',I2,
C     *        ''  ML='',I2,''  NL='',I2,''  KL='',I2,''  XM='',I2,
C     *           F8.1)',
C     *           MPY,NPY,MPZ,NPZ,
C     *           LZOFYV(MPY,1),LZOFYV(NPY,1),NUMTHC(1),NXMAXV(1),
C     *           ATIME-TSTART
                 ATIMEX=ATIMEX+ATIME-ATIME0
                 ATIME0=ATIME
C
                        D1HELP=C_ZERO
C
                        DO MPX=0,LXOYZV(MPY,MPZ,1)
                           DO KX=0,NUMTHC(1)
                              DO LX=0,NUMTHC(1)
C
                                 DO KARTEZ=0,KARLIM
                                    DO ICHARG=ICHLIM,NDISOS
C
                                       D1HELP(  MPX,KX,KARTEZ,ICHARG)=
     *                                 D1HELP(  MPX,KX,KARTEZ,ICHARG)+
     *                                 DENTHC(0,MPX,LX,1)*
     *                                 DENTHC(0, MX,LX,1)*
     *                                 POTTHC(   KX,LX,1)
C
                                    END DO
                                 END DO
C
                              END DO
                           END DO
                        END DO
C
                        D_HELP=C_ZERO
C
                        DO MPX=0,LXOYZV(MPY,MPZ,1)
                           DO NPX=0,LXOYZV(NPY,NPZ,1)
                              DO KX=0,NUMTHC(1)
C
                                 DO KARTEZ=0,KARLIM
                                    DO ICHARG=ICHLIM,NDISOS
C
                                       D_HELP(  MPX,NPX,KARTEZ,ICHARG)=
     *                                 D_HELP(  MPX,NPX,KARTEZ,ICHARG)+
     *                                 D1HELP(  MPX, KX,KARTEZ,ICHARG)*
     *                                 DENTHC(0,NPX, KX,1)*
     *                                 DENTHC(0, NX, KX,1)
C
                                    END DO
                                 END DO
C
                              END DO
C
                              IBRA=INDICE(MPX,MPY,MPZ,1)
                              IKET=INDICE(NPX,NPY,NPZ,1)
C
                              DO KARTEZ=0,KARLIM
                                 DO ICHARG=ICHLIM,NDISOS
C
                                    GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)=
     *                              GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)+
     *                                  D_HELP(MPX,NPX,KARTEZ,ICHARG)*
     *                          Z_HE00(MPY,MPZ,NPY,NPZ,KARTEZ,ICHARG)
C
                                 END DO
                              END DO
C
                           END DO
                        END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
                     END DO
                  END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
               END DO
            END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      PRINT '(''   Y='',F8.1,''   Z='',F8.1,
     *        ''   X='',F8.1,''   T='',F8.1)',
     *             ATIMEY,ATIMEZ,ATIMEX,ATIME-TSTART
C=======================================================================
                       DEALLOCATE (Y_HEL0,Z_HE00)
      IF (I_PART.EQ.0) DEALLOCATE (Y_HEL1,Z_HE10,Z_HE01)
      IF (I_PART.GE.5.AND.I_PART.LE.7) THEN
                       DEALLOCATE (Y_HEL2,Z_HE20,Z_HE02)
      IF (I_PART.GE.6) DEALLOCATE (Y_HEL4,Z_HE40,Z_HE04,Z_HE22)
      IF (I_PART.GE.7) DEALLOCATE (Y_HEL6,Z_HE60,Z_HE06,Z_HE42,Z_HE24)
      END IF
      IF (I_PART.EQ.8.AND.I_PART.LE.10) THEN
                       DEALLOCATE (Y_HEL1,Z_HE10,Z_HE01)
                       DEALLOCATE (Y_HEL2,Z_HE20,Z_HE02)
          IF (I_PART.GE.9) THEN
                       DEALLOCATE (Y_HEL3,Z_HE30,Z_HE03,Z_HE12,Z_HE21)
                       DEALLOCATE (Y_HEL4,Z_HE40,Z_HE04,Z_HE11,Z_HE22)
                       DEALLOCATE (Y_HEL5,Z_HE50,Z_HE05)
          END IF
      END IF
C=======================================================================
C
      CALL CPUTIM('GAUTHC',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GAUOPT(ISIMPY,I_FIEL,I_PART,IDENSI)
C=======================================================================
      USE MAD_PP
      USE MAD_PM
      USE MAP_PP
      USE MAP_PM
      USE GAUSTO
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *          C_ZERO,C_UNIT,UNIT_I,BUFCMP,AUXCMP,BUXCMP,PHACOM
      COMPLEX
     *          D_HELP,D1HELP
      COMPLEX
     *          E_HELP,X_HE00,X_HE10,X_HE01
      COMPLEX
     *          Y_HEL0,Y_HEL1,Z_HE00,Z_HE10,Z_HE01
C
      DIMENSION
     *          E_HELP(0:NDKART,0:NDISOS)
      DIMENSION
     *          D_HELP(0:NDOSCI,0:NDOSCI,0:NDISOS,0:NDKART),
     *          D1HELP(0:NDOSCI,0:NDOSCI,0:NDISOS,0:NDKART)
      DIMENSION
     *          X_HE00(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE10(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS),
     *          X_HE01(0:NDKART,0:NDKART,0:NDISOS,0:NDISOS)
C=======================================================================
      ALLOCATABLE Y_HEL0(:,:,:,:,:,:)
      ALLOCATABLE Y_HEL1(:,:,:,:,:,:)
      ALLOCATABLE Z_HE00(:,:,:,:,:,:)
      ALLOCATABLE Z_HE10(:,:,:,:,:,:)
      ALLOCATABLE Z_HE01(:,:,:,:,:,:)
C=======================================================================
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUSIN/ GAU_X0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAU_X6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Y6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAU_Z6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *
     *                GAUX43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUY43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *                GAUZ43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('GAUOPT',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE AVERAGE ENERGIES AND FIELDS
C        CORRESPONDING TO  THE  FINITE-RANGE  GAUSSIAN  INTERACTION
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C
      LIMSET=0
C
      IF (I_PART.EQ.0) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          LIMSET=1
C
      END IF
C
      IF (I_PART.EQ.1) THEN
C
          KARLIM=NDKART
          ICHLIM=NDISOS
          LIMSET=1
C
      END IF
C
      IF (I_PART.EQ.2) THEN
C
          KARLIM=0
          ICHLIM=NDISOS
          LIMSET=1
C
      END IF
C
      IF (I_PART.EQ.3) THEN
C
          KARLIM=NDKART
          ICHLIM=0
          LIMSET=1
C
      END IF
C
      IF (LIMSET.NE.1)
     *    STOP 'GAUOPT CALLED WITH AN INCORRECT VALUE OF I_PART'
C
C=======================================================================
C
      IALLOC=0
C
      ALLOCATE (Y_HEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDISOS,0:KARLIM),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Y_HEL0','GAUOPT')
      ALLOCATE (Z_HE00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDISOS,0:KARLIM),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('Z_HE00','GAUOPT')
C
      IF (I_PART.EQ.0) THEN
          ALLOCATE (Y_HEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDISOS,0:KARLIM),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Y_HEL1','GAUOPT')
          ALLOCATE (Z_HE10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDISOS,0:KARLIM),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE10','GAUOPT')
          ALLOCATE (Z_HE01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                   0:NDISOS,0:KARLIM),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('Z_HE01','GAUOPT')
      END IF
      IF (     ALLOCATED(GAUAVR)) DEALLOCATE(GAUAVR)
      IF (.NOT.ALLOCATED(GAUAVR)) THEN
          IF (I_PART.EQ.0) THEN
              ALLOCATE (GAUAVR(0:NDKART,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUOPT')
          END IF
          IF (I_PART.EQ.1.OR.I_PART.EQ.2.OR.I_PART.EQ.3) THEN
              ALLOCATE (GAUAVR(0:0     ,0:NDKART,0:NDKART,
     *                         0:NDISOS,0:NDISOS),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('GAUAVR','GAUOPT')
          END IF
      END IF
C=======================================================================
C         ATTENTION: UP TO THE VERSION 2.48D, ARRAY "GAUFIL"  BELOW  WAS
C                    NOT DEALLOCATED BEFORE BEING ALLOCATED.  THIS COULD
C                    POTENTIALLY HAVE CREATED PROBLEMS IN CASE  "GAUENE"
C                    OR "GAUOPT" WERE CALLED TWICE WITH VALUES OF I_PART
C                    EQUAL TO ZERO AND GREATER THEN ZERO. THIS  BUG  WAS
C                    CORRECTED IN VERSION 2.48E ON 23/06/2010.
C         ATTENTION: IN THE FUTURE, ANY ALLOCATION THAT DEPENDS  ON  ANY
C                    CHANGEABLE VARIABLE (AND NOT ON A PARAMETER) _MUST_
C                    BE PRECEDED BY A DEALLOCATION.
C=======================================================================
      IF (     ALLOCATED(GAUFIL)) DEALLOCATE(GAUFIL)
      IF (.NOT.ALLOCATED(GAUFIL).AND.I_FIEL.GE.2) THEN
          IF (I_PART.EQ.0) THEN
              ALLOCATE (GAUFIL(0:NDKART,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
          ELSE
              ALLOCATE (GAUFIL(0:0     ,NDBASE,NDBASE,
     *                         0:NDKART,0:NDISOS),STAT=IALLOC)
          END IF
          IF (IALLOC.NE.0) CALL NOALLO('GAUFIL','GAUOPT')
      END IF
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE ENERGIES
C=======================================================================
C
      GAUAVR(:,:,:,:,:)=C_ZERO
C
C=======================================================================
C        ZEROING ARRAYS OF AVERAGE FIELDS
C=======================================================================
C
      IF (I_FIEL.GE.2) THEN
C
          IF (I_PART.EQ.0) THEN
C
              KARLIN=NDKART
          ELSE
              KARLIN=0
C
          END IF
C
          GAUFIL(:,:,:,:,:)=C_ZERO
C
      END IF
C
C=======================================================================
C
C                       I_PART = 0
C
C=======================================================================
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
      IF (I_PART.EQ.0) THEN
C
          DO NX=0,NXMAXV(1)
             DO MX=0,NXMAXV(1)
C
C=======================================================================
C        HERE BEGINS CALCULATION OF THE AVERAGE ENERGIES
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
                DO KARTEZ=0,KARLIM
                   DO ICHARG=ICHLIM,NDISOS
C
                      DO NZ=0,LZOFXV(NX,1)
                         DO MZ=0,LZOFXV(MX,1)
C
                            DO NY=0,LYOZXV(NZ,NX,1)
                               DO MY=0,LYOZXV(MZ,MX,1)
C
                                  IBRA=INDICE(NX,NY,NZ,1)
                                  IKET=INDICE(MX,MY,MZ,1)
C
                                  IF (IDENSI.EQ.0) THEN
C
                                      D_HELP(MY,NY,ICHARG,KARTEZ)=
     *
     *                                DEN_PP(IBRA,IKET, 0,ICHARG)*
     *                                       IPHAPP(MY,NY,KARTEZ)
     *                               +DEN_PP(IBRA,IKET, 1,ICHARG)*
     *                                       IPHAMM(MY,NY,KARTEZ)
C
                                      IF (ISIMPY.NE.1) THEN
C
                                          D_HELP(MY,NY,ICHARG,KARTEZ)=
     *                                    D_HELP(MY,NY,ICHARG,KARTEZ)
     *
     *                                   +DEN_PM(IBRA,IKET, 0,ICHARG)*
     *                                           IPHAMP(MY,NY,KARTEZ)
     *                                   +DEN_PM(IBRA,IKET, 1,ICHARG)*
     *                                           IPHAPM(MY,NY,KARTEZ)
C
                                      END IF
C
                                      D_HELP(MY,NY,ICHARG,KARTEZ)
     *                               =D_HELP(MY,NY,ICHARG,KARTEZ)
     *                               *PHACOM(KARTEZ)
C
                                  ELSE
C
                                      D_HELP(MY,NY,ICHARG,KARTEZ)
     *                               =CHI_PM(IBRA,IKET, 0,ICHARG)
C
                                      D1HELP(MY,NY,ICHARG,KARTEZ)
     *                               =CHI_PM(IBRA,IKET, 1,ICHARG)
C
                                  END IF
C
                               END DO ! MY
                            END DO ! NY
C
                            IF (IDENSI.EQ.0) THEN
C
                                DO NPY=0,NYMAXV(1)
                                   DO MPY=0,NYMAXV(1)
C
                                      BUFCMP = C_ZERO
                                      AUXCMP = C_ZERO
C
                                      DO NY=0,LYOZXV(NZ,NX,1)
                                         DO MY=0,LYOZXV(MZ,MX,1)
C
                                            BUFCMP=BUFCMP
     *                                     +D_HELP(MY,NY,ICHARG,KARTEZ)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                            AUXCMP=AUXCMP
     *                                     +D_HELP(MY,NY,ICHARG,KARTEZ)
     *                                     *GAU_Y1(MPY,MY,NPY,NY)
C
                                         END DO ! MY
                                      END DO ! NY
C
                                   Y_HEL0(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                            =BUFCMP
C
                                   Y_HEL1(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                            =AUXCMP
C
                                   END DO ! MPY
                                END DO ! NPY
C
                            ELSE
C
                                DO NPY=0,NYMAXV(1)
                                   DO MPY=0,NYMAXV(1)
C
                                      BUFCMP = C_ZERO
                                      AUXCMP = C_ZERO
C
                                      DO NY=0,LYOZXV(NZ,NX,1)
                                         DO MY=0,LYOZXV(MZ,MX,1)
C
                                         BUFCMP=BUFCMP
     *                                  +D_HELP(MY,NY,ICHARG,KARTEZ)
     *                                  *GAU_Y0(MPY,MY,NPY,NY)
     *                                  *IPHAMP(MPY,MY,KARTEZ)
     *                                  *IPHAPM(NPY,NY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
     *                                  *PHACOM(KARTEZ)
     *
     *                                  +D1HELP(MY,NY,ICHARG,KARTEZ)
     *                                  *GAU_Y0(MPY,MY,NPY,NY)
     *                                  *IPHAPP(MPY,MY,KARTEZ)
     *                                  *IPHAPP(NPY,NY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
     *                                  *PHACOM(KARTEZ)
C
                                         AUXCMP=AUXCMP
     *                                  +D_HELP(MY,NY,ICHARG,KARTEZ)
     *                                  *GAU_Y1(MPY,MY,NPY,NY)
     *                                  *IPHAMP(MPY,MY,KARTEZ)
     *                                  *IPHAPM(NPY,NY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
     *                                  *PHACOM(KARTEZ)
     *
     *                                  +D1HELP(MY,NY,ICHARG,KARTEZ)
     *                                  *GAU_Y1(MPY,MY,NPY,NY)
     *                                  *IPHAPP(MPY,MY,KARTEZ)
     *                                  *IPHAPP(NPY,NY,KARTEZ)
     *                                  *PHACOM(KARTEZ)
     *                                  *PHACOM(KARTEZ)
C
                                         END DO ! MY
                                      END DO ! NY
C
                                   Y_HEL0(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                            =BUFCMP
C
                                   Y_HEL1(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                            =AUXCMP
C
                                   END DO ! MPY
                                END DO ! NPY
C
                            END IF
C
                        END DO ! MZ
                     END DO ! NZ
C
                  END DO ! ICHARG
                END DO ! KARTEZ
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                DO KARTEZ=0,KARLIM !NDKART
                   DO ICHARG=0,NDISOS
C
                      DO NPY=0,NYMAXV(1)
                         DO MPY=0,NYMAXV(1)
C
                            DO NPZ=0,LZOFYV(NPY,1)
                               DO MPZ=0,LZOFYV(MPY,1)
C
                                  BUFCMP = C_ZERO
                                  AUXCMP = C_ZERO
                                  BUXCMP = C_ZERO
C
                                  DO NZ=0,LZOFXV(NX,1)
                                     DO MZ=0,LZOFXV(MX,1)
C
                                        BUFCMP=BUFCMP
     *                             +Y_HEL0(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                        AUXCMP=AUXCMP
     *                             +Y_HEL1(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                             *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                        BUXCMP=BUXCMP
     *                             +Y_HEL0(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                             *GAU_Z1(MPZ,MZ,NPZ,NZ)
C
                                     END DO ! MZ
                                  END DO ! NZ
C
                                  Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                           =BUFCMP
                                  Z_HE10(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                           =AUXCMP
                                  Z_HE01(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                           =BUXCMP
C
                             END DO ! MPZ
                          END DO ! NPZ
C
                        END DO ! MPY
                     END DO ! NPY
C
                   END DO ! ICHARG
                END DO ! KARTEZ
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C         Here we can add an OpenMP parallel do over NPX
C          - local thread storage is small
C          - inside loop over NX and MX
C
                DO NPX=0,NXMAXV(1)
                   DO MPX=0,NXMAXV(1)
C
                      X_HE00(:,:,:,:)=C_ZERO
                      X_HE10(:,:,:,:)=C_ZERO
                      X_HE01(:,:,:,:)=C_ZERO
C
                      DO NPY=0,LYOFXV(NPX,1)
                         DO MPY=0,LYOFXV(MPX,1)
C
                            DO NPZ=0,LZOXYV(NPX,NPY,1)
                               DO MPZ=0,LZOXYV(MPX,MPY,1)
C
                                  IBRA=INDICE(NPX,NPY,NPZ,1)
                                  IKET=INDICE(MPX,MPY,MPZ,1)
C
                                  IF (IDENSI.EQ.0) THEN
C
                                      DO KARTEP=0,KARLIM
                                         DO ICHARP=ICHLIM,NDISOS
C
                                            E_HELP(KARTEP,ICHARP)=
     *
     *                                      DEN_PP(IBRA,IKET,0,ICHARP)*
     *                                          IPHAPP(MPY,NPY,KARTEP)
     *                                     +DEN_PP(IBRA,IKET,1,ICHARP)*
     *                                          IPHAMM(MPY,NPY,KARTEP)
C
                                            IF(ISIMPY.NE.1)
     *
     *                                      E_HELP(KARTEP,ICHARP)=
     *                                      E_HELP(KARTEP,ICHARP)
     *
     *                                     +DEN_PM(IBRA,IKET,0,ICHARP)*
     *                                          IPHAMP(MPY,NPY,KARTEP)
     *                                     +DEN_PM(IBRA,IKET,1,ICHARP)*
     *                                          IPHAPM(MPY,NPY,KARTEP)
C
                                         END DO
                                      END DO
C
                                  ELSE
C
                                      DO KARTEP=0,KARLIM
                                         DO ICHARP=ICHLIM,NDISOS
C
                                            E_HELP(KARTEP,ICHARP)=
     *
     *                          -CONJG(CHI_PM(IBRA,IKET,0,ICHARP))
C
                                         END DO
                                      END DO
                                  END IF
C
                                  E_HELP(3,0)=E_HELP(3,0)*UNIT_I
                                  E_HELP(3,1)=E_HELP(3,1)*UNIT_I
C
                                  DO ICHARG=ICHLIM,NDISOS
                                     DO ICHARP=ICHLIM,NDISOS
                                        DO KARTEZ=0,KARLIM
                                           DO KARTEP=0,KARLIM
C
                                    X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
C
                                    X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE10(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
C
                                    X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                              X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                           +E_HELP(KARTEP,ICHARP)
     *                           *Z_HE01(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
C
                                           END DO ! KARTEP
                                        END DO ! KARTEZ
                                     END DO ! ICHARP
                                  END DO ! ICHARG
C
                              END DO ! MPZ
                            END DO ! NPZ
C
                         END DO ! MPY
                      END DO ! NPY
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C        HERE THE AVERAGE ENERGIES ARE SUMMED UP
C=======================================================================
C
                      DO ICHARG=ICHLIM,NDISOS
                         DO ICHARP=ICHLIM,NDISOS
                            DO KARTEZ=0,KARLIM
                               DO KARTEP=0,KARLIM
C
                              GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                        GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         *GAU_X0(MPX,MX,NPX,NX)
C
                              GAUAVR(1,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                        GAUAVR(1,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         *GAU_X1(MPX,MX,NPX,NX)
C
                              GAUAVR(2,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                        GAUAVR(2,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         +X_HE10(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         *GAU_X0(MPX,MX,NPX,NX)
C
                              GAUAVR(3,KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                        GAUAVR(3,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         +X_HE01(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         *GAU_X0(MPX,MX,NPX,NX)
C
                              END DO
                           END DO
                         END DO
                      END DO
C
C=======================================================================
C
                   END DO ! MPX
                END DO ! NPX
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
                IF (I_FIEL.GE.2) THEN
C
C=======================================================================
C        HERE BEGINS CALCULATION OF THE AVERAGE FIELDS
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C         Here we can add an OpenMP parallel do over NPX
C          - local thread storage is small
C          - inside loop over NX and MX
                    DO NPX=0,NXMAXV(1)
                       DO MPX=0,NXMAXV(1)
C
                          DO KARTEZ=0,KARLIM
                             DO ICHARG=ICHLIM,NDISOS
C
                                DO NPY=0,LYOFXV(NPX,1)
                                   DO MPY=0,LYOFXV(MPX,1)
C
                                      DO NPZ=0,LZOXYV(NPX,NPY,1)
                                         DO MPZ=0,LZOXYV(MPX,MPY,1)
C
                                         IBRA=INDICE(MPX,MPY,MPZ,1)
                                         IKET=INDICE(NPX,NPY,NPZ,1)
C
                                       GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(1,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                            *GAU_X1(MPX,MX,NPX,NX)
C
                                       GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(2,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE10(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                       GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                                =GAUFIL(3,IBRA,IKET,KARTEZ,ICHARG)
     *                            +Z_HE01(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                            *GAU_X0(MPX,MX,NPX,NX)
C
                                         END DO ! MPZ
                                      END DO ! NPZ
C
                                   END DO ! MPY
                                END DO ! NPY
C
                             END DO ! ICHARG
                          END DO ! KARTEZ
C
                       END DO ! MPX
                    END DO ! NPX
C
C=======================================================================
C        HERE ENDS CALCULATION OF THE AVERAGE FIELDS
C=======================================================================
C
                END IF
C
             END DO ! MX
          END DO ! NX
C
C=======================================================================
C
C                       I_PART > 0
C
C=======================================================================
C
       ELSE
C
          DO NX=0,NXMAXV(1)
             DO MX=0,NXMAXV(1)
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C
C                 The terms below will be the mean-field \Gamma
C                 and pairing field \Delta
C                   \Gamma = \Gamma_{mp,np}
C                          = \sum{m,n} <mp m | v | np n>\rho_{n,m}
C                   \Delta = \Delta_{mp,np}
C                          = \sum{m,n} <mp np | v | m n>\kap_{m,n}
C                          = \sum{m,n} <mp m | v(exc) | np n>\kap_{m,n}
C
                 DO KARTEZ=0,KARLIM
                    DO ICHARG=ICHLIM,NDISOS
C
                       DO NZ=0,LZOFXV(NX,1)
                          DO MZ=0,LZOFXV(MX,1)
C
                            DO NY=0,LYOZXV(NZ,NX,1)
                               DO MY=0,LYOZXV(MZ,MX,1)
C
C                                  IBRA asociated with (n) indexes
C                                  IKET asociated with (m) indexes
                                  IBRA=INDICE(NX,NY,NZ,1)
                                  IKET=INDICE(MX,MY,MZ,1)
C
C                                  The multiplication of the density
C                                  matrix and pairing tensor by phase
C                                  factors IPHAPP, etc. sets the phase
C                                  of the matrices of Gamma and Delta
C                                  in the t-basis
C
C                                  Below: \rho_{nm} <-> DEN(IBRA,IKET)
C
                                  IF (IDENSI.EQ.0) THEN
C
                                      D_HELP(MY,NY,ICHARG,KARTEZ)=
     *
     *                                DEN_PP(IBRA,IKET, 0,ICHARG)*
     *                                       IPHAPP(MY,NY,KARTEZ)
     *                               +DEN_PP(IBRA,IKET, 1,ICHARG)*
     *                                       IPHAMM(MY,NY,KARTEZ)
C
                                      IF (ISIMPY.NE.1)
     *
     *                                    D_HELP(MY,NY,ICHARG,KARTEZ)=
     *                                    D_HELP(MY,NY,ICHARG,KARTEZ)
     *
     *                                   +DEN_PM(IBRA,IKET, 0,ICHARG)*
     *                                           IPHAMP(MY,NY,KARTEZ)
     *                                   +DEN_PM(IBRA,IKET, 1,ICHARG)*
     *                                           IPHAPM(MY,NY,KARTEZ)
C
                                      D_HELP(MY,NY,ICHARG,KARTEZ)
     *                               =D_HELP(MY,NY,ICHARG,KARTEZ)
     *                               *PHACOM(KARTEZ)
C
                                  ELSE
C
C                                  Below: \kappa_{mn} <-> CHI(IKET,IBRA)
C
                                      D_HELP(MY,NY,ICHARG,KARTEZ)
     *                               =CHI_PM(IKET,IBRA, 0,ICHARG)
C
                                      D1HELP(MY,NY,ICHARG,KARTEZ)
     *                               =CHI_PM(IKET,IBRA, 1,ICHARG)
C
                                  END IF ! IDENSI=0
C
                               END DO ! MY
                            END DO ! NY
C
                            IF (IDENSI.EQ.0) THEN
C
                                DO NPY=0,NYMAXV(1)
                                   DO MPY=0,NYMAXV(1)
C
                                      BUFCMP = C_ZERO
C
                                      DO NY=0,LYOZXV(NZ,NX,1)
                                         DO MY=0,LYOZXV(MZ,MX,1)
C
                                            BUFCMP=BUFCMP
     *                                     +D_HELP(MY,NY,ICHARG,KARTEZ)
     *                                     *GAU_Y0(MPY,MY,NPY,NY)
C
                                         END DO ! MY
                                      END DO ! NY
C
                                   Y_HEL0(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                            =BUFCMP
C
                                   END DO ! MPY
                                END DO ! NPY
C
                            ELSE
C
                                DO NPY=0,NYMAXV(1)
                                   DO MPY=0,NYMAXV(1)
C
                                      BUFCMP = C_ZERO
C
                                      DO NY=0,LYOZXV(NZ,NX,1)
                                         DO MY=0,LYOZXV(MZ,MX,1)
C
                                            BUFCMP=BUFCMP
     *
     *                                     +D_HELP(MY,NY,ICHARG,KARTEZ)
     *                                     *GAU_Y0(MPY,NPY,MY,NY)
     *                                     *IPHAMP(MPY,MY,KARTEZ)
     *                                     *IPHAPM(NPY,NY,KARTEZ)
     *                                     *PHACOM(KARTEZ)
     *                                     *PHACOM(KARTEZ)
     *
     *                                     +D1HELP(MY,NY,ICHARG,KARTEZ)
     *                                     *GAU_Y0(MPY,NPY,MY,NY)
     *                                     *IPHAPP(MPY,MY,KARTEZ)
     *                                     *IPHAMM(NPY,NY,KARTEZ)
     *                                     *PHACOM(KARTEZ)
     *                                     *PHACOM(KARTEZ)
C
                                         END DO ! MY
                                      END DO ! NY
C
                                   Y_HEL0(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                            =BUFCMP
C
                                   END DO ! MPY
                                END DO ! NPY
C
                            END IF ! IDENSI=0
C
                        END DO ! MZ
                     END DO ! NZ
C
                  END DO ! ICHARG
                END DO ! KARTEZ
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN Z DIR
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C
                DO KARTEZ=0,KARLIM
                   DO ICHARG=0,NDISOS
C
                      DO NPY=0,NYMAXV(1)
                         DO MPY=0,NYMAXV(1)
C
                            DO NPZ=0,LZOFYV(NPY,1)
                               DO MPZ=0,LZOFYV(MPY,1)
C
                                  BUFCMP = C_ZERO
C
                                  IF (IDENSI.EQ.0) THEN
C
                                      DO NZ=0,LZOFXV(NX,1)
                                         DO MZ=0,LZOFXV(MX,1)
C
                                            BUFCMP=BUFCMP
     *                       +Y_HEL0(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                       *GAU_Z0(MPZ,MZ,NPZ,NZ)
C
                                         END DO ! MZ
                                      END DO ! NZ
C
                                  ELSE
C
                                      DO NZ=0,LZOFXV(NX,1)
                                         DO MZ=0,LZOFXV(MX,1)
C
                                            BUFCMP=BUFCMP
     *                       +Y_HEL0(MZ,NZ,MPY,NPY,ICHARG,KARTEZ)
     *                       *GAU_Z0(MPZ,NPZ,MZ,NZ)
C
                                         END DO ! MZ
                                      END DO ! NZ
                                  END IF
C
                                  Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                           =BUFCMP
C
                             END DO ! MPZ
                          END DO ! NPZ
C
                        END DO ! MPY
                     END DO ! NPY
C
                   END DO ! ICHARG
                END DO ! KARTEZ
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN Y DIR
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C                Preparing the calculation of the expectation value:
C                second trace over \rho and \kappa
C                Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ) contains
C                \Gamma_{ab} or \Delta_{ab}, with (a,b) := (m',n')
C
C
C         Here we could add an OpenMP parallel do over NPX
C          - local thread storage is small
C          - inside loop over NX and MX
C
                DO NPX=0,NXMAXV(1)
                   DO MPX=0,NXMAXV(1)
C
                      X_HE00(:,:,:,:)=C_ZERO
                      X_HE10(:,:,:,:)=C_ZERO
                      X_HE01(:,:,:,:)=C_ZERO
C
                      DO NPY=0,LYOFXV(NPX,1)
                         DO MPY=0,LYOFXV(MPX,1)
C
                            DO NPZ=0,LZOXYV(NPX,NPY,1)
                               DO MPZ=0,LZOXYV(MPX,MPY,1)
C
C                                  IBRA asociated with (n') indexes
C                                  IKET asociated with (m') indexes
                                  IBRA=INDICE(NPX,NPY,NPZ,1)
                                  IKET=INDICE(MPX,MPY,MPZ,1)
C
C                                  Below: \rho_{np,mp} <-> DEN(IBRA,IKET)
C
                                  IF (IDENSI.EQ.0) THEN
C
                                      DO KARTEP=0,KARLIM
                                         DO ICHARP=ICHLIM,NDISOS
C
#if(SWITCH_COULEX==0)
                                            E_HELP(KARTEP,ICHARP)=
     *
     *                                      DEN_PP(IBRA,IKET,0,ICHARP)*
     *                                          IPHAPP(MPY,NPY,KARTEP)
     *                                     +DEN_PP(IBRA,IKET,1,ICHARP)*
     *                                          IPHAMM(MPY,NPY,KARTEP)
C
                                            IF(ISIMPY.NE.1)
     *
     *                                      E_HELP(KARTEP,ICHARP)=
     *                                      E_HELP(KARTEP,ICHARP)
     *
     *                                     +DEN_PM(IBRA,IKET,0,ICHARP)*
     *                                          IPHAMP(MPY,NPY,KARTEP)
     *                                     +DEN_PM(IBRA,IKET,1,ICHARP)*
     *                                          IPHAPM(MPY,NPY,KARTEP)
#else
                                            E_HELP(KARTEP,ICHARP)=
     *
     *                                      BIG_PP(IBRA,IKET,0)*
     *                                          IPHAPP(MPY,NPY,KARTEP)
     *                                     +BIG_PP(IBRA,IKET,1)*
     *                                          IPHAMM(MPY,NPY,KARTEP)
C
                                            IF(ISIMPY.NE.1)
     *
     *                                      E_HELP(KARTEP,ICHARP)=
     *                                      E_HELP(KARTEP,ICHARP)
     *
     *                                     +BIG_PM(IBRA,IKET,0)*
     *                                          IPHAMP(MPY,NPY,KARTEP)
     *                                     +BIG_PM(IBRA,IKET,1)*
     *                                          IPHAPM(MPY,NPY,KARTEP)
#endif
C
                                         END DO ! ICHARP
                                      END DO ! KARTEP
C
                                      E_HELP(3,0)=E_HELP(3,0)*UNIT_I
                                      E_HELP(3,1)=E_HELP(3,1)*UNIT_I
C
                                  ELSE
C
C                                  Below: \kappa_{np,mp} <-> CHI(IBRA,IKET)
C
                                      DO KARTEP=0,KARLIM
                                         DO ICHARP=ICHLIM,NDISOS
C
                                            E_HELP(KARTEP,ICHARP)=
     *
     *                               -CONJG(CHI_PM(IBRA,IKET,0,ICHARP))
C
                                         END DO ! ICHARP
                                      END DO ! KARTEP
C
                                  END IF
C
                                  DO ICHARG=ICHLIM,NDISOS
                                     DO ICHARP=ICHLIM,NDISOS
                                        DO KARTEZ=0,KARLIM
                                           DO KARTEP=0,KARLIM
C
                           X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)=
     *                     X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                                  +E_HELP(KARTEP,ICHARP)
     *                  *Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
C
                                           END DO ! KARTEP
                                        END DO ! KARTEZ
                                     END DO ! ICHARP
                                  END DO ! ICHARG
C
                               END DO ! MPZ
                            END DO ! NPZ
C
                         END DO ! MPY
                      END DO ! NPY
C
C=======================================================================
C        HERE THE AVERAGE ENERGIES ARE SUMMED UP
C=======================================================================
C
                      DO ICHARG=ICHLIM,NDISOS
                         DO ICHARP=ICHLIM,NDISOS
                            DO KARTEZ=0,KARLIM
                               DO KARTEP=0,KARLIM
C
                                  IF (IDENSI.EQ.0) THEN
                                GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         =GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                           +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                           *GAU_X0(MPX,MX,NPX,NX)
                                  ELSE
                                GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                         =GAUAVR(0,KARTEP,KARTEZ,ICHARP,ICHARG)
     *                           +X_HE00(KARTEP,KARTEZ,ICHARP,ICHARG)
     *                           *GAU_X0(MPX,NPX,MX,NX)
                                  END IF
C
                              END DO ! KARTEP
                           END DO ! KARTEZ
                         END DO ! ICHARP
                      END DO ! ICHARG
C
                   END DO ! MPX
                END DO ! NPX
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C=======================================================================
C        HERE BEGINS CALCULATION OF THE AVERAGE FIELDS
C=======================================================================
C
                IF (I_FIEL.GE.2) THEN
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE PARTICLE "1" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C         Here we can add an OpenMP parallel do over NPX
C          - local thread storage is small
C          - inside loop over NX and MX
C
                    IF (IDENSI.EQ.0) THEN
C
                        DO NPX=0,NXMAXV(1)
                           DO MPX=0,NXMAXV(1)
C
                              DO KARTEZ=0,KARLIM
                                 DO ICHARG=ICHLIM,NDISOS
C
                                    DO NPY=0,LYOFXV(NPX,1)
                                       DO MPY=0,LYOFXV(MPX,1)
C
                                          DO NPZ=0,LZOXYV(NPX,NPY,1)
                                             DO MPZ=0,LZOXYV(MPX,MPY,1)
C
                                             IBRA=INDICE(MPX,MPY,MPZ,1)
                                             IKET=INDICE(NPX,NPY,NPZ,1)
C
                                    GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                             =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                         +Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                         *GAU_X0(MPX,MX,NPX,NX)
C
                                             END DO ! MPZ
                                          END DO ! NPZ
C
                                       END DO ! MPY
                                    END DO ! NPY
C
                                 END DO ! ICHARG
                              END DO ! KARTEZ
C
                           END DO ! MPX
                        END DO  ! NPX
C
                    ELSE
C
                        DO NPX=0,NXMAXV(1)
                           DO MPX=0,NXMAXV(1)
C
                              DO KARTEZ=0,KARLIM
                                 DO ICHARG=ICHLIM,NDISOS
C
                                    DO NPY=0,LYOFXV(NPX,1)
                                       DO MPY=0,LYOFXV(MPX,1)
C
                                          DO NPZ=0,LZOXYV(NPX,NPY,1)
                                             DO MPZ=0,LZOXYV(MPX,MPY,1)
C
                                             IBRA=INDICE(MPX,MPY,MPZ,1)
                                             IKET=INDICE(NPX,NPY,NPZ,1)
C
                                    GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                             =GAUFIL(0,IBRA,IKET,KARTEZ,ICHARG)
     *                         +Z_HE00(MPZ,NPZ,MPY,NPY,ICHARG,KARTEZ)
     *                         *GAU_X0(MPX,NPX,MX,NX)
C
                                             END DO ! MPZ
                                          END DO ! NPZ
C
                                       END DO ! MPY
                                    END DO ! NPY
C
                                 END DO ! ICHARG
                              END DO ! KARTEZ
C
                           END DO ! MPX
                        END DO  ! NPX
C
                    END IF ! IDENSI=0
C
                END IF ! I_FIELD=2
C
C=======================================================================
C        ABOVE ENDS CALCULATION OF THE AVERAGE FIELDS
C=======================================================================
C
             END DO ! MX
          END DO ! NX
C
      END IF ! I_PART
C
C=======================================================================
C        ABOVE END  LOOPS OVER THE PARTICLE "2" QUANTUM NUMBERS IN X DIR
C=======================================================================
C
C=======================================================================
                       DEALLOCATE (Y_HEL0,Z_HE00)
      IF (I_PART.EQ.0) DEALLOCATE (Y_HEL1,Z_HE10,Z_HE01)
C=======================================================================
C
      CALL CPUTIM('GAUOPT',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFTHC(MORDER,ND_MAX,N_MAXX,NGAUSS,KARTEZ,GOGWID)
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
C=======================================================================
      DIMENSION
     *          GOGFF0(0:4*NDOSCI+4),
     *          GOGFF1(0:4*NDOSCI+4),
     *          GOGFF2(0:4*NDOSCI+4),
     *          GOGFF4(0:4*NDOSCI+4),
     *          GOGFF6(0:4*NDOSCI+4)
      DIMENSION
     *          COFMOS(0:2*NDOSCI+NDORDE,0:2*NDOSCI+NDORDE)
      DIMENSION
     *          I_DONE(NDKART)
C
      COMMON
     *       /MATTHC/ DENTHC(0:NDORDE,
     *                         0:NDOSCI,0:2*NDOSCI+NDORDE,1:NDKART),
     *                POTTHC(0:2*NDOSCI,0:2*NDOSCI+NDORDE,1:NDKART),
     *                NUMTHC(1:NDKART)
      COMMON
     *       /INTTHC/ GA_THC(0:2*NDOSCI+NDORDE,
     *                       0:2*NDOSCI+NDORDE,1:NDKART)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /DONGOG/ HOMSCA_(NDKART),GOGWID_(NDKART),
     *                N_MAXX_(NDKART),ND_MAX_(NDKART),NGAUSS_(NDKART)
      COMMON
     *       /MUFACR/ NUFACR
C
      DATA   I_DONE   /0,0,0/
C
C=======================================================================
C
      CALL CPUTIM('DEFTHC',1)
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES  THE  HARMONIC-OSCILLATOR  MATRIX
C        ELEMENTS OF THE TWO-BODY GAUSSIAN INTERACTION IN ONE DIMENSION
C        SEE NOTES NO. 63 AND 85.
C        TO BE USED IN THE TENSOR HYPERCONTRACTION METHOD, PRL111-132505
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN DEFTHC'
      IF (MORDER.GT.NDORDE) STOP 'MORDER.GT.NDORDE IN DEFTHC'
      IF (MORDER.GT.     6) STOP 'MORDER.GT.     6 IN DEFTHC'
C
C=======================================================================
C        IF CALCULATIONS HAVE AREADY BEEN DONE, THEY ARE NOT REPEATED
C=======================================================================
C
      I_DONE(KARTEZ)=0
      IF (I_DONE(KARTEZ).EQ.1) THEN
C
          ICHECK=1
C
          IF (HOMSCA(KARTEZ,1).NE.HOMSCA_(KARTEZ)) ICHECK=0
          IF (GOGWID          .NE.GOGWID_(KARTEZ)) ICHECK=0
          IF (N_MAXX          .NE.N_MAXX_(KARTEZ)) ICHECK=0
          IF (ND_MAX          .NE.ND_MAX_(KARTEZ)) ICHECK=0
          IF (NGAUSS          .NE.NGAUSS_(KARTEZ)) ICHECK=0
C
          IF (ICHECK.EQ.1) THEN
C
              CALL CPUTIM('DEFTHC',0)
              RETURN
C
          END IF
C
      END IF
C
      HOMSCA_(KARTEZ)=HOMSCA(KARTEZ,1)
      GOGWID_(KARTEZ)=GOGWID
      N_MAXX_(KARTEZ)=N_MAXX
      ND_MAX_(KARTEZ)=ND_MAX
      NGAUSS_(KARTEZ)=NGAUSS
C
      I_DONE(KARTEZ)=1
C
C=======================================================================
C
      SQ2=SQRT(2.0D0)
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
C=======================================================================
C          CALCULATING THE FORM FACTORS OF THE GAUSSIAN INTERACTION WITH
C          RESPECT TO THE K-TH HERMITE POLYNOMIAL H_K^(0):
C
C          GOGFFI= INT DT EXP(-T^2) (T*SQ2)^I H_K^(0)(T)
C                               * EXP[-2*T^2/(B*GOGWID)^2]
C
C          FOR I=0, 1, 2, 4, AND 6
C=======================================================================
C
      GOGPAR=HOMSCA(KARTEZ,1)*GOGWID
      FACTO1=GOGPAR**2/(2+GOGPAR**2)
      FACTO2=       -1/(2+GOGPAR**2)
C
      DO K=0,4*N_MAXX+4
C
C=======================================================================
C          I=EVEN
C=======================================================================
C
         IF (MOD(K,2).EQ.0) THEN
C
             M=K/2
C
             IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFTHC (1)'
C
             GOGFF0(K)= FACTO1**(1.0D0/2.0D0)*FACTO2**M
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF2(K)=(1 -M*GOGPAR**2)
     *                 *FACTO1**(3.0D0/2.0D0)*FACTO2**(M)
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF4(K)=(3 -6*M*GOGPAR**2 +M*(M-1)*GOGPAR**4)
     *                 *FACTO1**(5.0D0/2.0D0)*FACTO2**(M)
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF6(K)=(15-45*M*GOGPAR**2+15*M*(M-1)*GOGPAR**4
     *                                      -M*(M-1)*(M-2)*GOGPAR**6)
     *                 *FACTO1**(7.0D0/2.0D0)*FACTO2**(M)
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
         ELSE
C
             GOGFF0(K)=0.0D0
             GOGFF2(K)=0.0D0
             GOGFF4(K)=0.0D0
             GOGFF6(K)=0.0D0
C
         END IF
C
C=======================================================================
C          I=ODD
C=======================================================================
C
         IF (MOD(K,2).EQ.1) THEN
C
             M=(K-1)/2
C
             IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFTHC (2)'
C
             GOGFF1(K)= SQRT(FACTO1)**3*FACTO2**M
     *                 *SQRT(FACTOE(M))
     *                 *SQRT(FACTOO(M+1))/FACTOR(M)
     *                 *SQ4_PI
         ELSE
             GOGFF1(K)=0.0D0
C
         END IF
C
C        print *,gogff0(k),gogff1(k),gogff2(k)
C
      END DO
C
C=======================================================================
C          CALCULATING THE MOSHINSKI COFFICIENTS FOR S=0:
C
C          H_K^(0)(X) * H_L^(0)(Y)
C                  = SUM_S COFMOS(K,L) * H_S^(0)(U) * H_P^(0)(T)
C
C          FOR P=K+L-S, U=(X+Y)/SQ2, T=(X-Y)/SQ2
C
C=======================================================================
C          COEFFICIENTS ARE READY UP TO ORDER 6
C=======================================================================
C
      DO K=0,2*N_MAXX+MORDER
         DO L=0,2*N_MAXX+MORDER
C
            IF (MOD(K+L,2).EQ.0) THEN
C
                M=(K+L)/2
C
                IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFTHC (3)'
C
                FACTOM=FACTOE(M)*FACTOO(M)
C
            ELSE
C
                M=(K+L-1)/2
C
                IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFTHC (4)'
C
                FACTOM=FACTOE(M)*FACTOO(M+1)
C
            END IF
C
            COFMOS(K,L)=(-1)**L*SQRT(FACTOM/(2.0D0)**(K+L)
     *                                             /FACTOR(K)/FACTOR(L))
C
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE FINAL MATRIX ELEMENTS
C=======================================================================
C
      DO K=0,NUMTHC(KARTEZ)
         DO L=0,NUMTHC(KARTEZ)
C
            GA_THC(K,L,KARTEZ)=0.0D0
C
            DO N=0,2*N_MAXX
               DO M=0,2*N_MAXX
C
                  IF (MOD(N+M,2).EQ.0)
     *
     *                GA_THC(K,L,KARTEZ)=GA_THC(K,L,KARTEZ)
     *                                  +COFMOS(N,M)*GOGFF0(N+M)
     *                                  *POTTHC(N,K,KARTEZ)
     *                                  *POTTHC(M,L,KARTEZ)
     *                                  /HOMSCA(KARTEZ,1)
C
              END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('DEFTHC',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFGOG(N_MAXX,NGAUSS,KARTEZ,GOGWID,
     *                  GAUEL0,GAUEL1,GAUEL2,GAUEL4,GAUEL6,
     *                                       GAUT21,GAUT22,
     *                                GAUT41,GAUT42,GAUT43)
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
      REAL*16
     *          FACTOM,COFMOS,GOGFF0,GOGFF1,GOGMOS,
     *          GOGPAR,FACTO1,FACTO2,
     *          SQ4_PI,FOUR,ONE,TWO,
     *          QOEF00,QOMSCA,RESULT
C=======================================================================
      DIMENSION
     *          GOGFF0(0:4*NDOSCI+4),
     *          GOGFF1(0:4*NDOSCI+4),
     *          GOGFF2(0:4*NDOSCI+4),
     *          GOGFF4(0:4*NDOSCI+4),
     *          GOGFF6(0:4*NDOSCI+4)
      DIMENSION
     *          COFMOS(0:2*NDOSCI+6,0:2*NDOSCI+6),
     *          GOGMOS(0:2*NDOSCI+6,0:2*NDOSCI+6)
      DIMENSION
     *          COFSCA(0:2*NDOSCI+1,0:2*NDOSCI+1)
      REAL*16, DIMENSION(:,:,:,:) ::
     *          QAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          QAUEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          PAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
C
      INTEGER,                              SAVE :: ND_STO
      INTEGER, DIMENSION(:),                SAVE :: I_DONE(NDKART)
      REAL,    DIMENSION(:,:), ALLOCATABLE, SAVE :: HOMSC1,GOGWI1
      REAL,    DIMENSION(:,:), ALLOCATABLE       :: HOMSC2,GOGWI2
      INTEGER, DIMENSION(:,:), ALLOCATABLE, SAVE :: N_MAX1,NGAUS1
      INTEGER, DIMENSION(:,:), ALLOCATABLE       :: N_MAX2,NGAUS2
      REAL,    DIMENSION(:,:,:,:,:,:,:), ALLOCATABLE, SAVE :: ELESTO
      REAL,    DIMENSION(:,:,:,:,:,:,:), ALLOCATABLE       :: ELESAV
C
      COMMON
     *       /QOEXYZ/ QOEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO3XYZ/ COEF12(0:ND2MAX+1,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF03(0:ND2MAX+1,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO4XYZ/ COEF22(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF13(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF04(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /MUFACR/ NUFACR
C
      DATA   I_DONE   /0,0,0/
C
C=======================================================================
C
      CALL CPUTIM('DEFGOG',1)
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES  THE  HARMONIC-OSCILLATOR  MATRIX
C        ELEMENTS OF THE TWO-BODY GAUSSIAN INTERACTION IN ONE DIMENSION
C        SEE NOTES NO. 63 AND 85.
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN DEFGOG'
C
      IF (.NOT.ALLOCATED(ELESTO)) THEN
C
          ND_STO=1
C
          ALLOCATE (ELESTO(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_STO,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESTO','DEFGOG')
C
          ALLOCATE (HOMSC1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC1','DEFGOG')
C
          ALLOCATE (GOGWI1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI1','DEFGOG')
C
          ALLOCATE (N_MAX1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX1','DEFGOG')
C
          ALLOCATE (NGAUS1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS1','DEFGOG')
C
      END IF
C
C=======================================================================
C        IF CALCULATIONS HAVE AREADY BEEN DONE, THEY ARE NOT REPEATED
C=======================================================================
C
      DO I_STOE=1,I_DONE(KARTEZ)
C
         ICHECK=1
C
         IF (HOMSCA(KARTEZ,1).NE.HOMSC1(KARTEZ,I_STOE)) ICHECK=0
         IF (GOGWID          .NE.GOGWI1(KARTEZ,I_STOE)) ICHECK=0
         IF (N_MAXX          .NE.N_MAX1(KARTEZ,I_STOE)) ICHECK=0
         IF (NGAUSS          .NE.NGAUS1(KARTEZ,I_STOE)) ICHECK=0
C
         IF (ICHECK.EQ.1) THEN
C
             IF (10.GT.NDNUME) STOP 'INCREASE NDNUME IN DEFGOG'
C
             GAUEL0(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 1)
             GAUEL1(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 2)
             GAUEL2(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 3)
             GAUEL4(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 4)
             GAUEL6(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 5)
             GAUT21(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 6)
             GAUT22(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 7)
             GAUT41(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 8)
             GAUT42(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 9)
             GAUT43(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE,10)
C
             CALL CPUTIM('DEFGOG',0)
             RETURN
C
         END IF
C
      END DO
C
      IF (I_DONE(KARTEZ).GE.ND_STO) THEN
C
C=======================================================================
C        HERE WE EXTEND THE ALLOCATION OF ARRAYS BY ONE AND COPY ALREADY
C        SAVED INFO INTO THE EXTENDED ARRAYS
C=======================================================================
C
          ND_SAV=ND_STO
C
          ALLOCATE (ELESAV(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_SAV,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESAV','DEFGOG')
C
          ALLOCATE (HOMSC2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC2','DEFGOG')
C
          ALLOCATE (GOGWI2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI2','DEFGOG')
C
          ALLOCATE (N_MAX2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX2','DEFGOG')
C
          ALLOCATE (NGAUS2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS2','DEFGOG')
C
          ELESAV=ELESTO
          HOMSC2=HOMSC1
          GOGWI2=GOGWI1
          N_MAX2=N_MAX1
          NGAUS2=NGAUS1
C
          DEALLOCATE (ELESTO)
          DEALLOCATE (HOMSC1)
          DEALLOCATE (GOGWI1)
          DEALLOCATE (N_MAX1)
          DEALLOCATE (NGAUS1)
C
          ND_STO=ND_STO+1
C
          ALLOCATE (ELESTO(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_STO,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESTO','DEFGOG')
C
          ALLOCATE (HOMSC1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC1','DEFGOG')
C
          ALLOCATE (GOGWI1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI1','DEFGOG')
C
          ALLOCATE (N_MAX1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX1','DEFGOG')
C
          ALLOCATE (NGAUS1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS1','DEFGOG')
C
          ELESTO(:,:,:,:,:,1:ND_SAV,:)=ELESAV(:,:,:,:,:,1:ND_SAV,:)
          HOMSC1(        :,1:ND_SAV  )=HOMSC2(        :,1:ND_SAV  )
          GOGWI1(        :,1:ND_SAV  )=GOGWI2(        :,1:ND_SAV  )
          N_MAX1(        :,1:ND_SAV  )=N_MAX2(        :,1:ND_SAV  )
          NGAUS1(        :,1:ND_SAV  )=NGAUS2(        :,1:ND_SAV  )
C
          DEALLOCATE (ELESAV)
          DEALLOCATE (HOMSC2)
          DEALLOCATE (GOGWI2)
          DEALLOCATE (N_MAX2)
          DEALLOCATE (NGAUS2)
C
      END IF
C
      I_DONE(KARTEZ)=I_DONE(KARTEZ)+1
C
      J_STOE=I_DONE(KARTEZ)
C
      HOMSC1(KARTEZ,J_STOE)=HOMSCA(KARTEZ,1)
      GOGWI1(KARTEZ,J_STOE)=GOGWID
      N_MAX1(KARTEZ,J_STOE)=N_MAXX
      NGAUS1(KARTEZ,J_STOE)=NGAUSS
C
C=======================================================================
C
      SQ2=SQRT(2.0D0)
C
      FOUR=4
      ONE =1
      TWO =2
C
      SQ4_PI=SQRT(SQRT(FOUR*ATAN(ONE)))
C
      QOMSCA=HOMSCA(KARTEZ,1)
C
C=======================================================================
C          CALCULATING THE FORM FACTORS OF THE GAUSSIAN INTERACTION WITH
C          RESPECT TO THE K-TH HERMITE POLYNOMIAL H_K^(0):
C
C          GOGFFI= INT DT EXP(-T^2) (T*SQ2)^I H_K^(0)(T)
C                               * EXP[-2*T^2/(B*GOGWID)^2]
C
C          FOR I=0, 1, 2, 4, AND 6
C=======================================================================
C
      GOGPAR=HOMSCA(KARTEZ,1)*GOGWID
      FACTO1=GOGPAR**2/(2+GOGPAR**2)
      FACTO2=       -1/(2+GOGPAR**2)
C
      DO K=0,4*N_MAXX+4
C
C=======================================================================
C          I=EVEN
C=======================================================================
C
         IF (MOD(K,2).EQ.0) THEN
C
             M=K/2
C
             IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFGOG (1)'
C
             GOGFF0(K)= SQRT(FACTO1)*FACTO2**M
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF2(K)=(1 -M*GOGPAR**2)
     *                 *FACTO1**(3.0D0/2.0D0)*FACTO2**(M)
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF4(K)=(3 -6*M*GOGPAR**2 +M*(M-1)*GOGPAR**4)
     *                 *FACTO1**(5.0D0/2.0D0)*FACTO2**(M)
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF6(K)=(15-45*M*GOGPAR**2+15*M*(M-1)*GOGPAR**4
     *                                      -M*(M-1)*(M-2)*GOGPAR**6)
     *                 *FACTO1**(7.0D0/2.0D0)*FACTO2**(M)
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
         ELSE
C
             GOGFF0(K)=0
             GOGFF2(K)=0
             GOGFF4(K)=0
             GOGFF6(K)=0
C
         END IF
C
C=======================================================================
C          I=ODD
C=======================================================================
C
         IF (MOD(K,2).EQ.1) THEN
C
             M=(K-1)/2
C
             IF (M+1.GT.NUFACR) STOP ' M+1 TOO LARGE IN DEFGOG (2)'
C
             GOGFF1(K)= SQRT(FACTO1)**3*FACTO2**M
     *                 *SQRT(FACTOE(M))
     *                 *SQRT(FACTOO(M+1))/FACTOR(M)
     *                 *SQ4_PI
         ELSE
             GOGFF1(K)=0.0D0
C
         END IF
C
C        print *,gogff0(k),gogff1(k),gogff2(k)
C
      END DO
C
C=======================================================================
C          CALCULATING THE SCALED HERMITE POLYNOMIALS CEFFICIENTS:
C
C          H_K^(0)(T/SQ2) = SUM_L COFSCA(K,L) H_L^(0)(T)
C=======================================================================
C
      DO K=0,2*N_MAXX+1
         DO L=0,K
C
            M=K-L
C
            IF (K.GT.NUFACR)   STOP ' K TOO LARGE IN DEFGOG (3)'
            IF (L.GT.NUFACR)   STOP ' L TOO LARGE IN DEFGOG (3)'
            IF (M/2.GT.NUFACR) STOP ' M/2 TOO LARGE IN DEFGOG (3)'
C
            IF (MOD(M,2).EQ.0) THEN
C
                COFSCA(K,L)=SQRT(FACTOR(K)/FACTOR(L))
     *                     *(-1)**(M/2)/FACTOR(M/2)/SQ2**L/2.0D0**M
            ELSE
                COFSCA(K,L)=0.0D0
            END IF
C
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE MOSHINSKI COFFICIENTS FOR S=0:
C
C          H_K^(0)(X) * H_L^(0)(Y)
C                  = SUM_S COFMOS(K,L) * H_S^(0)(U) * H_P^(0)(T)
C
C          FOR P=K+L-S, U=(X+Y)/SQ2, T=(X-Y)/SQ2
C
C=======================================================================
C          COEFFICIENTS ARE READY UP TO ORDER 6
C=======================================================================
C
      DO K=0,2*N_MAXX+6
         DO L=0,2*N_MAXX+6
C
            IF (MOD(K+L,2).EQ.0) THEN
C
                M=(K+L)/2
C
                IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFGOG (4)'
C
                FACTOM=FACTOE(M)*FACTOO(M)
C
            ELSE
C
                M=(K+L-1)/2
C
                IF (M+1.GT.NUFACR) STOP ' M+1 TOO LARGE IN DEFGOG (4)'
C
                FACTOM=FACTOE(M)*FACTOO(M+1)
C
            END IF
C
            IF (K.GT.NUFACR)   STOP ' K TOO LARGE IN DEFGOG (4)'
            IF (L.GT.NUFACR)   STOP ' L TOO LARGE IN DEFGOG (4)'
C
            COFMOS(K,L)=(-1)**L*SQRT(FACTOM/TWO**(K+L)
     *                                             /FACTOR(K)/FACTOR(L))
            GOGMOS(K,L)=COFMOS(K,L)*GOGFF0(K+L)
C
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE FINAL MATRIX ELEMENTS
C=======================================================================
C          BELOW, ARRAYS "GAUEL_" ARE DIVIDED BY THE  FACTORS  HOMSCA
C          IN ORDER TO REMOVE THE DIMENSIONAL FACTORS INCLUDED IN THE
C          CALCULATED VALUES OF THE COEFFICINTS COEF00.  IN ADDITION,
C          GAUEL1 IS DIVIDED BY ANOTHER FACTOR HOMSCA, AND
C          GAUEL2 IS DIVIDED BY ANOTHER FACTOR HOMSCA**2, ECT.,
C          SO AS TO TAKE INTO ACCOUT THE DIMENSIONS OF  THE  POSITION
C          VARIABLE THAT MULTIPLY THE GAUSSIAN INTERACTION.
C=======================================================================
C
      DO N=0,N_MAXX
         DO M=0,N_MAXX
            DO NP=0,N_MAXX
               DO MP=0,N_MAXX
C
                  QAUEL0(NP,MP,N,M)=0
                  QAUEL1(NP,MP,N,M)=0
                  PAUEL0(NP,MP,N,M)=0
                  GAUEL1(NP,MP,N,M)=0
                  GAUEL2(NP,MP,N,M)=0
                  GAUEL4(NP,MP,N,M)=0
                  GAUEL6(NP,MP,N,M)=0
C
                  DO K=N+NP,0,-2
                     DO L=M+MP,0,-2
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            RESULT=           GOGMOS(K,L)
     *                                       *QOEF00(K,NP,N,KARTEZ)
     *                                       *QOEF00(L,MP,M,KARTEZ)
C
                            KL=(K+L)/2
                            NN=(K+NP+N)/2
                            MM=(L+MP+M)/2
C
C                           RESUL0=(-1)**L*SQRT(TWO**(K+L))
C    *                            *SQRT(FACTO1)*FACTO2**KL
C    *                            *SQRT(FACTOR(NP)*FACTOR(N))
C    *                          /FACTOR(NN-K)*FACTOR(NN-NP)*FACTOR(NN-N)
C    *                            *SQRT(FACTOR(MP)*FACTOR(M))
C    *                          /FACTOR(MM-L)*FACTOR(MM-MP)*FACTOR(MM-M)
C    *                            /SQ4_PI
C
                            IF (RESULT.GT.0) THEN
C
                                PAUEL0(NP,MP,N,M)=PAUEL0(NP,MP,N,M)
     *                                           +RESULT
                            ELSE
                                QAUEL0(NP,MP,N,M)=QAUEL0(NP,MP,N,M)
     *                                           +RESULT
                            END IF
C
C                     IF (N.EQ.24.AND.M.EQ.24.AND.NP.EQ.24.AND.MP.EQ.24
C    *                .OR.N.EQ.23.AND.M.EQ.24.AND.NP.EQ.24.AND.MP.EQ.24
C    *                .OR.N.EQ.24.AND.M.EQ.23.AND.NP.EQ.24.AND.MP.EQ.24)
C    *                WRITE (*,'('' NP='',I3,'' MP='',I3,
C    *                           '' N ='',I3,'' M ='',I3,
C    *                           '' K ='',I3,'' L ='',I3,8D14.6)')
C    *                                        NP,MP,N,M,K,L,
C    *                                        GOGMOS(K,L),
C    *                                        QOEF00(K,NP,N,KARTEZ),
C    *                                        QOEF00(L,MP,M,KARTEZ),
C    *                                        RESULT,RESUL0,
C    *                                        PAUEL0(NP,MP,N,M),
C    *                                        QAUEL0(NP,MP,N,M),
C    *                                        PAUEL0(NP,MP,N,M)+
C    *                                        QAUEL0(NP,MP,N,M)
C
                            GAUEL2(NP,MP,N,M)=GAUEL2(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF2(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**3
C
                            GAUEL4(NP,MP,N,M)=GAUEL4(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF4(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**5
C
                            GAUEL6(NP,MP,N,M)=GAUEL6(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF6(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**7
C
                        ELSE
C
                            QAUEL1(NP,MP,N,M)=QAUEL1(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF1(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**2
C
                        END IF
C
                     END DO
                  END DO
C
                  QAUEL0(NP,MP,N,M)=QAUEL0(NP,MP,N,M)+PAUEL0(NP,MP,N,M)
C
                  QAUEL0(NP,MP,N,M)=SQ4_PI*QAUEL0(NP,MP,N,M)/QOMSCA
                  QAUEL1(NP,MP,N,M)=SQ4_PI*QAUEL1(NP,MP,N,M)
                  GAUEL2(NP,MP,N,M)=SQ4_PI*GAUEL2(NP,MP,N,M)
                  GAUEL4(NP,MP,N,M)=SQ4_PI*GAUEL4(NP,MP,N,M)
                  GAUEL6(NP,MP,N,M)=SQ4_PI*GAUEL6(NP,MP,N,M)
C
                  GAUEL0(NP,MP,N,M)=QAUEL0(NP,MP,N,M)
                  GAUEL1(NP,MP,N,M)=QAUEL1(NP,MP,N,M)
C
C=======================================================================
C           ORDER 2
C=======================================================================
C           GAUT21 CONTAINS MATRIX ELEMENTS OF (K'*^2+K^2)/2
C           GAUT22 CONTAINS MATRIX ELEMENTS OF  K'* DOT K
C=======================================================================
C
                  GAUT21(NP,MP,N,M)=0.0D0
                  GAUT22(NP,MP,N,M)=0.0D0
C
                  DO K=0,N+NP+2
                     DO L=0,M+MP
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT21(NP,MP,N,M)=GAUT21(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-8)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-8)
C
                            GAUT22(NP,MP,N,M)=GAUT22(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/4
     *
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP
                     DO L=0,M+MP+2
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT21(NP,MP,N,M)=GAUT21(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-8)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-8)
C
                            GAUT22(NP,MP,N,M)=GAUT22(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/4
C
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+1
                     DO L=0,M+MP+1
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT21(NP,MP,N,M)=GAUT21(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/4
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/4
C
                            GAUT22(NP,MP,N,M)=GAUT22(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-4)
C
                        END IF
C
                     END DO
                  END DO
C
                  GAUT21(NP,MP,N,M)=SQ4_PI*GAUT21(NP,MP,N,M)
                  GAUT22(NP,MP,N,M)=SQ4_PI*GAUT22(NP,MP,N,M)
C
C=======================================================================
C           ORDER 4
C=======================================================================
C           GAUT41 CONTAINS MATRIX ELEMENTS OF [(K'*^2+K^2)/2]^2
C           GAUT42 CONTAINS MATRIX ELEMENTS OF [K'* DOT K](K'*^2+K^2)/2
C           GAUT43 CONTAINS MATRIX ELEMENTS OF [K'* DOT K]^2
C=======================================================================
C
                  GAUT41(NP,MP,N,M)=0.0D0
                  GAUT42(NP,MP,N,M)=0.0D0
                  GAUT43(NP,MP,N,M)=0.0D0
C
                  DO K=0,N+NP+4
                     DO L=0,M+MP
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF04(K,N,NP,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF22(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)*2
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF04(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF13(K,N,NP,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF13(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF22(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+3
                     DO L=0,M+MP+1
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF03(K,N,NP,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF03(K,NP,N,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-4)
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,N,NP,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-3)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF03(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-1)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,NP,N,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-3)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF03(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-1)
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-2)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-2)
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+2
                     DO L=0,M+MP+2
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)*6
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)*2
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)*8
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)*2
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)*6
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)*3
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)*3
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)*3
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)*3
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)*4
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+1
                     DO L=0,M+MP+3
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF03(L,M,MP,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF12(L,MP,M,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF12(L,M,MP,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF03(L,MP,M,KARTEZ)*(-4)
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF03(L,M,MP,KARTEZ)*(-1)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF12(L,M,MP,KARTEZ)*(-3)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF03(L,MP,M,KARTEZ)*(-1)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF12(L,MP,M,KARTEZ)*(-3)
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF12(L,M,MP,KARTEZ)*(-2)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF12(L,MP,M,KARTEZ)*(-2)
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP
                     DO L=0,M+MP+4
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF04(L,M,MP,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF22(L,MP,M,KARTEZ)*2
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF04(L,MP,M,KARTEZ)
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF13(L,M,MP,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF13(L,MP,M,KARTEZ)
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF22(L,MP,M,KARTEZ)
                        END IF
C
                     END DO
                  END DO
C
                  GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                             *SQ4_PI/HOMSCA(KARTEZ,1)/64
                  GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                             *SQ4_PI/HOMSCA(KARTEZ,1)/(-32)
                  GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                             *SQ4_PI/HOMSCA(KARTEZ,1)/16
C
               END DO
            END DO
         END DO
      END DO
C
C=======================================================================
C          HERE THE CALCULATED MATRIX ELEMENTS ARE STORED
C=======================================================================
C
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 1)=GAUEL0(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 2)=GAUEL1(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 3)=GAUEL2(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 4)=GAUEL4(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 5)=GAUEL6(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 6)=GAUT21(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 7)=GAUT22(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 8)=GAUT41(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 9)=GAUT42(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE,10)=GAUT43(:,:,:,:)
C
C=======================================================================
C          HERE WE CALL THE SUBROUTINE "TESGOG", WHICH TESTS RESULTS
C          PRODUCED BY THIS SUBROUTINE. THE  CALL  IS  ACTIVATED  BY
C          SETTING I_TEST=1, 2, or 3 BELOW.
C=======================================================================
C
      I_TEST=0
      IF (I_TEST.NE.0) THEN
C
          DO I_KIND=0,1
C
            CALL TESGOG(N_MAXX,NGAUSS,KARTEZ,
     *                  GOGWID,QAUEL0,QAUEL1,
     *                  GOGFF0,GOGFF1,
     *                  COFMOS,COFSCA,
     *                  GOGPAR,
     *                  SQ2,
     *                  I_KIND,I_TEST)
C
          END DO
C
          STOP 'END OF TESTS IN DEFGOG'
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('DEFGOG',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEF2BC(N_MAXX,NGAUSS,KARTEZ,GOGWID,
     *                 TBC0_0,TBC0_1,TBC0_2,TBC0_3,TBC1_0,TBC1_1,TBC1_2)
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
C=======================================================================
      DIMENSION
     *          GOGFF0(0:4*NDOSCI+5),
     *          GOGFF1(0:4*NDOSCI+5),
     *          GOGFF2(0:4*NDOSCI+5),
     *          GOGFF3(0:4*NDOSCI+5)
      DIMENSION
     *          COFMOS(0:2*NDOSCI+6,0:2*NDOSCI+6),
     *          COFMO1(0:2*NDOSCI+7,0:2*NDOSCI+7)
      DIMENSION
     *          TBC0_0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          TBC0_1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          TBC0_2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          TBC0_3(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          TBC1_0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          TBC1_1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          TBC1_2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
C
      INTEGER,                              SAVE :: ND_STO
      INTEGER, DIMENSION(:),                SAVE :: I_DONE(NDKART)
      REAL,    DIMENSION(:,:), ALLOCATABLE, SAVE :: HOMSC1,GOGWI1
      REAL,    DIMENSION(:,:), ALLOCATABLE       :: HOMSC2,GOGWI2
      INTEGER, DIMENSION(:,:), ALLOCATABLE, SAVE :: N_MAX1,NGAUS1
      INTEGER, DIMENSION(:,:), ALLOCATABLE       :: N_MAX2,NGAUS2
      REAL,    DIMENSION(:,:,:,:,:,:,:), ALLOCATABLE, SAVE :: ELESTO
      REAL,    DIMENSION(:,:,:,:,:,:,:), ALLOCATABLE       :: ELESAV
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO3XYZ/ COEF12(0:ND2MAX+1,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF03(0:ND2MAX+1,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO4XYZ/ COEF22(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF13(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF04(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /MUFACR/ NUFACR
C
      DATA   I_DONE   /0,0,0/
C
C=======================================================================
C
      CALL CPUTIM('DEF2BC',1)
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES  THE  HARMONIC-OSCILLATOR  MATRIX
C        ELEMENTS OF THE TWO-BODY GAUSSIAN INTERACTION IN ONE DIMENSION
C        TO BE USED FOR THE TWO-BODY-CURRENT CONTRIBUTIONS TO  MAGNETIC
C        MOMENTS
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN DEF2BC'
C
      IF (.NOT.ALLOCATED(ELESTO)) THEN
C
          ND_STO=1
C
          ALLOCATE (ELESTO(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_STO,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESTO','DEF2BC')
C
          ALLOCATE (HOMSC1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC1','DEF2BC')
C
          ALLOCATE (GOGWI1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI1','DEF2BC')
C
          ALLOCATE (N_MAX1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX1','DEF2BC')
C
          ALLOCATE (NGAUS1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS1','DEF2BC')
C
      END IF
C
C=======================================================================
C        IF CALCULATIONS HAVE AREADY BEEN DONE, THEY ARE NOT REPEATED
C=======================================================================
C
      DO I_STOE=1,I_DONE(KARTEZ)
C
         ICHECK=1
C
         IF (HOMSCA(KARTEZ,1).NE.HOMSC1(KARTEZ,I_STOE)) ICHECK=0
         IF (GOGWID          .NE.GOGWI1(KARTEZ,I_STOE)) ICHECK=0
         IF (N_MAXX          .NE.N_MAX1(KARTEZ,I_STOE)) ICHECK=0
         IF (NGAUSS          .NE.NGAUS1(KARTEZ,I_STOE)) ICHECK=0
C
         IF (ICHECK.EQ.1) THEN
C
             IF (10.GT.NDNUME) STOP 'INCREASE NDNUME IN DEF2BC'
C
             TBC0_0(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 1)
             TBC0_1(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 2)
             TBC0_2(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 3)
             TBC0_3(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 4)
             TBC1_0(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 5)
             TBC1_1(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 6)
             TBC1_2(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 7)
             GAUT41(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 8)
             GAUT42(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 9)
             GAUT43(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE,10)
C
             CALL CPUTIM('DEF2BC',0)
             RETURN
C
         END IF
C
      END DO
C
      IF (I_DONE(KARTEZ).GE.ND_STO) THEN
C
C=======================================================================
C        HERE WE EXTEND THE ALLOCATION OF ARRAYS BY ONE AND COPY ALREADY
C        SAVED INFO INTO THE EXTENDED ARRAYS
C=======================================================================
C
          ND_SAV=ND_STO
C
          ALLOCATE (ELESAV(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_SAV,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESAV','DEF2BC')
C
          ALLOCATE (HOMSC2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC2','DEF2BC')
C
          ALLOCATE (GOGWI2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI2','DEF2BC')
C
          ALLOCATE (N_MAX2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX2','DEF2BC')
C
          ALLOCATE (NGAUS2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS2','DEF2BC')
C
          ELESAV=ELESTO
          HOMSC2=HOMSC1
          GOGWI2=GOGWI1
          N_MAX2=N_MAX1
          NGAUS2=NGAUS1
C
          DEALLOCATE (ELESTO)
          DEALLOCATE (HOMSC1)
          DEALLOCATE (GOGWI1)
          DEALLOCATE (N_MAX1)
          DEALLOCATE (NGAUS1)
C
          ND_STO=ND_STO+1
C
          ALLOCATE (ELESTO(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_STO,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESTO','DEF2BC')
C
          ALLOCATE (HOMSC1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC1','DEF2BC')
C
          ALLOCATE (GOGWI1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI1','DEF2BC')
C
          ALLOCATE (N_MAX1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX1','DEF2BC')
C
          ALLOCATE (NGAUS1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS1','DEF2BC')
C
          ELESTO(:,:,:,:,:,1:ND_SAV,:)=ELESAV(:,:,:,:,:,1:ND_SAV,:)
          HOMSC1(        :,1:ND_SAV  )=HOMSC2(        :,1:ND_SAV  )
          GOGWI1(        :,1:ND_SAV  )=GOGWI2(        :,1:ND_SAV  )
          N_MAX1(        :,1:ND_SAV  )=N_MAX2(        :,1:ND_SAV  )
          NGAUS1(        :,1:ND_SAV  )=NGAUS2(        :,1:ND_SAV  )
C
          DEALLOCATE (ELESAV)
          DEALLOCATE (HOMSC2)
          DEALLOCATE (GOGWI2)
          DEALLOCATE (N_MAX2)
          DEALLOCATE (NGAUS2)
C
      END IF
C
      I_DONE(KARTEZ)=I_DONE(KARTEZ)+1
C
      J_STOE=I_DONE(KARTEZ)
C
      HOMSC1(KARTEZ,J_STOE)=HOMSCA(KARTEZ,1)
      GOGWI1(KARTEZ,J_STOE)=GOGWID
      N_MAX1(KARTEZ,J_STOE)=N_MAXX
      NGAUS1(KARTEZ,J_STOE)=NGAUSS
C
C=======================================================================
C
      SQ2=SQRT(2.0D0)
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
C=======================================================================
C          CALCULATING THE FORM FACTORS OF THE GAUSSIAN INTERACTION WITH
C          RESPECT TO THE K-TH HERMITE POLYNOMIAL H_K^(0)
C          FOR K-EVEN AND I-EVEN OR K-ODD AND I-ODD:
C
C                GOGFFI= INT DT EXP(-T^2) (T*SQ2)^I H_K^(0)(T)
C                               * EXP[-2*T^2/(B*GOGWID)^2]
C
C          CALCULATING THE FORM FACTORS OF THE GAUSSIAN INTERACTION WITH
C          RESPECT TO THE (K-1)-TH HERMITE POLYNOMIAL H_(K-1)^(0)
C          FOR K-EVEN AND I-ODD OR K-ODD AND I-EVEN:
C
C                GOGFFI= INT DT EXP(-T^2) (T*SQ2)^I H_(K-1)^(0)(T)
C                               * EXP[-2*T^2/(B*GOGWID)^2]
C
C          FOR I=0, 1, 2, AND 3
C=======================================================================
C
      GOGPAR=HOMSCA(KARTEZ,1)*GOGWID
      FACTO1=GOGPAR**2/(2+GOGPAR**2)
      FACTO2=       -1/(2+GOGPAR**2)
C
      DO K=0,4*N_MAXX+4
C
         GOGFF0(K)= 0.0D0
         GOGFF1(K)= 0.0D0
         GOGFF2(K)= 0.0D0
         GOGFF3(K)= 0.0D0
C
         IF (MOD(K,2).EQ.0) THEN
C
             M=K/2
             EM=M
C
             IF (M.GT.NUFACR)   STOP ' M TOO LARGE IN DEF2BC (1)'
C
             GOGFF0(K)= SQRT(FACTO1)*FACTO2**M
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF2(K)=(1 -M*GOGPAR**2)
     *                 *SQRT(FACTO1**3)*FACTO2**M
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF1(K)=-SQ4_PI*SQRT(EM)*SQRT(FACTOO(M))*SQRT(FACTOE(M))*
     *         (GOGPAR**2)*(FACTO1**(1.0D0/2.0D0))*(FACTO2**M)/
     *         FACTOR(M)/SQRT(2.0D0)

             GOGFF3(K)=-SQ4_PI*SQRT(EM)*SQRT(FACTOO(M))*SQRT(FACTOE(M))*
     *         (FACTO1**(3.0D0/2.0D0))*(GOGPAR**2)*(FACTO2**M)*
     *         (3.0D0-(M-1)*(GOGPAR**2))/FACTOR(M)/SQRT(2.0D0)

         ELSE
C
             M=(K-1)/2
C
             IF (M+1.GT.NUFACR)   STOP ' M+1 TOO LARGE IN DEF2BC (1)'
C
             GOGFF1(K)= SQRT(FACTO1)**3*FACTO2**M
     *                 *SQRT(FACTOE(M))
     *                 *SQRT(FACTOO(M+1))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF3(K)= SQRT(FACTOO(M+1))*SQRT(FACTOE(M))
     *                 *(FACTO1**(5.0D0/2.0D0))*(FACTO2**M)
     *                 *(3.0D0-(M*(GOGPAR)**2))/FACTOR(M)
     *                 *SQ4_PI
C
             GOGFF0(K)=SQ4_PI*SQRT(FACTOO(M))*SQRT(FACTOE(M))*
     *         (FACTO1**(1.0D0/2.0D0))*(FACTO2**M)/FACTOR(M)

             GOGFF2(K)=SQ4_PI*SQRT(FACTOO(M))*SQRT(FACTOE(M))*
     *         (FACTO1**(3.0D0/2.0D0))*(FACTO2**M)*
     *         (1.0D0-M*(GOGPAR**2))/FACTOR(M)
C
         END IF
C
      END DO
C
C=======================================================================
C          CALCULATING THE MOSHINSKI COFFICIENTS FOR S=0:
C
C          H_K^(0)(X) * H_L^(0)(Y)
C                  = SUM_S COFMOS(K,L,S) * H_S^(0)(U) * H_P^(0)(T)
C
C          FOR P=K+L-S, U=(X+Y)/SQ2, T=(X-Y)/SQ2
C
C=======================================================================
C          COEFFICIENTS ARE READY UP TO ORDER 6
C=======================================================================
C
      DO K=0,2*N_MAXX+6
         DO L=0,2*N_MAXX+6
C
            IF (MOD(K+L,2).EQ.0) THEN
C
                M=(K+L)/2
C
                IF (M.GT.NUFACR)   STOP ' M TOO LARGE IN DEF2BC (3)'
C
                FACTOM=FACTOE(M)*FACTOO(M)
C
            ELSE
C
                M=(K+L-1)/2
C
                IF (M+1.GT.NUFACR)   STOP ' M+1 TOO LARGE IN DEF2BC (3)'
C
                FACTOM=FACTOE(M)*FACTOO(M+1)
C
            END IF
C
            IF (K.GT.NUFACR)   STOP ' K TOO LARGE IN DEF2BC (3)'
            IF (L.GT.NUFACR)   STOP ' L TOO LARGE IN DEF2BC (3)'
C
            COFMOS(K,L)=(-1)**L*SQRT(FACTOM/(2.0D0)**(K+L)
     *                                             /FACTOR(K)/FACTOR(L))
C
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE MOSHINSKI COFFICIENTS FOR S=1:
C=======================================================================
C
      DO K=0,2*N_MAXX+7
         DO L=0,2*N_MAXX+7
C
            IF (MOD(K+L,2).EQ.0) THEN
C
                M=(K+L)/2
C
                IF (M.GT.NUFACR)   STOP ' M TOO LARGE IN DEF2BC (4A)'
C
                FACTOM=FACTOE(M-1)*FACTOO(M)
C
            ELSE
C
                M=(K+L-1)/2
C
                IF (M.GT.NUFACR)   STOP ' M TOO LARGE IN DEF2BC (4B)'
C
                FACTOM=FACTOE(M)*FACTOO(M)
C
            END IF
C
            IF (K.GT.NUFACR)   STOP ' K TOO LARGE IN DEF2BC (4)'
            IF (L.GT.NUFACR)   STOP ' L TOO LARGE IN DEF2BC (4)'
C
            COFMO1(K,L) = (-1)**L*(K-L)*SQRT(FACTOM/(2.0D0)**(K+L)
     *                    /FACTOR(K)/FACTOR(L))
C
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE FINAL MATRIX ELEMENTS
C=======================================================================
C          BELOW, ARRAYS "TBCN_M" ARE DIVIDED BY THE  FACTORS  HOMSCA
C          IN ORDER TO REMOVE THE DIMENSIONAL FACTORS INCLUDED IN THE
C          CALCULATED VALUES OF THE COEFFICINTS COEF00.  IN ADDITION,
C          TBCN_1 IS DIVIDED BY ANOTHER FACTOR HOMSCA, AND
C          TBCN_2 IS DIVIDED BY ANOTHER FACTOR HOMSCA**2, ECT.,
C          SO AS TO TAKE INTO ACCOUT THE DIMENSIONS OF  THE  POSITION
C          VARIABLE THAT MULTIPLY THE GAUSSIAN INTERACTION.
C=======================================================================
C
      DO N=0,N_MAXX
         DO M=0,N_MAXX
            DO NP=0,N_MAXX
               DO MP=0,N_MAXX
C
                  TBC0_0(NP,MP,N,M)=0.0D0
                  TBC0_1(NP,MP,N,M)=0.0D0
                  TBC0_2(NP,MP,N,M)=0.0D0
                  TBC0_3(NP,MP,N,M)=0.0D0
C
                  TBC1_0(NP,MP,N,M)=0.0D0
                  TBC1_1(NP,MP,N,M)=0.0D0
                  TBC1_2(NP,MP,N,M)=0.0D0
C
                  DO K=0,N+NP
                     DO L=0,M+MP
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            TBC0_0(NP,MP,N,M)=TBC0_0(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)
C
                            TBC0_2(NP,MP,N,M)=TBC0_2(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF2(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**3
C
                            TBC1_1(NP,MP,N,M)=TBC1_1(NP,MP,N,M)
     *                                       +COFMO1(K,L)*GOGFF1(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**3
C
                        ELSE
C
                            TBC0_1(NP,MP,N,M)=TBC0_1(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF1(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**2
C
                            TBC0_3(NP,MP,N,M)=TBC0_3(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF3(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**4
C
                            TBC1_0(NP,MP,N,M)=TBC1_0(NP,MP,N,M)
     *                                       +COFMO1(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**2
C
                            TBC1_2(NP,MP,N,M)=TBC1_2(NP,MP,N,M)
     *                                       +COFMO1(K,L)*GOGFF2(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)**4
C
                        END IF
C
                     END DO
                  END DO
C
                  TBC0_0(NP,MP,N,M)=SQ4_PI*TBC0_0(NP,MP,N,M)
                  TBC0_1(NP,MP,N,M)=SQ4_PI*TBC0_1(NP,MP,N,M)
                  TBC0_2(NP,MP,N,M)=SQ4_PI*TBC0_2(NP,MP,N,M)
                  TBC0_3(NP,MP,N,M)=SQ4_PI*TBC0_3(NP,MP,N,M)
C
                  TBC1_0(NP,MP,N,M)=SQ4_PI*TBC1_0(NP,MP,N,M)/2.0D0
                  TBC1_1(NP,MP,N,M)=SQ4_PI*TBC1_1(NP,MP,N,M)/2.0D0
                  TBC1_2(NP,MP,N,M)=SQ4_PI*TBC1_2(NP,MP,N,M)/2.0D0
C
C=======================================================================
C           ORDER 2
C=======================================================================
C           GAUT21 CONTAINS MATRIX ELEMENTS OF (K'*^2+K^2)/2
C           GAUT22 CONTAINS MATRIX ELEMENTS OF  K'* DOT K
C=======================================================================
C
                  GAUT21(NP,MP,N,M)=0.0D0
                  GAUT22(NP,MP,N,M)=0.0D0
C
                  DO K=0,N+NP+2
                     DO L=0,M+MP
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT21(NP,MP,N,M)=GAUT21(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-8)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-8)
C
                            GAUT22(NP,MP,N,M)=GAUT22(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/4
     *
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP
                     DO L=0,M+MP+2
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT21(NP,MP,N,M)=GAUT21(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-8)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-8)
C
                            GAUT22(NP,MP,N,M)=GAUT22(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/4
C
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+1
                     DO L=0,M+MP+1
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT21(NP,MP,N,M)=GAUT21(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/4
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/4
C
                            GAUT22(NP,MP,N,M)=GAUT22(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)
     *                                       /HOMSCA(KARTEZ,1)/(-4)
C
                        END IF
C
                     END DO
                  END DO
C
                  GAUT21(NP,MP,N,M)=SQ4_PI*GAUT21(NP,MP,N,M)
                  GAUT22(NP,MP,N,M)=SQ4_PI*GAUT22(NP,MP,N,M)
C
C=======================================================================
C           ORDER 4
C=======================================================================
C           GAUT41 CONTAINS MATRIX ELEMENTS OF [(K'*^2+K^2)/2]^2
C           GAUT42 CONTAINS MATRIX ELEMENTS OF [K'* DOT K](K'*^2+K^2)/2
C           GAUT43 CONTAINS MATRIX ELEMENTS OF [K'* DOT K]^2
C=======================================================================
C
                  GAUT41(NP,MP,N,M)=0.0D0
                  GAUT42(NP,MP,N,M)=0.0D0
                  GAUT43(NP,MP,N,M)=0.0D0
C
                  DO K=0,N+NP+4
                     DO L=0,M+MP
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF04(K,N,NP,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF22(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)*2
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF04(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF13(K,N,NP,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF13(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF22(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+3
                     DO L=0,M+MP+1
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF03(K,N,NP,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF03(K,NP,N,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-4)
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,N,NP,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-3)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF03(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-1)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,NP,N,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-3)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF03(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-1)
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)*(-2)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF12(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)*(-2)
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+2
                     DO L=0,M+MP+2
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)*6
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)*2
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)*8
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)*2
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)*6
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)*3
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)*3
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)*3
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)*3
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,NP,N,KARTEZ)
     *                                       *COEF11(L,MP,M,KARTEZ)*4
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+1
                     DO L=0,M+MP+3
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF03(L,M,MP,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF12(L,MP,M,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF12(L,M,MP,KARTEZ)*(-4)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF03(L,MP,M,KARTEZ)*(-4)
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF03(L,M,MP,KARTEZ)*(-1)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF12(L,M,MP,KARTEZ)*(-3)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF03(L,MP,M,KARTEZ)*(-1)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF12(L,MP,M,KARTEZ)*(-3)
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF12(L,M,MP,KARTEZ)*(-2)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF12(L,MP,M,KARTEZ)*(-2)
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP
                     DO L=0,M+MP+4
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF04(L,M,MP,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF22(L,MP,M,KARTEZ)*2
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF04(L,MP,M,KARTEZ)
C
                            GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF13(L,M,MP,KARTEZ)
     *
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF13(L,MP,M,KARTEZ)
C
                            GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF22(L,MP,M,KARTEZ)
                        END IF
C
                     END DO
                  END DO
C
                  GAUT41(NP,MP,N,M)=GAUT41(NP,MP,N,M)
     *                             *SQ4_PI/HOMSCA(KARTEZ,1)/64
                  GAUT42(NP,MP,N,M)=GAUT42(NP,MP,N,M)
     *                             *SQ4_PI/HOMSCA(KARTEZ,1)/(-32)
                  GAUT43(NP,MP,N,M)=GAUT43(NP,MP,N,M)
     *                             *SQ4_PI/HOMSCA(KARTEZ,1)/16
C
               END DO
            END DO
         END DO
      END DO
C
C=======================================================================
C          HERE THE CALCULATED MATRIX ELEMENTS ARE STORED
C=======================================================================
C
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 1)=TBC0_0(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 2)=TBC0_1(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 3)=TBC0_2(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 4)=TBC0_3(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 5)=TBC1_0(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 6)=TBC1_1(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 7)=TBC1_2(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 8)=GAUT41(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 9)=GAUT42(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE,10)=GAUT43(:,:,:,:)
C
C=======================================================================
C          HERE WE CALL THE SUBROUTINE "TESGOG", WHICH TESTS RESULTS
C          PRODUCED BY THIS SUBROUTINE. THE  CALL  IS  ACTIVATED  BY
C          SETTING I_TEST=1, 2, or 3 BELOW.
C=======================================================================
C
      I_TEST=0
      IF (I_TEST.NE.0) THEN
C
          IF (I_TEST.EQ.3)
     *                  STOP 'I_TEST.EQ.3 NOT YET IMPLEMENTED IN DEF2BC'
C
          DO I_KIND=0,1
C
C           CALL TES2BC(N_MAXX,NGAUSS,KARTEZ,
C    *                  GOGWID,GAUEL0,GAUEL1,
C    *                  GOGFF0,GOGFF1,
C    *                  COFMOS,COFMO1,
C    *                  GOGPAR,
C    *                  SQ2,
C    *                  I_KIND,I_TEST)
C
          END DO
C
C         STOP 'END OF TESTS IN DEF2BC'
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('DEF2BC',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFFST(N_MAXX,NGAUSS,KARTEZ,GOGWID,
     *                  FST_00,FST_01,FST_10,FST_02,FST_11,FST_20,
     *                                GAUT22,GAUT41,GAUT42,GAUT43)
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
C=======================================================================
      DIMENSION
     *          GOGFF0(0:4*NDOSCI+4),
     *          GOGFF1(0:4*NDOSCI+4),
     *          GOGFF2(0:4*NDOSCI+4)
      DIMENSION
     *          COFMOS(0:2*NDOSCI+6,0:2*NDOSCI+6)
      DIMENSION
     *          COFSCA(0:2*NDOSCI+1,0:2*NDOSCI+1)
      DIMENSION
     *          FST_00(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          FST_01(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          FST_10(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          FST_02(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          FST_11(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          FST_20(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          GAUT21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
C
      INTEGER,                              SAVE :: ND_STO
      INTEGER, DIMENSION(:),                SAVE :: I_DONE(NDKART)
      REAL,    DIMENSION(:,:), ALLOCATABLE, SAVE :: HOMSC1,GOGWI1
      REAL,    DIMENSION(:,:), ALLOCATABLE       :: HOMSC2,GOGWI2
      INTEGER, DIMENSION(:,:), ALLOCATABLE, SAVE :: N_MAX1,NGAUS1
      INTEGER, DIMENSION(:,:), ALLOCATABLE       :: N_MAX2,NGAUS2
      REAL,    DIMENSION(:,:,:,:,:,:,:), ALLOCATABLE, SAVE :: ELESTO
      REAL,    DIMENSION(:,:,:,:,:,:,:), ALLOCATABLE       :: ELESAV
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO3XYZ/ COEF12(0:ND2MAX+1,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF03(0:ND2MAX+1,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /CO4XYZ/ COEF22(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF13(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF04(0:ND2MAX+2,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /MUFACR/ NUFACR
C
      DATA   I_DONE   /0,0,0/
C
C=======================================================================
C
      CALL CPUTIM('DEFFST',1)
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES  THE  HARMONIC-OSCILLATOR  MATRIX
C        ELEMENTS OF THE TWO-BODY GAUSSIAN INTERACTION IN ONE DIMENSION
C        TO BE USED FOR THE FINITE-RANGE SPIN-ORBIT AND TENSOR TERMS.
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN DEFFST'
C
      IF (.NOT.ALLOCATED(ELESTO)) THEN
C
          ND_STO=1
C
          ALLOCATE (ELESTO(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_STO,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESTO','DEFFST')
C
          ALLOCATE (HOMSC1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC1','DEFFST')
C
          ALLOCATE (GOGWI1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI1','DEFFST')
C
          ALLOCATE (N_MAX1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX1','DEFFST')
C
          ALLOCATE (NGAUS1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS1','DEFFST')
C
      END IF
C
C=======================================================================
C        IF CALCULATIONS HAVE AREADY BEEN DONE, THEY ARE NOT REPEATED
C=======================================================================
C
      DO I_STOE=1,I_DONE(KARTEZ)
C
         ICHECK=1
C
         IF (HOMSCA(KARTEZ,1).NE.HOMSC1(KARTEZ,I_STOE)) ICHECK=0
         IF (GOGWID          .NE.GOGWI1(KARTEZ,I_STOE)) ICHECK=0
         IF (N_MAXX          .NE.N_MAX1(KARTEZ,I_STOE)) ICHECK=0
         IF (NGAUSS          .NE.NGAUS1(KARTEZ,I_STOE)) ICHECK=0
C
         IF (ICHECK.EQ.1) THEN
C
             IF (10.GT.NDNUME) STOP 'INCREASE NDNUME IN DEFFST'
C
             FST_00(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 1)
             FST_01(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 2)
             FST_10(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 3)
             FST_02(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 4)
             FST_11(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 5)
             FST_20(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 6)
             GAUT22(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 7)
             GAUT41(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 8)
             GAUT42(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE, 9)
             GAUT43(:,:,:,:)=ELESTO(:,:,:,:,KARTEZ,I_STOE,10)
C
             CALL CPUTIM('DEFFST',0)
             RETURN
C
         END IF
C
      END DO
C
      IF (I_DONE(KARTEZ).GE.ND_STO) THEN
C
C=======================================================================
C        HERE WE EXTEND THE ALLOCATION OF ARRAYS BY ONE AND COPY ALREADY
C        SAVED INFO INTO THE EXTENDED ARRAYS
C=======================================================================
C
          ND_SAV=ND_STO
C
          ALLOCATE (ELESAV(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_SAV,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESAV','DEFFST')
C
          ALLOCATE (HOMSC2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC2','DEFFST')
C
          ALLOCATE (GOGWI2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI2','DEFFST')
C
          ALLOCATE (N_MAX2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX2','DEFFST')
C
          ALLOCATE (NGAUS2(NDKART,ND_SAV),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS2','DEFFST')
C
          ELESAV=ELESTO
          HOMSC2=HOMSC1
          GOGWI2=GOGWI1
          N_MAX2=N_MAX1
          NGAUS2=NGAUS1
C
          DEALLOCATE (ELESTO)
          DEALLOCATE (HOMSC1)
          DEALLOCATE (GOGWI1)
          DEALLOCATE (N_MAX1)
          DEALLOCATE (NGAUS1)
C
          ND_STO=ND_STO+1
C
          ALLOCATE (ELESTO(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                       NDKART,ND_STO,NDNUME),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('ELESTO','DEFFST')
C
          ALLOCATE (HOMSC1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HOMSC1','DEFFST')
C
          ALLOCATE (GOGWI1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('GOGWI1','DEFFST')
C
          ALLOCATE (N_MAX1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('N_MAX1','DEFFST')
C
          ALLOCATE (NGAUS1(NDKART,ND_STO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('NGAUS1','DEFFST')
C
          ELESTO(:,:,:,:,:,1:ND_SAV,:)=ELESAV(:,:,:,:,:,1:ND_SAV,:)
          HOMSC1(        :,1:ND_SAV  )=HOMSC2(        :,1:ND_SAV  )
          GOGWI1(        :,1:ND_SAV  )=GOGWI2(        :,1:ND_SAV  )
          N_MAX1(        :,1:ND_SAV  )=N_MAX2(        :,1:ND_SAV  )
          NGAUS1(        :,1:ND_SAV  )=NGAUS2(        :,1:ND_SAV  )
C
          DEALLOCATE (ELESAV)
          DEALLOCATE (HOMSC2)
          DEALLOCATE (GOGWI2)
          DEALLOCATE (N_MAX2)
          DEALLOCATE (NGAUS2)
C
      END IF
C
      I_DONE(KARTEZ)=I_DONE(KARTEZ)+1
C
      J_STOE=I_DONE(KARTEZ)
C
      HOMSC1(KARTEZ,J_STOE)=HOMSCA(KARTEZ,1)
      GOGWI1(KARTEZ,J_STOE)=GOGWID
      N_MAX1(KARTEZ,J_STOE)=N_MAXX
      NGAUS1(KARTEZ,J_STOE)=NGAUSS
C
C=======================================================================
C
      SQ2=SQRT(2.0D0)
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
C=======================================================================
C          CALCULATING THE FORM FACTORS OF THE GAUSSIAN INTERACTION WITH
C          RESPECT TO THE I-TH-ORDER DERIVATIVE OF THE K-TH HERMITE
C          POLYNOMIAL H_K^(I):
C
C                GOGFFI= INT DT EXP(-T^2)  H_K^(I)(T)
C                               * EXP[-2*T^2/(B*GOGWID)^2]
C
C          FOR I=0
C=======================================================================
C
      GOGPAR=HOMSCA(KARTEZ,1)*GOGWID
      FACTO1=GOGPAR**2/(2+GOGPAR**2)
      FACTO2=       -1/(2+GOGPAR**2)
C
      DO K=0,4*N_MAXX+4
C
         GOGFF0(K)= 0.0D0
C
         IF (MOD(K,2).EQ.0) THEN
C
             M=K/2
C
             IF (M.GT.NUFACR)   STOP ' M TOO LARGE IN DEFFST (1)'
C
             GOGFF0(K)= FACTO1**(1.0D0/2.0D0)*FACTO2**M
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
     *                 *SQ4_PI
C
         END IF
C
      END DO
C
C=======================================================================
C          CALCULATING THE SCALED HERMITE POLYNOMIALS CEFFICIENTS:
C
C          H_K^(0)(T/SQ2) = SUM_L COFSCA(K,L) H_L^(0)(T)
C=======================================================================
C
      DO K=0,2*N_MAXX+1
         DO L=0,K
C
            M=K-L
C
            IF (MOD(M,2).EQ.0) THEN
C
C
                IF (K.GT.NUFACR)   STOP ' K TOO LARGE IN DEFFST (2)'
                IF (L.GT.NUFACR)   STOP ' L TOO LARGE IN DEFFST (2)'
                IF (M/2.GT.NUFACR) STOP ' M/2 TOO LARGE IN DEFFST (2)'
C
                COFSCA(K,L)=SQRT(FACTOR(K)/FACTOR(L))
     *                     *(-1)**(M/2)/FACTOR(M/2)/SQ2**L/2.0D0**M
            ELSE
                COFSCA(K,L)=0.0D0
            END IF
C
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE MOSHINSKI COFFICIENTS FOR S=0:
C
C          H_K^(0)(X) * H_L^(0)(Y)
C                  = SUM_S COFMOS(K,L) * H_S^(0)(U) * H_P^(0)(T)
C
C          FOR P=K+L-S, U=(X+Y)/SQ2, T=(X-Y)/SQ2
C
C=======================================================================
C          COEFFICIENTS ARE READY UP TO ORDER 6
C=======================================================================
C
      DO K=0,2*N_MAXX+6
         DO L=0,2*N_MAXX+6
C
            IF (MOD(K+L,2).EQ.0) THEN
C
                M=(K+L)/2
C
                IF (M.GT.NUFACR)   STOP ' M TOO LARGE IN DEFFST (3)'
C
                FACTOM=FACTOE(M)*FACTOO(M)
C
            ELSE
C
                M=(K+L-1)/2
C
                IF (M+1.GT.NUFACR)   STOP ' M+1 TOO LARGE IN DEFFST (3)'
C
                FACTOM=FACTOE(M)*FACTOO(M+1)
C
            END IF
C
            IF (K.GT.NUFACR)   STOP ' K TOO LARGE IN DEFFST (3)'
            IF (L.GT.NUFACR)   STOP ' L TOO LARGE IN DEFFST (3)'
C
            COFMOS(K,L)=(-1)**L*SQRT(FACTOM/(2.0D0)**(K+L)
     *                                             /FACTOR(K)/FACTOR(L))
C
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE FINAL MATRIX ELEMENTS
C=======================================================================
C          BELOW, ARRAYS "FST__M" ARE DIVIDED BY THE  FACTORS  HOMSCA
C          IN ORDER TO REMOVE THE DIMENSIONAL FACTORS INCLUDED IN THE
C          CALCULATED VALUES OF THE COEFFICINTS COEF00.  IN ADDITION,
C          FST__1 IS DIVIDED BY ANOTHER FACTOR HOMSCA, AND
C          FST__2 IS DIVIDED BY ANOTHER FACTOR HOMSCA**2, ECT.,
C          SO AS TO TAKE INTO ACCOUT THE DIMENSIONS OF  THE  POSITION
C          VARIABLE THAT MULTIPLY THE GAUSSIAN INTERACTION.
C=======================================================================
C
      DO N=0,N_MAXX
         DO M=0,N_MAXX
            DO NP=0,N_MAXX
               DO MP=0,N_MAXX
C
                  FST_00(NP,MP,N,M)=0.0D0
                  FST_01(NP,MP,N,M)=0.0D0
                  FST_10(NP,MP,N,M)=0.0D0
                  FST_02(NP,MP,N,M)=0.0D0
                  FST_11(NP,MP,N,M)=0.0D0
                  FST_20(NP,MP,N,M)=0.0D0
C
                  DO K=0,N+NP
                     DO L=0,M+MP
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            FST_00(NP,MP,N,M)=FST_00(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)
C
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+1
                     DO L=0,M+MP
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            FST_01(NP,MP,N,M)=FST_01(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)/2
C
                            FST_10(NP,MP,N,M)=FST_10(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)/2
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP
                     DO L=0,M+MP+1
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            FST_01(NP,MP,N,M)=FST_01(NP,MP,N,M)
     *                                       -COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)/2
C
                            FST_10(NP,MP,N,M)=FST_10(NP,MP,N,M)
     *                                       -COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)/2
C
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+2
                     DO L=0,M+MP
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            FST_02(NP,MP,N,M)=FST_02(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,NP,N,KARTEZ)
     *                                       *COEF00(L,MP,M,KARTEZ)/4
C
                            FST_11(NP,MP,N,M)=FST_11(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF11(K,N,NP,KARTEZ)
     *                                       *COEF00(L,M,MP,KARTEZ)/4
C
                            FST_20(NP,MP,N,M)=FST_20(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF02(K,N,NP,KARTEZ)
     *                                       *COEF00(L,M,MP,KARTEZ)/4
C
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP+1
                     DO L=0,M+MP+1
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            FST_02(NP,MP,N,M)=FST_02(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)/(-2)
C
                            FST_11(NP,MP,N,M)=FST_11(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF01(L,MP,M,KARTEZ)/(-4)
C
                            FST_11(NP,MP,N,M)=FST_11(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,NP,N,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)/(-4)
C
                            FST_20(NP,MP,N,M)=FST_20(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF01(K,N,NP,KARTEZ)
     *                                       *COEF01(L,M,MP,KARTEZ)/(-2)
C
                        END IF
C
                     END DO
                  END DO
C
                  DO K=0,N+NP
                     DO L=0,M+MP+2
C
                        IF (MOD(K+L,2).EQ.0) THEN
C
                            FST_02(NP,MP,N,M)=FST_02(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,NP,N,KARTEZ)
     *                                       *COEF02(L,MP,M,KARTEZ)/4
C
                            FST_11(NP,MP,N,M)=FST_11(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,N,NP,KARTEZ)
     *                                       *COEF11(L,M,MP,KARTEZ)/4
C
                            FST_20(NP,MP,N,M)=FST_20(NP,MP,N,M)
     *                                       +COFMOS(K,L)*GOGFF0(K+L)
     *                                       *COEF00(K,N,NP,KARTEZ)
     *                                       *COEF02(L,M,MP,KARTEZ)/4
C
                        END IF
C
                     END DO
                  END DO
C
                  FST_00(NP,MP,N,M)=SQ4_PI*FST_00(NP,MP,N,M)
     *                                                 /HOMSCA(KARTEZ,1)
                  FST_01(NP,MP,N,M)=SQ4_PI*FST_01(NP,MP,N,M)
     *                                                 /HOMSCA(KARTEZ,1)
                  FST_10(NP,MP,N,M)=SQ4_PI*FST_10(NP,MP,N,M)
     *                                                 /HOMSCA(KARTEZ,1)
                  FST_02(NP,MP,N,M)=SQ4_PI*FST_02(NP,MP,N,M)
     *                                                 /HOMSCA(KARTEZ,1)
                  FST_11(NP,MP,N,M)=SQ4_PI*FST_11(NP,MP,N,M)
     *                                                 /HOMSCA(KARTEZ,1)
                  FST_20(NP,MP,N,M)=SQ4_PI*FST_20(NP,MP,N,M)
     *                                                 /HOMSCA(KARTEZ,1)
C
               END DO
            END DO
         END DO
      END DO
C
C=======================================================================
C           ORDER 2
C=======================================================================
C           GAUT21 CONTAINS MATRIX ELEMENTS OF (K'*^2+K^2)/2
C           GAUT22 CONTAINS MATRIX ELEMENTS OF  K'* DOT K
C=======================================================================
C
                  GAUT21(NP,MP,N,M)=0.0D0
                  GAUT22(NP,MP,N,M)=0.0D0
C
C=======================================================================
C           ORDER 4
C=======================================================================
C           GAUT41 CONTAINS MATRIX ELEMENTS OF [(K'*^2+K^2)/2]^2
C           GAUT42 CONTAINS MATRIX ELEMENTS OF [K'* DOT K](K'*^2+K^2)/2
C           GAUT43 CONTAINS MATRIX ELEMENTS OF [K'* DOT K]^2
C=======================================================================
C
                  GAUT41(NP,MP,N,M)=0.0D0
                  GAUT42(NP,MP,N,M)=0.0D0
                  GAUT43(NP,MP,N,M)=0.0D0
C
C=======================================================================
C          HERE THE CALCULATED MATRIX ELEMENTS ARE STORED
C=======================================================================
C
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 1)=FST_00(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 2)=FST_01(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 3)=FST_10(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 4)=FST_02(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 5)=FST_11(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 6)=FST_20(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 7)=GAUT22(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 8)=GAUT41(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE, 9)=GAUT42(:,:,:,:)
      ELESTO(:,:,:,:,KARTEZ,J_STOE,10)=GAUT43(:,:,:,:)
C
C=======================================================================
C          HERE WE CALL THE SUBROUTINE "TESGOG", WHICH TESTS RESULTS
C          PRODUCED BY THIS SUBROUTINE. THE  CALL  IS  ACTIVATED  BY
C          SETTING I_TEST=1, 2, or 3 BELOW.
C=======================================================================
C
      I_TEST=0
      IF (I_TEST.NE.0) THEN
C
          IF (I_TEST.EQ.3)
     *                  STOP 'I_TEST.EQ.3 NOT YET IMPLEMENTED IN DEFFST'
C
          DO I_KIND=0,1
C
C           CALL TESGOG(N_MAXX,NGAUSS,KARTEZ,
C    *                  GOGWID,GAUEL0,GAUEL1,
C    *                  GOGFF0,GOGFF1,
C    *                  COFMOS,COFSCA,
C    *                  GOGPAR,
C    *                  SQ2,
C    *                  I_KIND,I_TEST)
C
          END DO
C
C         STOP 'END OF TESTS IN DEFFST'
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('DEFFST',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFDIQ(N_MAXX,GAUEL0,GA_EIG,GA_VEC,GA_VEI,
     *                                KNDDIQ,LNDDIQ,NNDDIQ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      PARAMETER (NDOSC2=(NDOSCI+1)*(NDOSCI+1))
C=======================================================================
C
      COMPLEX
     *          GA_VEC,GA_VEI,GA_TMP,CELMTS,GAUAUY
C
      DIMENSION
     *          GAUAUX(NDOSC2,NDOSC2),GAUAUY(NDOSC2,NDOSC2)
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          GA_VEC(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GA_TMP(NDOSC2,0:NDOSCI,0:NDOSCI),
     *          GA_VEI(NDOSC2,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          GA_EIG(NDOSC2),
     *          GA_COP(NDOSC2)
      DIMENSION
     *          IA_ORD(NDOSC2)
      DIMENSION
     *          CELMTS(1:((NDOSC2+1)*NDOSC2)/2)
      DIMENSION
     *          KNDDIQ(0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          LNDDIQ(NDOSC2,2)
C
C=======================================================================
C
      CALL CPUTIM('DEFDIQ',1)
C
C=======================================================================
C     THIS SUBROUTINE DIAGONALIZES GAUSSIAN FORMFACTORS
C=======================================================================
C
C=======================================================================
C     BUILDING POINTERS THAT HANDLE GROUPED INDICES
C=======================================================================
C
      INDDIQ=0
      DO NP=0,N_MAXX
         DO N=0,N_MAXX
C
            INDDIQ=INDDIQ+1
C
            KNDDIQ(NP,N)=INDDIQ
            LNDDIQ(INDDIQ,1)=NP
            LNDDIQ(INDDIQ,2)=N
C
        END DO
      END DO
C
      NNDDIQ=INDDIQ
C
C=======================================================================
C     GROUPING THE PAIRS OF THE HARMONIC-OSCILLATOR INDICES
C=======================================================================
C
      DO NP=0,N_MAXX
         DO N=0,N_MAXX
C
            DO MP=0,N_MAXX
               DO M=0,N_MAXX
C
                  GAUAUX(KNDDIQ(NP,N),KNDDIQ(MP,M))=GAUEL0(NP,MP,N,M)
C
C                  PRINT *, GAUEL0(NP,MP,N,M), NP, MP, N, M
C
               END DO
            END DO
C
        END DO
      END DO
C
C
C=======================================================================
C     COLLECTING THE LOWER TRIANGLE INTO A LINEAR ARRAY
C=======================================================================
C
      NCOUNT=0
C
      DO JNDDIQ=1,NNDDIQ
         DO INDDIQ=JNDDIQ,NNDDIQ
C
            NCOUNT=NCOUNT+1
C
            CELMTS(NCOUNT)=GAUAUX(INDDIQ,JNDDIQ)
C
C            PRINT *, CELMTS(NCOUNT), NCOUNT
C
         END DO
      END DO
C
C
C      PRINT *, CELMTS(NCOUNT/2 + 1), CELMTS(1)
C
C=======================================================================
C     DIAGONALIZING THE ARRAY WITH REGROUPED INDICES
C=======================================================================
C
      CALL DIAMAT(CELMTS,GA_EIG,GAUAUY,NNDDIQ,NDOSC2,NNDDIQ)
C
C=======================================================================
C     REVERTING THE GROUPED INDICES INTO THE PAIR OF THE HO INDICES
C=======================================================================
C
      DO NP=0,N_MAXX
         DO N=0,N_MAXX
C
            DO JNDDIQ=1,NNDDIQ
C
               GA_VEC(JNDDIQ,NP,N)=GAUAUY(KNDDIQ(NP,N),JNDDIQ)
C
               GA_VEI(JNDDIQ,NP,N)=GAUAUY(KNDDIQ(NP,N),JNDDIQ)*
     *                                          GA_EIG(JNDDIQ)
C
C            PRINT *, GA_VEI(JNDDIQ,NP,N), GA_VEC(JNDDIQ,NP,N)
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C     SORTING THE EIGENVALUES IN CRESCENT ABSOLUTE VALUE
C=======================================================================
C
      GA_COP=ABS(GA_EIG)
C
      IORDER=0
C
      DO JNDDIQ=1,NNDDIQ
         IORDER=IORDER+1
         IA_ORD(IORDER)=IORDER
      END DO
C
      CALL ORDER1(GA_COP,IA_ORD,IORDER)
C
      GA_COP=GA_EIG
      GA_TMP=GA_VEC
C
      DO NP=0,N_MAXX
         DO N=0,N_MAXX
C
            DO JNDDIQ=1,NNDDIQ
C
C--------------INDEX TO INVERT THE ARRAY INTO DECRESCENT ORDER
               INVDIQ=NNDDIQ-JNDDIQ+1
C
               GA_EIG(INVDIQ)=GA_COP(IA_ORD(JNDDIQ))
C
               GA_VEC(INVDIQ,NP,N)=GA_TMP(IA_ORD(JNDDIQ),NP,N)
C
               GA_VEI(INVDIQ,NP,N)=GA_TMP(IA_ORD(JNDDIQ),NP,N)*
     *                             GA_COP(IA_ORD(JNDDIQ))
C
C            PRINT *, GA_VEI(JNDDIQ,NP,N), GA_VEC(JNDDIQ,NP,N)
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('DEFDIQ',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFSEP(N_MAXX,NGAUSS,KARTEZ,ILEFGA,IRIGGA,
     *                  GAUEL0,GAUEL1,GAUEL2,GAUEL4,GAUEL6,
     *                                       GAUT21,GAUT22,
     *                                GAUT41,GAUT42,GAUT43)
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
C=======================================================================
C
      DIMENSION
     *          SEPFL0(0:4*NDOSCI+4),SEPFR0(0:4*NDOSCI+4)
      DIMENSION
     *          COFMOT(0:2*NDOSCI+6,0:2*NDOSCI+6,0:2*NDOSCI+6)
      DIMENSION
     *          GAMOL0(0:2*NDOSCI+6,0:2*NDOSCI+6,0:2*NDOSCI+6),
     *          GAMOR0(0:2*NDOSCI+6,0:2*NDOSCI+6,0:2*NDOSCI+6)
      DIMENSION
     *          SAVEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI,
     *                                NDKART,NDSEGA,NDSEGA)
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          HOMSCA_(NDKART,NDSEGA,NDSEGA),
     *          SEPWIL_(NDKART,NDSEGA,NDSEGA),
     *          SEPWIR_(NDKART,NDSEGA,NDSEGA),
     *          N_MAXX_(NDKART,NDSEGA,NDSEGA),
     *          NGAUSS_(NDKART,NDSEGA,NDSEGA)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /SEPPAR/ SEPWID(NDSEGA),SEPGAU(NDSEGA),NUSEGA
      COMMON
     *       /MUFACR/ NUFACR
      COMMON
     *       /SEPDON/ ISEPDO(NDKART,NDSEGA,NDSEGA)
C
C=======================================================================
C
      CALL CPUTIM('DEFSEP',1)
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES  THE  HARMONIC-OSCILLATOR  MATRIX
C        ELEMENTS OF THE TWO-BODY SEPARABLE GAUSSIAN INTERACTION IN ONE
C        DIMENSION SEE NOTES NO. 96.
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN DEFSEP'
C
      IF (ILEFGA.LT.1.OR.ILEFGA.GT.NUSEGA) STOP 'ILEFGA IN DEFSEP'
      IF (IRIGGA.LT.1.OR.IRIGGA.GT.NUSEGA) STOP 'IRIGGA IN DEFSEP'
C
C=======================================================================
C        IF CALCULATIONS HAVE AREADY BEEN DONE, THEY ARE NOT REPEATED
C=======================================================================
C
C     write (*,*) KARTEZ,ILEFGA,IRIGGA,ISEPDO(KARTEZ,ILEFGA,IRIGGA)
C
      ISEPDO(KARTEZ,ILEFGA,IRIGGA)=0
      IF (ISEPDO(KARTEZ,ILEFGA,IRIGGA).EQ.1) THEN
C
         ICHECK=1
C
         IF (HOMSCA(KARTEZ,1).NE.HOMSCA_(KARTEZ,ILEFGA,IRIGGA)) ICHECK=0
         IF (SEPWID(ILEFGA).NE.SEPWIL_(KARTEZ,ILEFGA,IRIGGA))   ICHECK=0
         IF (SEPWID(IRIGGA).NE.SEPWIR_(KARTEZ,IRIGGA,IRIGGA))   ICHECK=0
         IF (N_MAXX        .NE.N_MAXX_(KARTEZ,ILEFGA,IRIGGA))   ICHECK=0
         IF (NGAUSS        .NE.NGAUSS_(KARTEZ,ILEFGA,IRIGGA))   ICHECK=0
C
C         write (*,*) ICHECK
C
          IF (ICHECK.EQ.1) THEN
C
              GAUEL0(:,:,:,:)=SAVEL0(:,:,:,:,KARTEZ,ILEFGA,IRIGGA)
C
              CALL CPUTIM('DEFSEP',0)
              RETURN
C
          END IF
C
      END IF
C
      HOMSCA_(KARTEZ,ILEFGA,IRIGGA)=HOMSCA(KARTEZ,1)
      SEPWIL_(KARTEZ,ILEFGA,IRIGGA)=SEPWID(ILEFGA)
      SEPWIR_(KARTEZ,IRIGGA,IRIGGA)=SEPWID(IRIGGA)
      N_MAXX_(KARTEZ,ILEFGA,IRIGGA)=N_MAXX
      NGAUSS_(KARTEZ,ILEFGA,IRIGGA)=NGAUSS
C
      ISEPDO(KARTEZ,ILEFGA,IRIGGA)=1
C
C=======================================================================
C
      SQ2=SQRT(2.0D0)
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
      SQ4_8=SQRT(SQRT(8.0D0))
C
C=======================================================================
C          CALCULATING THE FORM FACTORS OF THE GAUSSIAN INTERACTION WITH
C          RESPECT TO THE K-TH HERMITE POLYNOMIAL H_K^(0):
C
C          SEPFGI= INT DT EXP(-T^2) (T*SQ2)^I H_K^(0)(T)
C                               * EXP[-2*T^2/(B*SEPWID)^2]
C
C          FOR I=0 AND FOR LEFT (G=L) AND RIGHT (G=R) GAUSSIAN
C=======================================================================
C          LEFT GAUSSIAN
C=======================================================================
C
      SEPCON=HOMSCA(KARTEZ,1)*SEPWID(ILEFGA)
      FACTO1=SEPCON**2/(2+SEPCON**2)
      FACTO2=       -1/(2+SEPCON**2)
      FACTO3=HOMSCA(KARTEZ,1)/(4+SEPCON**2)
      FACTO4=(SEPCON**2-4)/(2*SEPCON**2+8)
C
      DO K=0,4*N_MAXX+4
C
C=======================================================================
C          I=EVEN
C=======================================================================
C
         IF (MOD(K,2).EQ.0) THEN
C
             M=K/2
C
             IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFSEP'
C
             SEPFL0(K)=SQ4_8*FACTO3**(1.0D0/2.0D0)*FACTO4**M/SQ4_PI
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
C
         ELSE
C
             SEPFL0(K)=0.0D0
C
         END IF
C
      END DO
C
C=======================================================================
C          RIGHT GAUSSIAN
C=======================================================================
C
      SEPCON=HOMSCA(KARTEZ,1)*SEPWID(IRIGGA)
      FACTO1=SEPCON**2/(2+SEPCON**2)
      FACTO2=       -1/(2+SEPCON**2)
      FACTO3=HOMSCA(KARTEZ,1)/(4+SEPCON**2)
      FACTO4=(SEPCON**2-4)/(2*SEPCON**2+8)
C
      DO K=0,4*N_MAXX+4
C
C=======================================================================
C          I=EVEN
C=======================================================================
C
         IF (MOD(K,2).EQ.0) THEN
C
             M=K/2
C
             IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFSEP'
C
             SEPFR0(K)=SQ4_8*FACTO3**(1.0D0/2.0D0)*FACTO4**M/SQ4_PI
     *                 *SQRT(FACTOO(M))*SQRT(FACTOE(M))/FACTOR(M)
C
         ELSE
C
             SEPFR0(K)=0.0D0
C
         END IF
C
      END DO
C
C=======================================================================
C          CALCULATING THE MOSHINSKI COFFICIENTS FOR ALL VALUES OF S:
C
C          H_K^(0)(X) * H_L^(0)(Y)
C                  = SUM_N COFMOT(N,K,L) * H_S^(0)(U) * H_N^(0)(T)
C
C          FOR N=K+L-S, U=(X+Y)/SQ2, T=(X-Y)/SQ2
C
C=======================================================================
C          COEFFICIENTS ARE READY UP TO ORDER 6
C=======================================================================
C
      COFMOT=0.0D0
C
      DO K=0,2*N_MAXX+6
         DO L=0,2*N_MAXX+6
            DO N=0,K+L
C
               IF (MOD(K+L-N,2).EQ.0) THEN
C
                   M=(K+L-N)/2
C
                   IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFSEP (2)'
C
                   FACTOM=FACTOE(M)*FACTOO(M)
C
               ELSE
C
                   M=(K+L-N-1)/2
C
                   IF (M+1.GT.NUFACR)STOP ' M+1 TOO LARGE IN DEFSEP (3)'
C
                   FACTOM=FACTOE(M)*FACTOO(M+1)
C
               END IF
C
               IF (MOD(N,2).EQ.0) THEN
C
                   M=(N)/2
C
                   IF (M.GT.NUFACR) STOP ' M TOO LARGE IN DEFSEP (4)'
C
                   FACTON=FACTOE(M)*FACTOO(M)
C
               ELSE
C
                   M=(N-1)/2
C
                   IF (M+1.GT.NUFACR)STOP ' M+1 TOO LARGE IN DEFSEP (4)'
C
                   FACTON=FACTOE(M)*FACTOO(M+1)
C
               END IF
C
               IF (K.GT.NUFACR) STOP ' K TOO LARGE IN DEFSEP (2)'
               IF (L.GT.NUFACR) STOP ' L TOO LARGE IN DEFSEP (2)'
C
               FACTOT=SQRT(FACTOM*FACTON)*SQRT(FACTOR(K)*FACTOR(L)
     *                                            /(2.0D0)**(K+L))
C
               DO I=MAX(0,N-L),MIN(N,K)
C
                  IF (I.GT.NUFACR)     STOP ' I TOO LARGE IN DEFSEP'
                  IF (N-I.GT.NUFACR)   STOP ' N-I TOO LARGE IN DEFSEP'
                  IF (K-I.GT.NUFACR)   STOP ' K-I TOO LARGE IN DEFSEP'
                  IF (L-N+I.GT.NUFACR) STOP ' L-N+I TOO LARGE IN DEFSEP'
C
                  COFMOT(N,K,L)=COFMOT(N,K,L)+FACTOT*(-1)**(L-N+I)
     *                                      /(FACTOR(I)*FACTOR(N-I))
     *                                      /(FACTOR(K-I)*FACTOR(L-N+I))
C
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE AUXILIARY MATRIX ELEMENTS
C=======================================================================
C
      GAMOL0=0.0D0
      GAMOR0=0.0D0
C
      DO N=0,N_MAXX
         DO NP=0,N_MAXX
            DO NN=0,N+NP
C
               LL=N+NP-NN
C
               GAMOL0(NN,N,NP)=COFMOT(NN,NP,N)*SEPFL0(LL)
               GAMOR0(NN,N,NP)=COFMOT(NN,NP,N)*SEPFR0(LL)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C          CALCULATING THE FINAL MATRIX ELEMENTS
C=======================================================================
C
      GAUEL0=0.0D0
      GAUEL1=0.0D0
      GAUEL2=0.0D0
      GAUEL4=0.0D0
      GAUEL6=0.0D0
      GAUT21=0.0D0
      GAUT22=0.0D0
      GAUT41=0.0D0
      GAUT42=0.0D0
      GAUT43=0.0D0
C
      DO N=0,N_MAXX
         DO NP=0,N_MAXX
            DO M=0,N_MAXX
               DO MP=0,N_MAXX
C
                  DO NN=0,MIN(NP+MP,N+M)
C
                     GAUEL0(NP,MP,N,M)=GAUEL0(NP,MP,N,M)
     *                                +GAMOL0(NN,NP,MP)*GAMOR0(NN,N,M)
C
                  END DO
C
               END DO
            END DO
         END DO
      END DO
C
      SAVEL0(:,:,:,:,KARTEZ,ILEFGA,IRIGGA)=GAUEL0(:,:,:,:)
C
C=======================================================================
C          HERE WE CALL THE SUBROUTINE "TESSEP", WHICH TESTS RESULTS
C          PRODUCED BY THIS SUBROUTINE. THE  CALL  IS  ACTIVATED  BY
C          SETTING I_TEST=1, 2, or 3 BELOW.
C=======================================================================
C
      I_TEST=0
      IF (I_TEST.NE.0) THEN
C
          STOP ' TESSEP NOT READY IN DEFSEP'
C
          DO I_KIND=0,1
C
C           CALL TESSEP(N_MAXX,NDOSCI,NGAUSS,KARTEZ,
C    *                  SEPWID,GAUEL0,GAUEL1,
C    *                  SEPFF0,SEPFF1,
C    *                  COFMOS,COFSCA,
C    *                  SEPCON,
C    *                  SQ2,
C    *                  I_KIND,I_TEST)
C
          END DO
C
C         STOP 'END OF TESTS IN DEFSEP'
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('DEFSEP',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TESGOG(N_MAXX,NGAUSS,KARTEZ,
     *                  GOGWID,GAUEL0,GAUEL1,
     *                  GOGFF0,GOGFF1,
     *                  COFMOS,COFSCA,
     *                  GOGPAR,
     *                  SQ2,
     *                  I_KIND,I_TEST)
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
      REAL*16
     *          COFMOS,GOGFF0,GOGFF1,GOGPAR,HERFAQ,XPOINT,PHERMI,DHERMI
      REAL*16
     *          RESULT,STEP
      REAL*16
     *          GAUEL0,GAUEL1
      REAL*16
     *          RESULN
      REAL*16
     *          FSIMPS,HERMIS,HELPIJ,HELP_I,HELP_J,HELPAJ
C=======================================================================
      DIMENSION
     *          GOGFF0(0:4*NDOSCI+4),
     *          GOGFF1(0:4*NDOSCI+4)
      DIMENSION
     *          COFMOS(0:2*NDOSCI+6,0:2*NDOSCI+6)
      DIMENSION
     *          COFSCA(0:2*NDOSCI+1,0:2*NDOSCI+1)
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          PHERMI(4*NDOSCI+1),DHERMI(4*NDOSCI+1)
      DIMENSION
     *          HERFAC(0:4*NDOSCI),RESULN(0:4*NDOSCI)
      DIMENSION
     *          HERFAQ(0:4*NDOSCI)
C
      ALLOCATABLE FSIMPS(:)
      ALLOCATABLE HERMIS(:,:)
      ALLOCATABLE HELPIJ(:,:)
      ALLOCATABLE HELP_I(:,:,:)
      ALLOCATABLE HELP_J(:,:,:)
      ALLOCATABLE HELPAJ(:,:,:)
C
      COMMON
     *       /COEFMO/ COEMOS(0:ND0MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /HERMEM/ HERONE(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /INTMEM/ TWOWGT(1:NDGAUS,1:NDKART),
     *                TWOPNT(1:NDGAUS,1:NDKART)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /MUFACR/ NUFACR
      COMMON
     *       /INTCHE/ RANGX,NPOINT
C
C=======================================================================
C
      CALL CPUTIM('TESGOG',1)
C
C=======================================================================
C        THIS SUBROUTINE TESTS RESULTS PRODUCED BY SUBROUTINE "DEFGOG"
C        FOR I_KIND=0 OR 1 THE MATRIX ELEMENTS ARE TESTED FOR I=0 OR 1
C        FOR I_TEST=1 OR 2,3 LESS OR OR MORE OUTPUT IS PRINTED
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN TESGOG'
C
      PRINT '(/'' TESTS IN TESGOG FOR N_MAXX='',I3,'' NGAUSS='',I5,
     *    '' KARTEZ='',I1,/,20X,'' GOGWID='',D15.7,'' GOGPAR='',D15.7)',
     *          N_MAXX,NGAUSS,KARTEZ,GOGWID,GOGPAR
C
C=======================================================================
C          PRINTING THE FACTORIALS
C=======================================================================
C
      PRINT '(/''  I'','' FACTORIAL(I)'',
     *                 '' ODD(I)*EV(I)'',
     *                 ''    ODD(I)   '',
     *                 ''   EVEN(I)   ''/)'
C
      DO I=1,2*N_MAXX+1
C
         IF (I.GT.NUFACR) STOP ' I TOO LARGE IN TESGOG (1)'
C
         PRINT '(I3,4D13.5)',I,FACTOR(I),FACTOO(I)*FACTOE(I),
     *                                   FACTOO(I),FACTOE(I)
      END DO
C
C=======================================================================
C          TESTING THE FORM FACTORS OF THE GAUSSIAN INTERACTION AGAINST
C          THE RESULTS OF EXPLICIT NUMERICAL INTEGRATION.  SET I=0 OR 1
C          BELOW TO TEST THE TWO KINDS OF FORM FACTORS.
C=======================================================================
C
      I=I_KIND
C
      PRINT '(////'' TESTS OF FORM FACTORS IN TESGOG FOR I='',I1)',I
C
      NPOIN2=300
      RANGE=5.0D0*GOGPAR
      STEP=RANGE/NPOIN2
      NMAIN4=4*N_MAXX
      CALL NORFAQ(HERFAQ,NMAIN4)
C
      PRINT '(/'' NPOIN2='',I5,'' RANGE='',F10.5,'' STEP='',F10.5)',
     *      NPOIN2,RANGE,STEP
C
      DO KOSCIL = 0,NMAIN4
         RESULN(KOSCIL)=0
      END DO
C
      DO IPOINT = -NPOIN2,NPOIN2
         XPOINT = STEP * IPOINT
         CALL D_HERQ(XPOINT,NMAIN4,PHERMI,DHERMI,4*NDOSCI+1)
C
         DO KOSCIL = 0,NMAIN4
            RESULN(KOSCIL)=RESULN(KOSCIL)+STEP*EXP(-XPOINT**2)
     *                                   *(XPOINT*SQ2)**I
     *                                  *PHERMI(KOSCIL+1)/HERFAQ(KOSCIL)
     *                                   *EXP(-2*XPOINT**2/GOGPAR**2)
C
         END DO
      END DO
C
      PRINT '(/'' KOSCIL '','' NUMERICAL  RESULT '',
     *                      '' ANALYTICAL RESULT '',
     *                      '' RELATIVE DIFFERENCE''/)'
C
      DIFMAX=0
      DO KOSCIL = 0,NMAIN4
         IF (MOD(KOSCIL,2).EQ.I.AND.I.EQ.0) THEN
             PRINT '(I7,3D19.10)',KOSCIL,RESULN(KOSCIL),GOGFF0(KOSCIL),
     *                    (RESULN(KOSCIL)-GOGFF0(KOSCIL))/RESULN(KOSCIL)
                DIFMAX=MAX(DIFMAX,ABS((RESULN(KOSCIL)-GOGFF0(KOSCIL))
     *                                                 /RESULN(KOSCIL)))
         END IF
         IF (MOD(KOSCIL,2).EQ.I.AND.I.EQ.1) THEN
             PRINT '(I7,3D19.10)',KOSCIL,RESULN(KOSCIL),GOGFF1(KOSCIL),
     *                    (RESULN(KOSCIL)-GOGFF1(KOSCIL))/RESULN(KOSCIL)
                DIFMAX=MAX(DIFMAX,ABS((RESULN(KOSCIL)-GOGFF1(KOSCIL))
     *                                                 /RESULN(KOSCIL)))
         END IF
      END DO
C
      PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10)',DIFMAX
C
C=======================================================================
C          TESTING THE SCALED HERMITE POLYNOMIALS CEFFICIENTS AGAINST
C          THE EXPLICIT SUMMATION OF THE HERMITE POLYNOMIALS.
C=======================================================================
C
      PRINT '(//'' TESTS OF SCALED HERMITE POLYNOMIALS IN TESGOG'')'
C
      NMAIN2=2*N_MAXX
      CALL NORFAQ(HERFAQ,NMAIN2)
C
      XPOINT=1.5
      PRINT '(/'' XPOINT='',F10.5)',XPOINT
C
      CALL D_HERQ(XPOINT,NMAIN2,PHERMI,DHERMI,4*NDOSCI+1)
C
      DO KOSCIL = 0,NMAIN2
         RESULN(KOSCIL)=0
         DO LOSCIL = 0,KOSCIL
            RESULN(KOSCIL)=RESULN(KOSCIL)+COFSCA(KOSCIL,LOSCIL)
     *                                  *PHERMI(LOSCIL+1)/HERFAQ(LOSCIL)
         END DO
      END DO
C
      XPOINT=XPOINT/SQ2
C
      CALL D_HERQ(XPOINT,NMAIN2,PHERMI,DHERMI,4*NDOSCI+1)
C
      PRINT '(/'' KOSCIL '','' RESULT OF SUMATION'',
     *                      '' ANALYTICAL RESULT '',
     *                      '' RELATIVE DIFFERENCE''/)'
C
      DIFMAX=0
      DO KOSCIL = 0,NMAIN2
         PRINT '(I7,3D19.10)',KOSCIL,RESULN(KOSCIL),
     *                               PHERMI(KOSCIL+1)/HERFAQ(KOSCIL),
     *                  (RESULN(KOSCIL)-PHERMI(KOSCIL+1)/HERFAQ(KOSCIL))
     *                                                  /RESULN(KOSCIL)
                DIFMAX=MAX(DIFMAX,ABS((RESULN(KOSCIL)-PHERMI(KOSCIL+1)
     *                                                 /HERFAQ(KOSCIL))
     *                                                 /RESULN(KOSCIL)))
      END DO
C
C
      PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10)',DIFMAX
C
C=======================================================================
C          TESTING THE MOSHINSKI  COEFFICIENTS  AGAINST  THE  EXPLICIT
C          EXPRESSION DERIVED IN 63-B.  SET I=0 OR 1 ABOVE TO TEST THE
C          MOSHINSKI COEFFICIENTS FOR EVEN AND ODD K+L, RESPECTIVELY.
C=======================================================================
C
      PRINT '(//'' TESTS OF THE MOSHINSKI COEFFICIENTS FROM DEFGOG'',
     *          '' IN TESGOG FOR I='',I1)',I
C
      IF (I_TEST.GE.2)
     *    PRINT '(/''   K   L  '','' RESULT OF DEFGOG  '',
     *                            '' ANALYTICAL RESULT '',
     *                            '' RELATIVE DIFFERENCE''/)'
C
      DIFMAX=0
      DO K = 0,NMAIN2
         DO L = 0,NMAIN2
C
            RESULT=0.0D0
C
            IF (MOD(K+L,2).EQ.0) THEN
C
                DO M=0,MIN(K,L)
C
                   RESULT=RESULT+COFSCA(K,M)*COFSCA(L,M)
C
                END DO
C
                M=(K+L)/2
C
                IF (M.GT.NUFACR) STOP ' M TOO LARGE IN TESGOG (2)'
C
                RESULT=RESULT*(-2.0D0)**M
     *                     *FACTOR(M)/SQRT(FACTOO(M))/SQRT(FACTOE(M))
C
            ELSE
C
                DO M=0,MIN(K,L+1)
C
                   RESULT=RESULT+COFSCA(K,M)*COFSCA(L+1,M)
C
                END DO
C
                M=(K+L-1)/2
C
                IF (M.GT.NUFACR) STOP ' M TOO LARGE IN TESGOG (3)'
C
                RESULT=RESULT*(-2.0D0)**M
     *                     *FACTOR(M)/SQRT(FACTOO(M))/SQRT(FACTOE(M))
     *                     *SQ2*SQRT((L+1.0D0)/(K+L))
C
            END IF
C
            IF (MOD(K+L,2).EQ.I) THEN
                DIFMAX=MAX(DIFMAX,ABS((COFMOS(K,L)-RESULT)/RESULT))
C
                IF (I_TEST.GE.2)
     *          PRINT '(2I4,5D19.10)',K,L,
     *                                COFMOS(K,L),RESULT,
     *                       (COFMOS(K,L)-RESULT)/RESULT
C    *                        COFMOS(K,L)        /RESULT,
C    *                       (COFMOS(K,L)        /RESULT)**2
C
            END IF
         END DO
      END DO
C
      PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10)',DIFMAX
C
C=======================================================================
C          TESTING THE  MOSHINSKI  COEFFICIENTS  AGAINST  THOSE
C          CALCULATED IN DEFMOS. SET I=0 OR 1 ABOVE TO TEST THE
C          MOSHINSKI COEFFICIENTS FOR EVEN AND ODD K+L, RESPECTIVELY.
C=======================================================================
C
      PRINT '(//'' TESTS OF THE MOSHINSKI COEFFICIENTS FROM DEFMOS'',
     *          '' IN TESGOG FOR I='',I1)',I
C
      IF (I_TEST.GE.2)
     *    PRINT '(/''   K   L  '','' RESULT OF DEFGOG  '',
     *                            '' RESULT OF DEFMOS  '',
     *                            '' RELATIVE DIFFERENCE''/)'
C
      DIFMAX=0
      DO K = 0,N_MAXX
         DO L = 0,N_MAXX
C
            RESULT=COEMOS(0,K,L,KARTEZ)
C
            IF (MOD(K+L,2).EQ.I) THEN
                DIFMAX=MAX(DIFMAX,ABS((COFMOS(K,L)-RESULT)/RESULT))
C
                IF (I_TEST.GE.2)
     *          PRINT '(2I4,5D19.10)',K,L,
     *                                COFMOS(K,L),RESULT,
     *                       (COFMOS(K,L)-RESULT)/RESULT
C    *                        COFMOS(K,L)        /RESULT,
C    *                       (COFMOS(K,L)        /RESULT)**2
C
            END IF
         END DO
      END DO
C
      PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10)',DIFMAX
C
C=======================================================================
C          TESTING THE FINAL MATRIX ELEMENTS. SET I=0 OR 1
C          ABOVE TO TEST THE TWO KINDS OF MATRIX ELEMENTS.
C=======================================================================
C
      PRINT '(//'' TESTS OF FINAL MATRIX ELEMS IN TESGOG FOR I='',I1)',I
C
      IF (I_TEST.EQ.3) THEN ! IF NOT INDENTED
C
          PRINT '(/'' NP MP  N  M '','' NUMERICAL  RESULT '',
     *                               '' ANALYTICAL RESULT '',
     *                               '' RELAT. DIFFERENCE '',
     *                               '' ABSOL. DIFFERENCE '',
     *                               '' 2BODY INTEGRATION ''/)'
C
      DIFMAX=0
      DIFMAY=0
      DO N=0,N_MAXX
         DO M=0,N_MAXX
            DO NP=0,N_MAXX
               DO MP=0,N_MAXX
C
                  RESULT=0.0D0
C
                  DO IGAUSS=1,NGAUSS
                     DO JGAUSS=1,NGAUSS
C
                     RESULT=RESULT+  TWOWGT(IGAUSS,KARTEZ)
     *                              *TWOWGT(JGAUSS,KARTEZ)
     *                           *HERONE(NP,IGAUSS,KARTEZ)
     *                           *HERONE(MP,JGAUSS,KARTEZ)
     *                            *((TWOPNT(IGAUSS,KARTEZ)
     *                              -TWOPNT(JGAUSS,KARTEZ))
     *                                     /HOMSCA(KARTEZ,1))**I
     *                       *EXP(-((TWOPNT(IGAUSS,KARTEZ)
     *                              -TWOPNT(JGAUSS,KARTEZ))/GOGPAR)**2)
     *                            *HERONE(N,IGAUSS,KARTEZ)
     *                            *HERONE(M,JGAUSS,KARTEZ)
C
                     END DO
                  END DO
C
                  IF (MOD(NP+MP+N+M,2).EQ.0.AND.I.EQ.0) THEN
C
                      PRINT '(4I3,4D19.10)',NP,MP,N,M,
     *                        RESULT,GAUEL0(NP,MP,N,M),
     *                       (RESULT-GAUEL0(NP,MP,N,M))
     *                                               /GAUEL0(NP,MP,N,M),
     *                       (RESULT-GAUEL0(NP,MP,N,M))
C
                      DIFMAX=MAX(DIFMAX,ABS((RESULT-GAUEL0(NP,MP,N,M))
     *                                              /GAUEL0(NP,MP,N,M)))
                      DIFMAY=MAX(DIFMAY,ABS((RESULT-GAUEL0(NP,MP,N,M))))
C
                  END IF
C
                  IF (MOD(NP+MP+N+M,2).EQ.1.AND.I.EQ.1) THEN
C
                      PRINT '(4I3,4D19.10)',NP,MP,N,M,
     *                        RESULT,GAUEL1(NP,MP,N,M),
     *                       (RESULT-GAUEL1(NP,MP,N,M))
     *                                             /GAUEL1(NP,MP,N,M),
     *                       (RESULT-GAUEL1(NP,MP,N,M))
C
                      DIFMAX=MAX(DIFMAX,ABS((RESULT-GAUEL1(NP,MP,N,M))
     *                                             /GAUEL1(NP,MP,N,M)))
                      DIFMAY=MAX(DIFMAY,ABS((RESULT-GAUEL1(NP,MP,N,M))))
C
                  END IF
C
               END DO
            END DO
         END DO
      END DO
C
      PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10)',DIFMAX
      PRINT '(/'' MAXIMUM          DIFFERENCE='',D19.10)',DIFMAY
C
      END IF ! IF NOT INDENTED
C
      IF (I_TEST.EQ.4) THEN ! IF NOT INDENTED
C
      IF (NPOINT.EQ.0) STOP 'NPOINT NOT READ BY NAMELI IN TESGOG'
C
C=======================================================================
      IF (     ALLOCATED(FSIMPS)) DEALLOCATE (FSIMPS)
      IF (.NOT.ALLOCATED(FSIMPS)) THEN
          ALLOCATE (FSIMPS(-NPOINT:NPOINT),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('FSIMPS','TESGOG')
      END IF
C=======================================================================
      IF (     ALLOCATED(HERMIS)) DEALLOCATE (HERMIS)
      IF (.NOT.ALLOCATED(HERMIS)) THEN
          ALLOCATE (HERMIS(-NPOINT:NPOINT,0:4*NDOSCI),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HERMIS','TESGOG')
      END IF
C=======================================================================
      IF (     ALLOCATED(HELP_I)) DEALLOCATE (HELP_I)
      IF (.NOT.ALLOCATED(HELP_I)) THEN
         ALLOCATE (HELP_I(-NPOINT:NPOINT,0:NDOSCI,0:NDOSCI),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HELP_I','TESGOG')
      END IF
C=======================================================================
      IF (     ALLOCATED(HELP_J)) DEALLOCATE (HELP_J)
      IF (.NOT.ALLOCATED(HELP_J)) THEN
         ALLOCATE (HELP_J(-NPOINT:NPOINT,0:NDOSCI,0:NDOSCI),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HELP_J','TESGOG')
      END IF
C=======================================================================
      IF (     ALLOCATED(HELPAJ)) DEALLOCATE (HELPAJ)
      IF (.NOT.ALLOCATED(HELPAJ)) THEN
         ALLOCATE (HELPAJ(-NPOINT:NPOINT,0:NDOSCI,0:NDOSCI),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HELPAJ','TESGOG')
      END IF
C=======================================================================
      IF (     ALLOCATED(HELPIJ)) DEALLOCATE (HELPIJ)
      IF (.NOT.ALLOCATED(HELPIJ)) THEN
          ALLOCATE (HELPIJ(-NPOINT:NPOINT,-NPOINT:NPOINT),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('HELPIJ','TESGOG')
      END IF
C=======================================================================
C
      RANGE=RANGX*GOGPAR
      STEP=RANGE/NPOINT
      NMAIN4=4*N_MAXX
      CALL NORFAQ(HERFAQ,NMAIN4)
C
      PRINT '(/'' NPOINT='',I5,'' RANGE='',F10.5,'' STEP='',F10.5)',
     *      NPOINT,RANGE,STEP
C
          PRINT '(/'' NP MP  N  M '','' NUMERICAL  RESULT '',
     *                               '' ANALYTICAL RESULT '',
     *                               '' RELAT. DIFFERENCE '',
     *                               '' ABSOL. DIFFERENCE '',
     *                               '' LAGRA INTEGRATION ''/)'
C
C=======================================================================
C
      DO IPOINT = -NPOINT,NPOINT
         XPOINT = STEP * IPOINT
         CALL D_HERQ(XPOINT,NMAIN4,PHERMI,DHERMI,4*NDOSCI+1)
C
         DO KOSCIL = 0,NMAIN4
C
            HERMIS(IPOINT,KOSCIL)=PHERMI(KOSCIL+1)/HERFAQ(KOSCIL)
     *                                         *EXP(-XPOINT**2/2)
C
         END DO
      END DO
C
C=======================================================================
C
      DO N=0,N_MAXX
         DO NP=0,N_MAXX
            DO IPOINT = -NPOINT,NPOINT
C
               HELP_I(IPOINT,N,NP)=HERMIS(IPOINT,NP)
     *                            *HERMIS(IPOINT,N )
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DO M=0,N_MAXX
         DO MP=0,N_MAXX
            DO JPOINT = -NPOINT,NPOINT
C
               HELP_J(JPOINT,M,MP)=HERMIS(JPOINT,MP)
     *                            *HERMIS(JPOINT,M )
C
            END DO
         END DO
      END DO
C
C=======================================================================
C           SIMPSON INTEGRATION
C=======================================================================
C
      DO IPOINT = -NPOINT,NPOINT
C
         IF (ABS(IPOINT).EQ.NPOINT) THEN
C
             FSIMPS(IPOINT)=STEP/3
         ELSE
             IF (MOD(NPOINT-IPOINT,2).EQ.1) THEN
C
                 FSIMPS(IPOINT)=4*STEP/3
             ELSE
                 FSIMPS(IPOINT)=2*STEP/3
C
             END IF
         END IF
C
      END DO
C
C=======================================================================
C
      DO IPOINT = -NPOINT,NPOINT
         DO JPOINT = -NPOINT,NPOINT
C
            HELPIJ(IPOINT,JPOINT)=FSIMPS(IPOINT)*FSIMPS(JPOINT)
     *                       *(STEP*(IPOINT-JPOINT)/HOMSCA(KARTEZ,1))**I
     *                 *EXP(-((STEP*(IPOINT-JPOINT))/GOGPAR)**2)
C
         END DO
      END DO
C
C=======================================================================
C
      DO N=0,N_MAXX
         DO NP=0,N_MAXX
            DO JPOINT = -NPOINT,NPOINT
C
               RESULT=0.0D0
C
               DO IPOINT = -NPOINT+1,NPOINT-1
C
                 RESULT=RESULT+HELP_I(IPOINT,N,NP)*HELPIJ(IPOINT,JPOINT)
C
               END DO
C
               HELPAJ(JPOINT,N,NP)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DIFMAX=0
      DIFMAY=0
C
      DO N=0,N_MAXX
         DO M=0,N_MAXX
            DO NP=0,N_MAXX
               DO MP=0,N_MAXX
C
                  RESULT=0.0D0
C
C                 DO IPOINT = -NPOINT,NPOINT
                     DO JPOINT = -NPOINT,NPOINT
C
                        RESULT=RESULT+HELPAJ(JPOINT,N,NP)
     *                               *HELP_J(JPOINT,M,MP)
C
C                       RESULT=RESULT+STEP**2
C    *                               *HERMIS(IPOINT,NP)
C    *                               *HERMIS(JPOINT,MP)
C    *                        *(STEP*(IPOINT-JPOINT))**I
C    *                  *EXP(-((STEP*(IPOINT-JPOINT))/GOGPAR)**2)
C    *                               *HERMIS(IPOINT,N )
C    *                               *HERMIS(JPOINT,M )
C
                     END DO
C                 END DO
C
                  IF (MOD(NP+MP+N+M,2).EQ.0.AND.I.EQ.0) THEN
C
                      PRINT '(4I3,4D19.10)',NP,MP,N,M,
     *                        RESULT,GAUEL0(NP,MP,N,M),
     *                       (RESULT-GAUEL0(NP,MP,N,M))
     *                                             /GAUEL0(NP,MP,N,M),
     *                       (RESULT-GAUEL0(NP,MP,N,M))
C
                      DIFMAX=MAX(DIFMAX,ABS((RESULT-GAUEL0(NP,MP,N,M))
     *                                             /GAUEL0(NP,MP,N,M)))
                      DIFMAY=MAX(DIFMAY,ABS((RESULT-GAUEL0(NP,MP,N,M))))
C
                  END IF
C
                  IF (MOD(NP+MP+N+M,2).EQ.1.AND.I.EQ.1) THEN
C
                      PRINT '(4I3,4D19.10)',NP,MP,N,M,
     *                        RESULT,GAUEL1(NP,MP,N,M),
     *                       (RESULT-GAUEL1(NP,MP,N,M))
     *                                             /GAUEL1(NP,MP,N,M),
     *                       (RESULT-GAUEL1(NP,MP,N,M))
C
                      DIFMAX=MAX(DIFMAX,ABS((RESULT-GAUEL1(NP,MP,N,M))
     *                                             /GAUEL1(NP,MP,N,M)))
                      DIFMAY=MAX(DIFMAY,ABS((RESULT-GAUEL1(NP,MP,N,M))))
C
                  END IF
C
               END DO
            END DO
         END DO
      END DO
C
      PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10)',DIFMAX
      PRINT '(/'' MAXIMUM          DIFFERENCE='',D19.10)',DIFMAY
C
C=======================================================================
      DEALLOCATE (HERMIS)
      DEALLOCATE (HELP_I)
      DEALLOCATE (HELP_J)
      DEALLOCATE (HELPAJ)
      DEALLOCATE (HELPIJ)
C=======================================================================
      END IF ! IF NOT INDENTED
C=======================================================================
C
      CALL CPUTIM('TESGOG',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE EXCGOG(N_MAXX,
     *                  GAUEL0,GAUEL1,GAUEL2,GAUEL4,GAUEL6,
     *                                       GAUT21,GAUT22,
     *                                GAUT41,GAUT42,GAUT43)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
C
C=======================================================================
C        THIS SUBROUTINE EXCHANGES THE  THIRD  (3RD)  AND  FOURTH  (4TH)
C        HARMONIC-OSCILLATOR INDICES OF MATRIX ELEMENTS OF THE  TWO-BODY
C        GAUSSIAN INTERACTION IN ONE DIMENSION. IT  IS  DESIGNED  TO  BE
C        APPLIED BEFORE EVAULATIONG THE EXCHANGE TERM.
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN EXCGOG'
C
C=======================================================================
C          EXCHANGING THE MATRIX ELEMENTS
C=======================================================================
C
      DO NP=0,N_MAXX
         DO MP=0,N_MAXX
            DO N=0,N_MAXX
               DO M=0,N
C
                  VALUNM=GAUEL0(NP,MP,N,M)
                  VALUMN=GAUEL0(NP,MP,M,N)
C
                  GAUEL0(NP,MP,M,N)=VALUNM
                  GAUEL0(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUEL1(NP,MP,N,M)
                  VALUMN=GAUEL1(NP,MP,M,N)
C
                  GAUEL1(NP,MP,M,N)=VALUNM
                  GAUEL1(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUEL2(NP,MP,N,M)
                  VALUMN=GAUEL2(NP,MP,M,N)
C
                  GAUEL2(NP,MP,M,N)=VALUNM
                  GAUEL2(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUEL4(NP,MP,N,M)
                  VALUMN=GAUEL4(NP,MP,M,N)
C
                  GAUEL4(NP,MP,M,N)=VALUNM
                  GAUEL4(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUEL6(NP,MP,N,M)
                  VALUMN=GAUEL6(NP,MP,M,N)
C
                  GAUEL6(NP,MP,M,N)=VALUNM
                  GAUEL6(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUT21(NP,MP,N,M)
                  VALUMN=GAUT21(NP,MP,M,N)
C
                  GAUT21(NP,MP,M,N)=VALUNM
                  GAUT21(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUT22(NP,MP,N,M)
                  VALUMN=GAUT22(NP,MP,M,N)
C
                  GAUT22(NP,MP,M,N)=VALUNM
                  GAUT22(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUT41(NP,MP,N,M)
                  VALUMN=GAUT41(NP,MP,M,N)
C
                  GAUT41(NP,MP,M,N)=VALUNM
                  GAUT41(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUT42(NP,MP,N,M)
                  VALUMN=GAUT42(NP,MP,M,N)
C
                  GAUT42(NP,MP,M,N)=VALUNM
                  GAUT42(NP,MP,N,M)=VALUMN
C
                  VALUNM=GAUT43(NP,MP,N,M)
                  VALUMN=GAUT43(NP,MP,M,N)
C
                  GAUT43(NP,MP,M,N)=VALUNM
                  GAUT43(NP,MP,N,M)=VALUMN
C
               END DO
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PAIGOG(N_MAXX,
     *                  GAUEL0,GAUEL1,GAUEL2,GAUEL4,GAUEL6,
     *                                       GAUT21,GAUT22,
     *                                GAUT41,GAUT42,GAUT43)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      DIMENSION
     *          GAUEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          GAUT43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          AUXEL0(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXEL1(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXEL2(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXEL4(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXEL6(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXT21(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXT22(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXT41(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXT42(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI),
     *          AUXT43(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
C
C=======================================================================
C        THIS SUBROUTINE EXCHANGES THE
C        HARMONIC-OSCILLATOR INDICES OF MATRIX ELEMENTS OF THE  TWO-BODY
C        GAUSSIAN INTERACTION IN ONE DIMENSION. IT  IS  DESIGNED  TO  BE
C        APPLIED BEFORE EVALUATING THE PAIRING TERM AND AFTER EVALUATING
C        THE EXCHANGE TERM.
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN PAIGOG'
C
C=======================================================================
C          EXCHANGING THE MATRIX ELEMENTS
C=======================================================================
C
      DO MP=0,N_MAXX
         DO M=0,N_MAXX
            DO NP=0,N_MAXX
               DO N=0,N_MAXX
C
                  AUXEL0(MP,M,NP,N)=GAUEL0(NP,MP,M,N)
                  AUXEL1(MP,M,NP,N)=GAUEL1(NP,MP,M,N)
                  AUXEL2(MP,M,NP,N)=GAUEL2(NP,MP,M,N)
                  AUXEL4(MP,M,NP,N)=GAUEL4(NP,MP,M,N)
                  AUXEL6(MP,M,NP,N)=GAUEL6(NP,MP,M,N)
                  AUXT21(MP,M,NP,N)=GAUT21(NP,MP,M,N)
                  AUXT22(MP,M,NP,N)=GAUT22(NP,MP,M,N)
                  AUXT41(MP,M,NP,N)=GAUT41(NP,MP,M,N)
                  AUXT42(MP,M,NP,N)=GAUT42(NP,MP,M,N)
                  AUXT43(MP,M,NP,N)=GAUT43(NP,MP,M,N)
C
               END DO
            END DO
         END DO
      END DO
C
      GAUEL0=AUXEL0
      GAUEL1=AUXEL1
      GAUEL2=AUXEL2
      GAUEL4=AUXEL4
      GAUEL6=AUXEL6
      GAUT21=AUXT21
      GAUT22=AUXT22
      GAUT41=AUXT41
      GAUT42=AUXT42
      GAUT43=AUXT43
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFMOS(N_MAXX,KARTEZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
#if(SWITCH_QUAD==1)
      REAL*16
     *          RBINOM
#endif
C
      COMMON
     *       /NEWBIR/ RBINOM(0:NDBINO,0:NDBINO)
      COMMON
     *       /COEFMO/ COEMOS(0:ND0MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
C
C=======================================================================
C        THIS  SUBROUTINE  CALCULATES  THE  MOSHINSKI COFFICIENTS:
C
C          H_K^(0)(X) * H_L^(0)(Y)
C                  = SUM_S COEMOS(S,K,L) * H_S^(0)(U) * H_P^(0)(T)
C
C          FOR P=K+L-S, U=(X+Y)/SQ2, T=(X-Y)/SQ2
C
C        SEE NOTES 8.70E
C=======================================================================
C
      IF (N_MAXX.GT.NDOSCI) STOP 'N_MAXX.GT.NDOSCI IN DEFMOS'
C
      DSQRT2=SQRT(2.0D0)
C
C=======================================================================
C
      DO K=0,N_MAXX
         DO L=0,N_MAXX
            DO N=0,K+L
C
C=======================================================================
C        HERE CONTRIBUTIONS FOR EVEN VALUES OF I ARE ADDED
C=======================================================================
C
               COEEVE=0.0D0
C
               DO I=0,N,2
C
                  IF (K-I.GE.0.AND.L-N+I.GE.0) THEN
C
                  COEEVE=COEEVE+SQRT(RBINOM(N,I)*RBINOM(K+L-N,K-I)
     *                              *RBINOM(K,I)*RBINOM(L,N-I))
C
                  END IF
C
               END DO
C
C=======================================================================
C        HERE CONTRIBUTIONS FOR ODD VALUES OF I ARE SUBTREACTED
C=======================================================================
C
               COEODD=0.0D0
C
               IF (N.GT.0) THEN
C
                   DO I=1,N,2
C
                      IF (K-I.GE.0.AND.L-N+I.GE.0) THEN
C
                      COEODD=COEODD+SQRT(RBINOM(N,I)*RBINOM(K+L-N,K-I)
     *                                  *RBINOM(K,I)*RBINOM(L,N-I))
C
                      END IF
C
                   END DO
C
               END IF
C
               COEMOS(N,K,L,KARTEZ)=(-1)**(N-L)
     *                             *(COEEVE-COEODD)/DSQRT2**(K+L)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SKF_IN(IROTAT)
C=======================================================================
      USE BROYIN
      USE VE_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
C
      COMMON
     *       /BROTEN/ KSCALA,KVECTO,KTENSO,KLIPKI
     *       /BROSIZ/ NSCALR,NVECTO,NTENSO,NMATRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE STORES OLD PARTICLE-HOLE FIELDS TO BE USED
C        IN THE BROYDEN METHOD
C=======================================================================
C
      INDEXX=KLIPKI
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               INDEXX=INDEXX+1
C
               BRO_IN(INDEXX)         =REAL(VE_MAS(IX,IY,IZ,0,1))
     *                                *EXPAUX(IX,IY,IZ,1)
               BRO_IN(INDEXX+  NSCALR)=REAL(VE_MAS(IX,IY,IZ,1,1))
     *                                *EXPAUX(IX,IY,IZ,1)
C
               BRO_IN(INDEXX+2*NSCALR)=REAL(VE_CEN(IX,IY,IZ,0,1))
     *                                *EXPAUX(IX,IY,IZ,1)
               BRO_IN(INDEXX+3*NSCALR)=REAL(VE_CEN(IX,IY,IZ,1,1))
     *                                *EXPAUX(IX,IY,IZ,1)
C
            END DO
         END DO
      END DO
C
      IF (IROTAT.EQ.1) THEN
C
          INDEXX=KLIPKI+KSCALA
C
          DO K=1,NDKART
C
             DO IZ=1,NZHERM
                DO IY=1,NYHERM
                   DO IX=1,NXHERM
C
                      INDEXX=INDEXX+1
C
                      BRO_IN(INDEXX)
     *                 =REAL(VE_CUR(IX,IY,IZ,K,0,1))
     *                      *EXPAUX(IX,IY,IZ,1)
                      BRO_IN(INDEXX+  NVECTO)
     *                 =REAL(VE_CUR(IX,IY,IZ,K,1,1))
     *                      *EXPAUX(IX,IY,IZ,1)
C
                      BRO_IN(INDEXX+2*NVECTO)
     *                 =REAL(VE_KIS(IX,IY,IZ,K,0,1))
     *                      *EXPAUX(IX,IY,IZ,1)
                      BRO_IN(INDEXX+3*NVECTO)
     *                 =REAL(VE_KIS(IX,IY,IZ,K,1,1))
     *                      *EXPAUX(IX,IY,IZ,1)
C
                      BRO_IN(INDEXX+4*NVECTO)
     *                 =REAL(VE_SPI(IX,IY,IZ,K,0,1))
     *                      *EXPAUX(IX,IY,IZ,1)
                      BRO_IN(INDEXX+5*NVECTO)
     *                 =REAL(VE_SPI(IX,IY,IZ,K,1,1))
     *                      *EXPAUX(IX,IY,IZ,1)
C
                   END DO
                END DO
             END DO
C
          END DO
C
      END IF
C
      INDEXX=KLIPKI+KSCALA+KVECTO
C
      DO L=1,NDKART
         DO K=1,NDKART
C
            DO IZ=1,NZHERM
               DO IY=1,NYHERM
                  DO IX=1,NXHERM
C
                     INDEXX=INDEXX+1
C
                     BRO_IN(INDEXX)
     *                =REAL(VE_SOR(IX,IY,IZ,K,L,0,1))
     *                     *EXPAUX(IX,IY,IZ,1)
                     BRO_IN(INDEXX+NTENSO)
     *                =REAL(VE_SOR(IX,IY,IZ,K,L,1,1))
     *                     *EXPAUX(IX,IY,IZ,1)
C
                  END DO
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SKF_OU(IROTAT)
C=======================================================================
      USE BROYOU
      USE VE_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
C
      COMMON
     *       /BROTEN/ KSCALA,KVECTO,KTENSO,KLIPKI
     *       /BROSIZ/ NSCALR,NVECTO,NTENSO,NMATRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE STORES NEW PARTICLE-HOLE FIELDS TO BE USED
C        IN THE BROYDEN METHOD
C=======================================================================
C
      INDEXX=KLIPKI
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               INDEXX=INDEXX+1
C
               BRO_OU(INDEXX)
     *          =REAL(VE_MAS(IX,IY,IZ,0,1))*EXPAUX(IX,IY,IZ,1)
               BRO_OU(INDEXX+  NSCALR)
     *          =REAL(VE_MAS(IX,IY,IZ,1,1))*EXPAUX(IX,IY,IZ,1)
C
               BRO_OU(INDEXX+2*NSCALR)
     *          =REAL(VE_CEN(IX,IY,IZ,0,1))*EXPAUX(IX,IY,IZ,1)
               BRO_OU(INDEXX+3*NSCALR)
     *          =REAL(VE_CEN(IX,IY,IZ,1,1))*EXPAUX(IX,IY,IZ,1)
C
            END DO
         END DO
      END DO
C
      IF (IROTAT.EQ.1) THEN
C
          INDEXX=KLIPKI+KSCALA
C
          DO K=1,NDKART
C
             DO IZ=1,NZHERM
                DO IY=1,NYHERM
                   DO IX=1,NXHERM
C
                      INDEXX=INDEXX+1
C
                      BRO_OU(INDEXX)
     *                 =REAL(VE_CUR(IX,IY,IZ,K,0,1))
     *                      *EXPAUX(IX,IY,IZ,1)
                      BRO_OU(INDEXX+  NVECTO)
     *                 =REAL(VE_CUR(IX,IY,IZ,K,1,1))
     *                      *EXPAUX(IX,IY,IZ,1)
C
                      BRO_OU(INDEXX+2*NVECTO)
     *                 =REAL(VE_KIS(IX,IY,IZ,K,0,1))
     *                      *EXPAUX(IX,IY,IZ,1)
                      BRO_OU(INDEXX+3*NVECTO)
     *                 =REAL(VE_KIS(IX,IY,IZ,K,1,1))
     *                      *EXPAUX(IX,IY,IZ,1)
C
                      BRO_OU(INDEXX+4*NVECTO)
     *                 =REAL(VE_SPI(IX,IY,IZ,K,0,1))
     *                      *EXPAUX(IX,IY,IZ,1)
                      BRO_OU(INDEXX+5*NVECTO)
     *                 =REAL(VE_SPI(IX,IY,IZ,K,1,1))
     *                      *EXPAUX(IX,IY,IZ,1)
C
                   END DO
                END DO
             END DO
C
          END DO
C
      END IF
C
      INDEXX=KLIPKI+KSCALA+KVECTO
C
      DO L=1,NDKART
         DO K=1,NDKART
C
            DO IZ=1,NZHERM
               DO IY=1,NYHERM
                  DO IX=1,NXHERM
C
                     INDEXX=INDEXX+1
C
                     BRO_OU(INDEXX)
     *                =REAL(VE_SOR(IX,IY,IZ,K,L,0,1))
     *                     *EXPAUX(IX,IY,IZ,1)
                     BRO_OU(INDEXX+NTENSO)
     *                =REAL(VE_SOR(IX,IY,IZ,K,L,1,1))
     *                     *EXPAUX(IX,IY,IZ,1)
C
                  END DO
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LINMIX(ITERUN,NUMITE,IPCONT,IWRIOL,TERMNT,IF_THO,
     *                                I_SLOW,SLOWEV,SLOWOD,SLOWPA,
     *                                       XOLDEV,XOLDOD,XOLDPA)
C=======================================================================
      LOGICAL
     *          TERMNT
C
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMAT/ NOIINP,MIXMAT
C
C=======================================================================
C        THIS SUBROUTINE DETERMINES THE LINEAR MIXING FACTORS
C=======================================================================
C
C=======================================================================
C        HERE WE TAKE CARE OF THE START-UP ITERATION, FOR WHICH THE
C        OLD FIELDS DO NOT EXIST YET.
C=======================================================================
C
                       NBROYD=IBROYD
      IF (NUMITE.EQ.0) NBROYD=0
C
      IF (NUMITE.EQ.0.OR.NBROYD.GE.1
     *               .OR.IF_THO.GE.1
     *               .OR.MIXMAT.NE.0
     *               .OR.I_SLOW.EQ.1) THEN
          XOLDEV=0.0
          XOLDOD=0.0
      ELSE
          XOLDEV=SLOWEV
          XOLDOD=SLOWOD
      END IF
C
C=======================================================================
C
      IF (NUMITE.EQ.0.OR.(ITERUN.EQ.1.AND.IPCONT.NE.1)
     *               .OR.NBROYD.GE.1
     *               .OR.IF_THO.GE.1
     *               .OR.MIXMAT.NE.0
     *               .OR.I_SLOW.EQ.1) THEN
          XOLDPA=0.0
      ELSE
          XOLDPA=SLOWPA
      END IF
C
C=======================================================================
C         HERE WE TAKE CARE OF THE LAST ITERATION, IN WHICH FOR IWRIOL=1
C         THE OLD FIELDS ARE TO BE STORED, WHICH  ALLOWS  FOR  A  SMOOTH
C         CONTINUATION OF ITERATIONS WHEN THE MEAN-FIELD FILE IS USED.
C=======================================================================
C         ATTENTION: IN VERSIONS BEFORE  2.66E, THE CONDITION BELOW  WAS
C                    INCORRECTLY CODED AND THE VALUES OF "XOLD__" BEFORE
C                    THE LAST ITERATION COULD HAVE BEEN INCRRECTLY  SET.
C                    IN SOME SITUATIONS, THE CODE COULD THUS OPERATE FOR
C                    MIXING CONDITIONS NOT INTENDED  BY  THE  USER. THIS
C                    BUG WAS CORRECTED IN VERSION 2.66E ON 01/08/2013.
C=======================================================================
C
      IF (IWRIOL.EQ.1.AND.TERMNT) THEN
C
          XOLDEV=1.0D0
          XOLDOD=1.0D0
          XOLDPA=1.0D0
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SKFILD(XOLDEV,XOLDOD,IPNMIX,ITWCEN,LTWCEN)
C=======================================================================
      USE HE_DEN
      USE PD_DEN
      USE VE_FLD
      USE TRUINT
C=======================================================================
      USE hfodd_sizes
      USE ADBATC, only : DE_RHO_SAV, PD_RHO_SAV, DE_SPI_SAV
C=======================================================================
C
      COMPLEX
     *          XTOTAL,XNEUTR,XPROTO,VNEUTR,VPROTO
      COMPLEX
     *          ANEUTR,APROTO
      COMPLEX
     *          QUNRHO,QUPRHO,QUTRHO,QUNSPI,QUPSPI,QUTSPI
      COMPLEX
     *          DENSIC,DENCHC
      COMPLEX
     *          DENPOW,DENDER,PAID_N,PAID_P,PAID_S
      COMPLEX
     *          DENNEU,DENPRO,SPINEU(NDKART),SPIPRO(NDKART)
      COMPLEX
     *          C_ZERO
      COMPLEX
     *          PAINEU,PAIPRO
      COMPLEX
     *          TRJTOT,TRJPRO,TRJNEU
C
      DIMENSION
     *          ISIEPS(NDKART,NDKART),INDEPS(NDKART,NDKART)
C
C=======================================================================
      ALLOCATABLE ANEUTR(:,:,:,:)
      ALLOCATABLE APROTO(:,:,:,:)
C=======================================================================
C
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
C
      COMMON
     *       /CCPSKY/ CRHO_T,CRHO_S,CRHODT,CRHODS,
     *                CLPR_T,CLPR_S,
     *                CTAU_T,CTAU_S,
     *                CSCU_T,CSCU_S,
     *                CDIV_T,CDIV_S,
     *                CSPI_T,CSPI_S,CSPIDT,CSPIDS,
     *                CLPS_T,CLPS_S,
     *                CCUR_T,CCUR_S,
     *                CKIS_T,CKIS_S,
     *                CROT_T,CROT_S,
     *                CSCT_T,CSCT_S,
     *                CKIT_T,CKIT_S,
     *                CSPT_T,CSPT_S
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /CCPSKP/ PRHO_0,PRHOD0,PTAU_1,PTAU_2,PLPR_0,PSCU_1,
     *                PSCU_2,PSCU_3
      COMMON
     *       /INTSKY/ T0,X0,T1,X1,T2,X2,T3,X3,W0,POWER
      COMMON
     *       /EXCHAN/ COULEX
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMAT/ NOIINP,MIXMAT
      COMMON
     *       /EDFPAR/ V0NEFF,V0PEFF,COUSCA
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /CC2CBR/ CR2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CS2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CT2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CK2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CL2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CP2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CC2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CJ2CBR(0:NDISOS,0:NDISOS,0:1)
     *       /CC3CBR/ CR3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CS3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CT3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CK3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CL3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CP3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CC3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CJ3CBR(0:NDISOS,0:NDISOS,0:1)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /ADBLNM/ IADBLN
C
C=======================================================================
C        THE FOLLOWING CONSTRUCTION ALLOWS US TO CALCULATE  CONTRACTIONS
C        WITH THE TOTALLY ANTISYMMETRIC LEVY-CIVITTA TENSOR.
C
C        INDEPS CONTAINS  THE  THIRD  INDEX  FOR  THE  FIRST  TWO GIVEN.
C               (IN  CASE  OF  EQUAL  FIRST  INDICES IT CONTAINS A DUMMY
C                NON-ZERO INDEX VALUE TO AVOID CALLING  MATRIX  ELEMENTS
C                OUTSIDE THE   D E C L A R E D   F O R T R A N   BOUNDS)
C        ISIEPS CONTAINS THE SIGN OF THE TENSOR (+1 OR -1) FOR THE FIRST
C               TWO GIVEN INDICES.
C               (IN  CASE  OF  EQUAL  FIRST  INDICES IT CONTAINS A ZERO.
C                IN  THIS  WAY  THE  INDEX IN INDEPS IS THEN IMMATERIAL)
C=======================================================================
C
      DATA   ISIEPS /  0, -1, +1,
     *                +1,  0, -1,
     *                -1, +1,  0/
C
      DATA   INDEPS /  1,  3,  2,
     *                 3,  2,  1,
     *                 2,  1,  3/
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE SKYRME FIELDS BASED ON THE REF.
C        (ENGEL ET AL.) PLUS DERIVATIONS BY  K. BURZYNSKI  (CF. NOTES).
C=======================================================================
C
C        THE EFFECTIVE COUPLING CONSTANTS ARE CODED AS:
C                      'C'//'XXX'//'N'//'TYP'
C
C        WHERE THE SYMBOLS:  'C', 'XXX', 'N', AND 'TYP'
C        ARE EXPLAINED IN THE SUBROUTINE "ESKYRM"
C
C=======================================================================
C
C        ATTENTION: EXPONENTIAL FACTORS IN TWO-CENTER BASIS METHOD A R E
C                   NOT PROPERLY COMPUTED YET.
C
C=======================================================================
C
      CALL CPUTIM('SKFILD',1)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
      XNEWOD=1.00D0-XOLDOD
      XNEWEV=1.00D0-XOLDEV
C
C=======================================================================
C
      ALLOCATE(ANEUTR(NDXHRM,NDYHRM,NDZHRM,NDKART))
      ALLOCATE(APROTO(NDXHRM,NDYHRM,NDZHRM,NDKART))
C
C=======================================================================
C
      IF (LTWCEN.LT.1.AND.LTWCEN.GT.16)
     *    STOP 'LTWCEN INCOMPATIBLE IN SKFILD'
C
C=======================================================================
C
      IDEN_X=0
C
      ANEUTR(:,:,:,:)=C_ZERO
      APROTO(:,:,:,:)=C_ZERO
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
C
            IX1=NXHERM/2
            IX2=NXHERM/2 + 1

            IF (IABS(IDEN_X).EQ.1)
     *      WRITE (*,'(4I3,12(1PE14.6))') IX1,IX2,IY,IZ,
     *      REAL(DE_CUR(IX1,IY,IZ,1,0,1)+IDEN_X*
     *                    DE_CUR(IX2,IY,IZ,1,0,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_CUR(IX1,IY,IZ,1,1,1)+IDEN_X*
     *                    DE_CUR(IX2,IY,IZ,1,1,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_SPI(IX1,IY,IZ,1,0,1)+IDEN_X*
     *                    DE_SPI(IX2,IY,IZ,1,0,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_SPI(IX1,IY,IZ,1,1,1)+IDEN_X*
     *                    DE_SPI(IX2,IY,IZ,1,1,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_CUR(IX1,IY,IZ,2,0,1)+IDEN_X*
     *                    DE_CUR(IX2,IY,IZ,2,0,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_CUR(IX1,IY,IZ,2,1,1)+IDEN_X*
     *                    DE_CUR(IX2,IY,IZ,2,1,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_SPI(IX1,IY,IZ,2,0,1)+IDEN_X*
     *                    DE_SPI(IX2,IY,IZ,2,0,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_SPI(IX1,IY,IZ,2,1,1)+IDEN_X*
     *                    DE_SPI(IX2,IY,IZ,2,1,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_CUR(IX1,IY,IZ,3,0,1)+IDEN_X*
     *                    DE_CUR(IX2,IY,IZ,3,0,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_CUR(IX1,IY,IZ,3,1,1)+IDEN_X*
     *                    DE_CUR(IX2,IY,IZ,3,1,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_SPI(IX1,IY,IZ,3,0,1)+IDEN_X*
     *                    DE_SPI(IX2,IY,IZ,3,0,1))/2*EXPAUX(IX,IY,IZ,1),
     *      REAL(DE_SPI(IX1,IY,IZ,3,1,1)+IDEN_X*
     *                    DE_SPI(IX2,IY,IZ,3,1,1))/2*EXPAUX(IX,IY,IZ,1)
C
            DO IX=1,NXHERM
C
               DENPOW=              DENSIC(IX,IY,IZ,LTWCEN)**POWER
C
               IF (ITWCEN.EQ.1) THEN
C
                   DENDER=    POWER*DENSIC(IX,IY,IZ,1)**(POWER-1)
     *                             *EXPAUX(IX,IY,IZ,1)
                   PAID_N=       POWERN*DENSIC(IX,IY,IZ,1)**(POWERN-1)
     *                             *EXPAUX(IX,IY,IZ,1)
                   PAID_P=       POWERP*DENSIC(IX,IY,IZ,1)**(POWERP-1)
     *                             *EXPAUX(IX,IY,IZ,1)
                   PAID_S=       POWER *DENSIC(IX,IY,IZ,1)**(POWER -1)
     *                             *EXPAUX(IX,IY,IZ,1)
C
               ELSEIF (ITWCEN.EQ.2) THEN
C
                   DENDER=   POWER*DENSIC(IX,IY,IZ,LTWCEN)**(POWER-1)
                   PAID_N= POWERN*DENSIC(IX,IY,IZ,LTWCEN)**(POWERN-1)
                   PAID_P= POWERP*DENSIC(IX,IY,IZ,LTWCEN)**(POWERP-1)
                   PAID_S= POWER *DENSIC(IX,IY,IZ,LTWCEN)**(POWER -1)
C
C=======================================================================
C     ATTENTION: TWO-CENTER OPTION. FOR POWERS BETWEEN (0,1) WE DIVIDE
C     BY DENSIC. IF DENSIC IS CLOSE TO 0 CAN CAUSE NUMERICAL PROBLEMS
C     IN THAT CASE WE SET DENDER TO ZERO. PROVISIONAL.
C=======================================================================
C
                   IF (ABS(DENSIC(IX,IY,IZ,LTWCEN)).LE.1E-25) THEN
C
                       DENDER=0.0D0
                       PAID_N=0.0D0
                       PAID_P=0.0D0
                       PAID_S=0.0D0
C
                   END IF
c
               END IF
C
               IF (IADBLN.EQ.0) THEN
C
                   DENNEU= DE_RHO(IX,IY,IZ,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   DENPRO= DE_RHO(IX,IY,IZ,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
                   SPINEU(1)= DE_SPI(IX,IY,IZ,1,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   SPIPRO(1)= DE_SPI(IX,IY,IZ,1,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
                   SPINEU(2)= DE_SPI(IX,IY,IZ,2,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   SPIPRO(2)= DE_SPI(IX,IY,IZ,2,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
                   SPINEU(3)= DE_SPI(IX,IY,IZ,3,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   SPIPRO(3)= DE_SPI(IX,IY,IZ,3,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
                   PAINEU=PD_RHO(IX,IY,IZ,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   PAIPRO=PD_RHO(IX,IY,IZ,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
               ELSE
C
                   DENNEU= DE_RHO_SAV(IX,IY,IZ,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   DENPRO= DE_RHO_SAV(IX,IY,IZ,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
                   SPINEU(1)= DE_SPI_SAV(IX,IY,IZ,1,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   SPIPRO(1)= DE_SPI_SAV(IX,IY,IZ,1,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
                   SPINEU(2)= DE_SPI_SAV(IX,IY,IZ,2,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   SPIPRO(2)= DE_SPI_SAV(IX,IY,IZ,2,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
                   SPINEU(3)= DE_SPI_SAV(IX,IY,IZ,3,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   SPIPRO(3)= DE_SPI_SAV(IX,IY,IZ,3,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
                   PAINEU=PD_RHO_SAV(IX,IY,IZ,0,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
                   PAIPRO=PD_RHO_SAV(IX,IY,IZ,1,LTWCEN)*
     *                                           EXPAUX(IX,IY,IZ,LTWCEN)
C
               ENDIF
C
C=======================================================================
C              S  C  A  L  A  R     F I E L D S     F O L L O W
C=======================================================================
C              EFFECTIVE MASS TERM (SEE: ENGEL ET AL, EQ.(B.2))
C=======================================================================
C
               XTOTAL=CTAU_T*(DE_RHO(IX,IY,IZ,0,LTWCEN)
     *                          +DE_RHO(IX,IY,IZ,1,LTWCEN))
C
               XNEUTR=CTAU_S* DE_RHO(IX,IY,IZ,0,LTWCEN)
C
               XPROTO=CTAU_S* DE_RHO(IX,IY,IZ,1,LTWCEN)
C
               VNEUTR = XTOTAL+XNEUTR
               VPROTO = XTOTAL+XPROTO
C
C=======================================================================
C              AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
               XNEUTR=CT2CBR(0,0,0) * DE_RHO(IX,IY,IZ,0,LTWCEN)
     *                        +CT2CBR(0,1,0) * DE_RHO(IX,IY,IZ,1,LTWCEN)
     *                        +CT3CBR(0,0,0) * DE_RHO(IX,IY,IZ,0,LTWCEN)
     *                        +CT3CBR(0,1,0) * DE_RHO(IX,IY,IZ,1,LTWCEN)

               XPROTO=CT2CBR(1,1,0) * DE_RHO(IX,IY,IZ,1,LTWCEN)
     *                        +CT2CBR(0,1,0) * DE_RHO(IX,IY,IZ,0,LTWCEN)
     *                        +CT3CBR(1,1,0) * DE_RHO(IX,IY,IZ,1,LTWCEN)
     *                        +CT3CBR(0,1,0) * DE_RHO(IX,IY,IZ,0,LTWCEN)

               VNEUTR = VNEUTR+XNEUTR
               VPROTO = VPROTO+XPROTO
C
C=======================================================================
C
               VE_MAS(IX,IY,IZ,0,LTWCEN) =
     *              VE_MAS(IX,IY,IZ,0,LTWCEN)*XOLDEV+XNEWEV*VNEUTR
               VE_MAS(IX,IY,IZ,1,LTWCEN) =
     *              VE_MAS(IX,IY,IZ,1,LTWCEN)*XOLDEV+XNEWEV*VPROTO
C
C=======================================================================
C              CENTRAL TERM (<= T0) - (SEE: ENGEL ET AL, EQ.(B.3))
C=======================================================================
C
               XTOTAL=CRHO_T*(DE_RHO(IX,IY,IZ,0,LTWCEN)
     *                       +DE_RHO(IX,IY,IZ,1,LTWCEN)) * 2.0D0
C
               XNEUTR=CRHO_S* DE_RHO(IX,IY,IZ,0,LTWCEN)  * 2.0D0
               XPROTO=CRHO_S* DE_RHO(IX,IY,IZ,1,LTWCEN)  * 2.0D0
C
               VNEUTR = XTOTAL+XNEUTR
               VPROTO = XTOTAL+XPROTO
C
C=======================================================================
C              AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
               XNEUTR=CR2CBR(0,0,0) * DE_RHO(IX,IY,IZ,0,LTWCEN) * 2.0D0
     *               +CR2CBR(0,1,0) * DE_RHO(IX,IY,IZ,1,LTWCEN) * 2.0D0
     *               +CR3CBR(0,0,0) * DE_RHO(IX,IY,IZ,0,LTWCEN) * 2.0D0
     *               +CR3CBR(0,1,0) * DE_RHO(IX,IY,IZ,1,LTWCEN) * 2.0D0
C
               XPROTO=CR2CBR(1,1,0) * DE_RHO(IX,IY,IZ,1,LTWCEN) * 2.0D0
     *               +CR2CBR(0,1,0) * DE_RHO(IX,IY,IZ,0,LTWCEN) * 2.0D0
     *               +CR3CBR(1,1,0) * DE_RHO(IX,IY,IZ,1,LTWCEN) * 2.0D0
     *               +CR3CBR(0,1,0) * DE_RHO(IX,IY,IZ,0,LTWCEN) * 2.0D0
C
               VNEUTR = VNEUTR+XNEUTR
               VPROTO = VPROTO+XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.3))
C=======================================================================
C
               XTOTAL=CLPR_T*(DE_LPR(IX,IY,IZ,0,LTWCEN)
     *                       +DE_LPR(IX,IY,IZ,1,LTWCEN)) * 2.0D0
     *               +CTAU_T*(DE_TAU(IX,IY,IZ,0,LTWCEN)
     *                       +DE_TAU(IX,IY,IZ,1,LTWCEN))
C
               XNEUTR=CLPR_S* DE_LPR(IX,IY,IZ,0,LTWCEN)  * 2.0D0
     *               +CTAU_S* DE_TAU(IX,IY,IZ,0,LTWCEN)
C
               XPROTO=CLPR_S* DE_LPR(IX,IY,IZ,1,LTWCEN)  * 2.0D0
     *               +CTAU_S* DE_TAU(IX,IY,IZ,1,LTWCEN)
C
               VNEUTR = VNEUTR+XTOTAL+XNEUTR
               VPROTO = VPROTO+XTOTAL+XPROTO
C
C=======================================================================
C              AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
               XNEUTR=CL2CBR(0,0,0) * DE_LPR(IX,IY,IZ,0,LTWCEN) * 2.0D0
     *               +CL2CBR(0,1,0) * DE_LPR(IX,IY,IZ,1,LTWCEN) * 2.0D0
     *               +CL3CBR(0,0,0) * DE_LPR(IX,IY,IZ,0,LTWCEN) * 2.0D0
     *               +CL3CBR(0,1,0) * DE_LPR(IX,IY,IZ,1,LTWCEN) * 2.0D0
C
               XPROTO=CL2CBR(1,1,0) * DE_LPR(IX,IY,IZ,1,LTWCEN) * 2.0D0
     *               +CL2CBR(0,1,0) * DE_LPR(IX,IY,IZ,0,LTWCEN) * 2.0D0
     *               +CL3CBR(1,1,0) * DE_LPR(IX,IY,IZ,1,LTWCEN) * 2.0D0
     *               +CL3CBR(0,1,0) * DE_LPR(IX,IY,IZ,0,LTWCEN) * 2.0D0
C
               VNEUTR = VNEUTR+XNEUTR
               VPROTO = VPROTO+XPROTO
C
               XNEUTR=CT2CBR(0,0,0) * DE_TAU(IX,IY,IZ,0,LTWCEN)
     *               +CT2CBR(0,1,0) * DE_TAU(IX,IY,IZ,1,LTWCEN)
     *               +CT3CBR(0,0,0) * DE_TAU(IX,IY,IZ,0,LTWCEN)
     *               +CT3CBR(0,1,0) * DE_TAU(IX,IY,IZ,1,LTWCEN)
C
               XPROTO=CT2CBR(1,1,0) * DE_TAU(IX,IY,IZ,1,LTWCEN)
     *               +CT2CBR(0,1,0) * DE_TAU(IX,IY,IZ,0,LTWCEN)
     *               +CT3CBR(1,1,0) * DE_TAU(IX,IY,IZ,1,LTWCEN)
     *               +CT3CBR(0,1,0) * DE_TAU(IX,IY,IZ,0,LTWCEN)
C
               VNEUTR = VNEUTR+XNEUTR
               VPROTO = VPROTO+XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= T3) - (N O T E THAT THIS IS A DENSITY
C                                      DEPENDENT  TERM  REPLACING THE
C                                      ENGEL'S THREE BODY INTERACTION)
C=======================================================================
C
               XTOTAL=CRHODT*(DE_RHO(IX,IY,IZ,0,LTWCEN)
     *                       +DE_RHO(IX,IY,IZ,1,LTWCEN))*2.0D0 * DENPOW
C
               XNEUTR=CRHODS* DE_RHO(IX,IY,IZ,0,LTWCEN) *2.0D0 * DENPOW
               XPROTO=CRHODS* DE_RHO(IX,IY,IZ,1,LTWCEN) *2.0D0 * DENPOW
C
               VNEUTR = VNEUTR+XTOTAL+XNEUTR
               VPROTO = VPROTO+XTOTAL+XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= U0) - THREE BODY INTERACTION
C=======================================================================
C
               XNEUTR=3*THREEB*(DE_RHO(IX,IY,IZ,0,LTWCEN)*2
     *                         +DE_RHO(IX,IY,IZ,1,LTWCEN)) *DENPRO/4
     *               -3*THREEB*(DE_SPI(IX,IY,IZ,1,1,LTWCEN)*SPIPRO(1)
     *                         +DE_SPI(IX,IY,IZ,2,1,LTWCEN)*SPIPRO(2)
     *                         +DE_SPI(IX,IY,IZ,3,1,LTWCEN)*SPIPRO(3))/4
               XPROTO=3*THREEB*(DE_RHO(IX,IY,IZ,1,LTWCEN)*2
     *                         +DE_RHO(IX,IY,IZ,0,LTWCEN) )*DENNEU/4
     *               -3*THREEB*(DE_SPI(IX,IY,IZ,1,0,LTWCEN)*SPINEU(1)
     *                         +DE_SPI(IX,IY,IZ,2,0,LTWCEN)*SPINEU(2)
     *                         +DE_SPI(IX,IY,IZ,3,0,LTWCEN)*SPINEU(3))/4
C
               VNEUTR = VNEUTR+XNEUTR
               VPROTO = VPROTO+XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= V0) - FOUR BODY INTERACTION
C=======================================================================
C
               XNEUTR=3*FOURBD*DE_RHO(IX,IY,IZ,0,LTWCEN)*DENPRO**2/2
     *               -3*FOURBD*DE_RHO(IX,IY,IZ,0,LTWCEN)
     *                        *(SPIPRO(1)**2
     *                         +SPIPRO(2)**2
     *                         +SPIPRO(3)**2)/2
               XPROTO=3*FOURBD*DE_RHO(IX,IY,IZ,1,LTWCEN)*DENNEU**2/2
     *               -3*FOURBD*DE_RHO(IX,IY,IZ,1,LTWCEN)
     *                        *(SPINEU(1)**2
     *                         +SPINEU(2)**2
     *                         +SPINEU(3)**2)/2
C
               VNEUTR = VNEUTR+XNEUTR
               VPROTO = VPROTO+XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= COULOMB EXCHANGE)
C=======================================================================
C              ATTENTION ---> THE SKYRME FIELDS ARE IN THIS SUBROUTINE
C              CALCULATED WITHOUT THE  EXPONENTIAL  FACTOR. THEREFORE,
C              THE COULOMB EXCHANGE FIELD HAS TO BE EXPLICITLY DIVIDED
C              BY THE "EXPAUX"  ARRAY.
C=======================================================================
C
               XPROTO =  COULEX*COUSCA
     *                * (4.0D0/3.0D0) * DENCHC(IX,IY,IZ)**(1.0D0/3.0D0)
     *                                / EXPAUX(IX,IY,IZ,1)
C
               VPROTO = VPROTO+XPROTO
C
C=======================================================================
C              CALCULATING  THE  T3 - REARRANGEMENT  TERM
C=======================================================================
C
               IF (ITWCEN.EQ.1) THEN
C
                   IF (IADBLN.EQ.0) THEN
C
                       QUNRHO = DE_RHO(IX,IY,IZ,0,LTWCEN)*
     *                          DE_RHO(IX,IY,IZ,0,LTWCEN)
                       QUPRHO = DE_RHO(IX,IY,IZ,1,LTWCEN)*
     *                          DE_RHO(IX,IY,IZ,1,LTWCEN)
C
                       QUTRHO =(DE_RHO(IX,IY,IZ,0,LTWCEN)+
     *                          DE_RHO(IX,IY,IZ,1,LTWCEN))
     *                        *(DE_RHO(IX,IY,IZ,0,LTWCEN)+
     *                          DE_RHO(IX,IY,IZ,1,LTWCEN))
C
                   ELSE
C
                       QUNRHO = DE_RHO_SAV(IX,IY,IZ,0,LTWCEN)*
     *                          DE_RHO(IX,IY,IZ,0,LTWCEN)*2
                       QUPRHO = DE_RHO_SAV(IX,IY,IZ,1,LTWCEN)*
     *                          DE_RHO(IX,IY,IZ,1,LTWCEN)*2
C
                       QUTRHO =(DE_RHO_SAV(IX,IY,IZ,0,LTWCEN)+
     *                          DE_RHO_SAV(IX,IY,IZ,1,LTWCEN))
     *                        *(DE_RHO(IX,IY,IZ,0,LTWCEN)+
     *                          DE_RHO(IX,IY,IZ,1,LTWCEN))*2
C
                   ENDIF
C
                   QUNSPI = C_ZERO
                   QUPSPI = C_ZERO
                   QUTSPI = C_ZERO
C
                   DO K=1,NDKART
C
                      IF (IADBLN.EQ.0) THEN
C
                          QUNSPI=QUNSPI + DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                                   *DE_SPI(IX,IY,IZ,K,0,LTWCEN)
                          QUPSPI=QUPSPI + DE_SPI(IX,IY,IZ,K,1,LTWCEN)
     *                                   *DE_SPI(IX,IY,IZ,K,1,LTWCEN)
C
                          QUTSPI=QUTSPI +(DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                                   +DE_SPI(IX,IY,IZ,K,1,LTWCEN))
     *                                  *(DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                                   +DE_SPI(IX,IY,IZ,K,1,LTWCEN))
C
                      ELSE
C
                          QUNSPI=QUNSPI+DE_SPI_SAV(IX,IY,IZ,K,0,LTWCEN)
     *                                  *DE_SPI(IX,IY,IZ,K,0,LTWCEN)*2
                          QUPSPI=QUPSPI+DE_SPI_SAV(IX,IY,IZ,K,1,LTWCEN)
     *                                  *DE_SPI(IX,IY,IZ,K,1,LTWCEN)*2
C
                          QUTSPI=QUTSPI
     *                              +(DE_SPI_SAV(IX,IY,IZ,K,0,LTWCEN)
     *                               +DE_SPI_SAV(IX,IY,IZ,K,1,LTWCEN))
     *                              *(DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                               +DE_SPI(IX,IY,IZ,K,1,LTWCEN))*2
C
                      ENDIF
C
                   END DO
C
               ELSEIF (ITWCEN.EQ.2) THEN
C
                   QUNRHO = DE_RHO(IX,IY,IZ,0,LTWCEN)*
     *                      DDTRHO(IX,IY,IZ,LTWCEN,0)
                   QUPRHO = DE_RHO(IX,IY,IZ,1,LTWCEN)*
     *                      DDTRHO(IX,IY,IZ,LTWCEN,1)
C
                   QUTRHO =(DE_RHO(IX,IY,IZ,0,LTWCEN)+
     *                      DE_RHO(IX,IY,IZ,1,LTWCEN))
     *                    * DENSIC(IX,IY,IZ,  LTWCEN)
C
                   QUNSPI = C_ZERO
                   QUPSPI = C_ZERO
                   QUTSPI = C_ZERO
C
                   DO K=1,NDKART
C
                      QUNSPI=QUNSPI + DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                               *DDTSPI(IX,IY,IZ,K,LTWCEN,0)
                      QUPSPI=QUPSPI + DE_SPI(IX,IY,IZ,K,1,LTWCEN)
     *                               *DDTSPI(IX,IY,IZ,K,LTWCEN,1)
C
                      QUTSPI=QUTSPI +(DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                               +DE_SPI(IX,IY,IZ,K,1,LTWCEN))
     *                              *(DDTSPI(IX,IY,IZ,K,LTWCEN,0)
     *                               +DDTSPI(IX,IY,IZ,K,LTWCEN,1))
C
                   END DO
C
               END IF
C
               XTOTAL=(CRHODT*QUTRHO+CSPIDT*QUTSPI
     *               + CRHODS*QUNRHO+CSPIDS*QUNSPI
     *               + CRHODS*QUPRHO+CSPIDS*QUPSPI)*DENDER
C
               VNEUTR = VNEUTR+XTOTAL
               VPROTO = VPROTO+XTOTAL
C
C=======================================================================
C              CALCULATING THE NEUTRON-PROTON REARRANGEMENT TERM
C=======================================================================
C
               IF (IPNMIX.EQ.1) THEN
C
                   QUNRHO = DE_RHO(IX,IY,IZ,2,LTWCEN)*
     *                      DE_RHO(IX,IY,IZ,3,LTWCEN)*2
C
                   QUNSPI = C_ZERO
C
                   DO K=1,NDKART
C
                      QUNSPI=QUNSPI + DE_SPI(IX,IY,IZ,K,2,LTWCEN)
     *                               *DE_SPI(IX,IY,IZ,K,3,LTWCEN)*2
C
                   END DO
C
                   XTOTAL=(CRHODS*QUNRHO+CSPIDS*QUNSPI)*DENDER
C
                   VNEUTR = VNEUTR+XTOTAL
                   VPROTO = VPROTO+XTOTAL
C
               END IF
C
C=======================================================================
C              CALCULATING  THE  T3 - PAIRING REARRANGEMENT  TERM
C=======================================================================
C
               IF (ITWCEN.EQ.1) THEN
C
                   IF (IADBLN.EQ.0) THEN
C
                       QUNRHO = PD_RHO(IX,IY,IZ,0,LTWCEN)*
     *                          CONJG(PD_RHO(IX,IY,IZ,0,LTWCEN))
                       QUPRHO = PD_RHO(IX,IY,IZ,1,LTWCEN)*
     *                          CONJG(PD_RHO(IX,IY,IZ,1,LTWCEN))
C
                   ELSE
C
                       QUNRHO = PD_RHO_SAV(IX,IY,IZ,0,LTWCEN)*
     *                          CONJG(PD_RHO(IX,IY,IZ,0,LTWCEN))
     *                        + PD_RHO(IX,IY,IZ,0,LTWCEN)*
     *                          CONJG(PD_RHO_SAV(IX,IY,IZ,0,LTWCEN))
                       QUPRHO = PD_RHO_SAV(IX,IY,IZ,1,LTWCEN)*
     *                          CONJG(PD_RHO(IX,IY,IZ,1,LTWCEN))
     *                        + PD_RHO(IX,IY,IZ,1,LTWCEN)*
     *                          CONJG(PD_RHO_SAV(IX,IY,IZ,1,LTWCEN))
C
                   ENDIF
C
               ELSEIF (ITWCEN.EQ.2) THEN
C
                   QUNRHO = PD_RHO(IX,IY,IZ,0,LTWCEN)*
     *                      CONJG(PDTRHO(IX,IY,IZ,LTWCEN,0))
                   QUPRHO = PD_RHO(IX,IY,IZ,1,LTWCEN)*
     *                      CONJG(PDTRHO(IX,IY,IZ,LTWCEN,1))
C
               END IF
C
               XTOTAL=(PRHODN*QUNRHO*PAID_N
     *               + PRHODP*QUPRHO*PAID_P)/ 4
C
               VNEUTR = VNEUTR+XTOTAL
               VPROTO = VPROTO+XTOTAL
C
               XTOTAL=(PRHOD0*QUNRHO*PAID_S
     *               + PRHOD0*QUPRHO*PAID_S)/ 4
C
               VNEUTR = VNEUTR+XTOTAL
               VPROTO = VPROTO+XTOTAL
C
C=======================================================================
C              CENTRAL TERM  FROM  U0 - KAPPA_KAPPA_RHO  TERM
C=======================================================================
C
               XNEUTR = 3*THREEB*PAIPRO*
     *                  CONJG(PD_RHO(IX,IY,IZ,1,LTWCEN))/4
               XPROTO = 3*THREEB*PAINEU*
     *                  CONJG(PD_RHO(IX,IY,IZ,0,LTWCEN))/4
C
               VNEUTR = VNEUTR+XNEUTR
               VPROTO = VPROTO+XPROTO
C
C=======================================================================
C              CENTRAL TERM   FROM  V0 - KAPPA_KAPPA_RHO_RHO  TERM
C=======================================================================
C
               XNEUTR = 3*FOURBD*PAIPRO*CONJG(PD_RHO(IX,IY,IZ,1,LTWCEN))
     *                          *DENNEU/2
               XPROTO = 3*FOURBD*PAINEU*CONJG(PD_RHO(IX,IY,IZ,0,LTWCEN))
     *                          *DENPRO/2
C
               VNEUTR = VNEUTR+XNEUTR
               VPROTO = VPROTO+XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.3))
C=======================================================================
C
               XTOTAL=CDIV_T*(DE_DIV(IX,IY,IZ,0,LTWCEN)
     *                      + DE_DIV(IX,IY,IZ,1,LTWCEN))
C
               XNEUTR=CDIV_S* DE_DIV(IX,IY,IZ,0,LTWCEN)
               XPROTO=CDIV_S* DE_DIV(IX,IY,IZ,1,LTWCEN)
C
               VNEUTR = VNEUTR+XTOTAL+XNEUTR
               VPROTO = VPROTO+XTOTAL+XPROTO
C
               VE_CEN(IX,IY,IZ,0,LTWCEN) =
     *         VE_CEN(IX,IY,IZ,0,LTWCEN)*XOLDEV+XNEWEV*VNEUTR
               VE_CEN(IX,IY,IZ,1,LTWCEN) =
     *         VE_CEN(IX,IY,IZ,1,LTWCEN)*XOLDEV+XNEWEV*VPROTO
C
C=======================================================================
C              TENSOR TERM (<= TE-TO) - (SEE: PERLINSKA, EQ.(83B))
C              THE TWO TERMS DEPENDING ON "CSPT" IN (83b) ARE CAST
C              INTO THE TIME-ODD-EQUIVALENT OF (83D)
C=======================================================================
C
               QUNSPI = C_ZERO
               QUPSPI = C_ZERO
               QUTSPI = C_ZERO
C
               DO K=1,NDKART
C
                  QUNSPI=QUNSPI + DE_DES(IX,IY,IZ,K,K,0,LTWCEN)
                  QUPSPI=QUPSPI + DE_DES(IX,IY,IZ,K,K,1,LTWCEN)
C
                  QUTSPI=QUTSPI + DE_DES(IX,IY,IZ,K,K,0,LTWCEN)
     *                          + DE_DES(IX,IY,IZ,K,K,1,LTWCEN)
C
               END DO
C
               XTOTAL=CSPT_T* QUTSPI * 2.0D0
C
               XNEUTR=CSPT_S* QUNSPI * 2.0D0
               XPROTO=CSPT_S* QUPSPI * 2.0D0
C
               VNEUTR = XTOTAL+XNEUTR
               VPROTO = XTOTAL+XPROTO
C
               VE_SPT(IX,IY,IZ,0,LTWCEN) =
     *         VE_SPT(IX,IY,IZ,0,LTWCEN)*XOLDEV+XNEWEV*VNEUTR
               VE_SPT(IX,IY,IZ,1,LTWCEN) =
     *         VE_SPT(IX,IY,IZ,1,LTWCEN)*XOLDEV+XNEWEV*VPROTO
C
            END DO
         END DO
      END DO
C
      DO K=1,NDKART
C
         DO IZ=1,NZHERM
            DO IY=1,NYHERM
               DO IX=1,NXHERM
C
                  DENPOW=DENSIC(IX,IY,IZ,LTWCEN)**POWER
C
                  IF (IADBLN.EQ.0) THEN
C
                      DENNEU=DE_RHO(IX,IY,IZ,0,LTWCEN)*
     *                                                EXPAUX(IX,IY,IZ,1)
                      DENPRO=DE_RHO(IX,IY,IZ,1,LTWCEN)*
     *                                                EXPAUX(IX,IY,IZ,1)
C
                      SPINEU(1)=DE_SPI(IX,IY,IZ,1,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      SPIPRO(1)=DE_SPI(IX,IY,IZ,1,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                      SPINEU(2)=DE_SPI(IX,IY,IZ,2,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      SPIPRO(2)=DE_SPI(IX,IY,IZ,2,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                      SPINEU(3)=DE_SPI(IX,IY,IZ,3,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      SPIPRO(3)=DE_SPI(IX,IY,IZ,3,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                      PAINEU=   PD_RHO(IX,IY,IZ,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      PAIPRO=   PD_RHO(IX,IY,IZ,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                  ELSE
C
                      DENNEU=DE_RHO_SAV(IX,IY,IZ,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      DENPRO=DE_RHO_SAV(IX,IY,IZ,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                      SPINEU(1)=DE_SPI_SAV(IX,IY,IZ,1,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      SPIPRO(1)=DE_SPI_SAV(IX,IY,IZ,1,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                      SPINEU(2)=DE_SPI_SAV(IX,IY,IZ,2,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      SPIPRO(2)=DE_SPI_SAV(IX,IY,IZ,2,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                      SPINEU(3)=DE_SPI_SAV(IX,IY,IZ,3,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      SPIPRO(3)=DE_SPI_SAV(IX,IY,IZ,3,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                      PAINEU=   PD_RHO_SAV(IX,IY,IZ,0,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
                      PAIPRO=   PD_RHO_SAV(IX,IY,IZ,1,LTWCEN)
     *                                               *EXPAUX(IX,IY,IZ,1)
C
                  ENDIF
C
C=======================================================================
C              V  E  C  T  O  R    F  I  E  L  D  S    F O L L O W
C=======================================================================
C
C=======================================================================
C                 CURRENT TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.5))
C=======================================================================
C
                  XTOTAL=+CCUR_T*(DE_CUR(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_CUR(IX,IY,IZ,K,1,LTWCEN)) * 2.0D0
C
                  XNEUTR=+CCUR_S* DE_CUR(IX,IY,IZ,K,0,LTWCEN)  * 2.0D0
                  XPROTO=+CCUR_S* DE_CUR(IX,IY,IZ,K,1,LTWCEN)  * 2.0D0
C
                  VNEUTR=XTOTAL+XNEUTR
                  VPROTO=XTOTAL+XPROTO
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                  XNEUTR=CC2CBR(0,0,0)*DE_CUR(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CC2CBR(0,1,0)*DE_CUR(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CC3CBR(0,0,0)*DE_CUR(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CC3CBR(0,1,0)*DE_CUR(IX,IY,IZ,K,1,LTWCEN)*2.0D0
C
                  XPROTO=CC2CBR(1,1,0)*DE_CUR(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CC2CBR(0,1,0)*DE_CUR(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CC3CBR(1,1,0)*DE_CUR(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CC3CBR(0,1,0)*DE_CUR(IX,IY,IZ,K,0,LTWCEN)*2.0D0
C
                  VNEUTR = VNEUTR+XNEUTR
                  VPROTO = VPROTO+XPROTO
C
C=======================================================================
C                 CURRENT TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.5))
C=======================================================================
C
                  XTOTAL=+CROT_T*(DE_ROS(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_ROS(IX,IY,IZ,K,1,LTWCEN))
C
                  XNEUTR=+CROT_S* DE_ROS(IX,IY,IZ,K,0,LTWCEN)
                  XPROTO=+CROT_S* DE_ROS(IX,IY,IZ,K,1,LTWCEN)
C
                  VNEUTR=VNEUTR+XTOTAL+XNEUTR
                  VPROTO=VPROTO+XTOTAL+XPROTO
C
                  VE_CUR(IX,IY,IZ,K,0,LTWCEN)=
     *            VE_CUR(IX,IY,IZ,K,0,LTWCEN)*XOLDOD + VNEUTR * XNEWOD
                  VE_CUR(IX,IY,IZ,K,1,LTWCEN)=
     *            VE_CUR(IX,IY,IZ,K,1,LTWCEN)*XOLDOD + VPROTO * XNEWOD
C
C=======================================================================
C                 KINET.SPIN TERM (<= T1-T2) - (SEE: ENGEL ET AL, (B.6))
C=======================================================================
C
                  XTOTAL=+CKIS_T*(DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_SPI(IX,IY,IZ,K,1,LTWCEN))
C
                  XNEUTR=+CKIS_S* DE_SPI(IX,IY,IZ,K,0,LTWCEN)
                  XPROTO=+CKIS_S* DE_SPI(IX,IY,IZ,K,1,LTWCEN)
C
                  VNEUTR=XTOTAL+XNEUTR
                  VPROTO=XTOTAL+XPROTO
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                  XNEUTR=CK2CBR(0,0,0) * DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                  +CK2CBR(0,1,0) * DE_SPI(IX,IY,IZ,K,1,LTWCEN)
     *                  +CK3CBR(0,0,0) * DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                  +CK3CBR(0,1,0) * DE_SPI(IX,IY,IZ,K,1,LTWCEN)
C
                  XPROTO=CK2CBR(1,1,0) * DE_SPI(IX,IY,IZ,K,1,LTWCEN)
     *                  +CK2CBR(0,1,0) * DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                  +CK3CBR(1,1,0) * DE_SPI(IX,IY,IZ,K,1,LTWCEN)
     *                  +CK3CBR(0,1,0) * DE_SPI(IX,IY,IZ,K,0,LTWCEN)
C
                  VNEUTR = VNEUTR+XNEUTR
                  VPROTO = VPROTO+XPROTO
C
                  VE_KIS(IX,IY,IZ,K,0,LTWCEN)=
     *            VE_KIS(IX,IY,IZ,K,0,LTWCEN) * XOLDOD + VNEUTR * XNEWOD
                  VE_KIS(IX,IY,IZ,K,1,LTWCEN)=
     *            VE_KIS(IX,IY,IZ,K,1,LTWCEN) * XOLDOD + VPROTO * XNEWOD
C
C=======================================================================
C                 TENSOR.SPIN TERM (<=TE-TO) - (SEE: PERLINSKA,   (83G))
C=======================================================================
C
                  XTOTAL=+CKIT_T*(DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_SPI(IX,IY,IZ,K,1,LTWCEN))
C
                  XNEUTR=+CKIT_S* DE_SPI(IX,IY,IZ,K,0,LTWCEN)
                  XPROTO=+CKIT_S* DE_SPI(IX,IY,IZ,K,1,LTWCEN)
C
                  VNEUTR=XTOTAL+XNEUTR
                  VPROTO=XTOTAL+XPROTO
C
                  VE_KIT(IX,IY,IZ,K,0,LTWCEN)=
     *            VE_KIT(IX,IY,IZ,K,0,LTWCEN) * XOLDOD + VNEUTR * XNEWOD
                  VE_KIT(IX,IY,IZ,K,1,LTWCEN)=
     *            VE_KIT(IX,IY,IZ,K,1,LTWCEN) * XOLDOD + VPROTO * XNEWOD
C
C=======================================================================
C                 SPIN TERM (<= T0) - (SEE: ENGEL ET AL, EQ.(B.7))
C=======================================================================
C
                  XTOTAL=+CSPI_T*(DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_SPI(IX,IY,IZ,K,1,LTWCEN)) * 2.0D0
C
                  XNEUTR=+CSPI_S* DE_SPI(IX,IY,IZ,K,0,LTWCEN)  * 2.0D0
                  XPROTO=+CSPI_S* DE_SPI(IX,IY,IZ,K,1,LTWCEN)  * 2.0D0
C
                  VNEUTR=XTOTAL+XNEUTR
                  VPROTO=XTOTAL+XPROTO
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                  XNEUTR=CS2CBR(0,0,0)*DE_SPI(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CS2CBR(0,1,0)*DE_SPI(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CS3CBR(0,0,0)*DE_SPI(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CS3CBR(0,1,0)*DE_SPI(IX,IY,IZ,K,1,LTWCEN)*2.0D0
C
                  XPROTO=CS2CBR(1,1,0)*DE_SPI(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CS2CBR(0,1,0)*DE_SPI(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CS3CBR(1,1,0)*DE_SPI(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CS3CBR(0,1,0)*DE_SPI(IX,IY,IZ,K,0,LTWCEN)*2.0D0
C
                  VNEUTR = VNEUTR+XNEUTR
                  VPROTO = VPROTO+XPROTO
C
C=======================================================================
C                 SPIN TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.7))
C                 SPIN TERM (<= TE-TO) - (SEE: PERLINSKA,   EQ.(83B))
C=======================================================================
C
                  XTOTAL=+CKIS_T*(DE_KIS(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_KIS(IX,IY,IZ,K,1,LTWCEN))
     *                   +CKIT_T*(DE_KIF(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_KIF(IX,IY,IZ,K,1,LTWCEN))
     *                   +CLPS_T*(DE_LPS(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_LPS(IX,IY,IZ,K,1,LTWCEN)) * 2.0D0
C
                  XNEUTR=+CKIS_S* DE_KIS(IX,IY,IZ,K,0,LTWCEN)
     *                   +CKIT_S* DE_KIF(IX,IY,IZ,K,0,LTWCEN)
     *                   +CLPS_S* DE_LPS(IX,IY,IZ,K,0,LTWCEN)  * 2.0D0
C
                  XPROTO=+CKIS_S* DE_KIS(IX,IY,IZ,K,1,LTWCEN)
     *                   +CKIT_S* DE_KIF(IX,IY,IZ,K,1,LTWCEN)
     *                   +CLPS_S* DE_LPS(IX,IY,IZ,K,1,LTWCEN)  * 2.0D0
C
                  VNEUTR=VNEUTR+XTOTAL+XNEUTR
                  VPROTO=VPROTO+XTOTAL+XPROTO
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                  XNEUTR=CK2CBR(0,0,0) * DE_KIS(IX,IY,IZ,K,0,LTWCEN)
     *                  +CK2CBR(0,1,0) * DE_KIS(IX,IY,IZ,K,1,LTWCEN)
     *                  +CK3CBR(0,0,0) * DE_KIS(IX,IY,IZ,K,0,LTWCEN)
     *                  +CK3CBR(0,1,0) * DE_KIS(IX,IY,IZ,K,1,LTWCEN)
C
                  XPROTO=CK2CBR(1,1,0) * DE_KIS(IX,IY,IZ,K,1,LTWCEN)
     *                  +CK2CBR(0,1,0) * DE_KIS(IX,IY,IZ,K,0,LTWCEN)
     *                  +CK3CBR(1,1,0) * DE_KIS(IX,IY,IZ,K,1,LTWCEN)
     *                  +CK3CBR(0,1,0) * DE_KIS(IX,IY,IZ,K,0,LTWCEN)
C
                  VNEUTR = VNEUTR+XNEUTR
                  VPROTO = VPROTO+XPROTO
C
C
                  XNEUTR=CP2CBR(0,0,0)*DE_LPS(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CP2CBR(0,1,0)*DE_LPS(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CP3CBR(0,0,0)*DE_LPS(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CP3CBR(0,1,0)*DE_LPS(IX,IY,IZ,K,1,LTWCEN)*2.0D0
C
                  XPROTO=CP2CBR(1,1,0)*DE_LPS(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CP2CBR(0,1,0)*DE_LPS(IX,IY,IZ,K,0,LTWCEN)*2.0D0
     *                  +CP3CBR(1,1,0)*DE_LPS(IX,IY,IZ,K,1,LTWCEN)*2.0D0
     *                  +CP3CBR(0,1,0)*DE_LPS(IX,IY,IZ,K,0,LTWCEN)*2.0D0
C
                  VNEUTR = VNEUTR+XNEUTR
                  VPROTO = VPROTO+XPROTO
C
C=======================================================================
C                 SPIN TERM (<= T3) - (N O T E THAT THIS IS A DENSITY
C                                      DEPENDENT  TERM  REPLACING THE
C                                      ENGEL'S THREE BODY INTERACTION)
C=======================================================================
C
                  XTOTAL=+CSPIDT*(DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_SPI(IX,IY,IZ,K,1,LTWCEN))* 2.0D0
     *                                                        * DENPOW
C
                  XNEUTR=+CSPIDS* DE_SPI(IX,IY,IZ,K,0,LTWCEN) * 2.0D0
     *                                                        * DENPOW
                  XPROTO=+CSPIDS* DE_SPI(IX,IY,IZ,K,1,LTWCEN) * 2.0D0
     *                                                        * DENPOW
C
                  VNEUTR=VNEUTR+XTOTAL+XNEUTR
                  VPROTO=VPROTO+XTOTAL+XPROTO
C
C=======================================================================
C                 SPIN TERM (<= U0) - THREE BODY INTERACTION
C=======================================================================
C
                  XNEUTR=-3*THREEB*DE_SPI(IX,IY,IZ,K,0,LTWCEN)*DENPRO/2
                  XPROTO=-3*THREEB*DE_SPI(IX,IY,IZ,K,1,LTWCEN)*DENNEU/2
C
                  VNEUTR=VNEUTR+XNEUTR
                  VPROTO=VPROTO+XPROTO
C
C=======================================================================
C                 SPIN TERM (<= V0) - 4-BODY RHO_RHO_RHO_RHO
C=======================================================================
C
                  XNEUTR=-3*FOURBD*DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                                           *DENPRO**2 /2
     *                   +3*FOURBD*DE_SPI(IX,IY,IZ,K,0,LTWCEN)
     *                            *(SPIPRO(1)**2
     *                             +SPIPRO(2)**2
     *                             +SPIPRO(3)**2 )/2
                  XPROTO=-3*FOURBD*DE_SPI(IX,IY,IZ,K,1,LTWCEN)
     *                                           *DENNEU**2 /2
     *                   +3*FOURBD*DE_SPI(IX,IY,IZ,K,1,LTWCEN)
     *                            *(SPINEU(1)**2
     *                             +SPINEU(2)**2
     *                             +SPINEU(3)**2 )/2
C
                  VNEUTR=VNEUTR+XNEUTR
                  VPROTO=VPROTO+XPROTO
C
C=======================================================================
C                 SPIN TERM  FROM  V0 - KAPPA_KAPPA_RHO_RHO  TERM
C=======================================================================
C
                  XNEUTR = -3*FOURBD*PAIPRO *
     *                      CONJG(PD_RHO(IX,IY,IZ,1,LTWCEN))*SPINEU(K)/2
                  XPROTO = -3*FOURBD*PAINEU *
     *                      CONJG(PD_RHO(IX,IY,IZ,0,LTWCEN))*SPIPRO(K)/2
C
                  VNEUTR = VNEUTR+XNEUTR
                  VPROTO = VPROTO+XPROTO
C
C=======================================================================
C                 SPIN TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.7))
C=======================================================================
C
                  XTOTAL=+CROT_T*(DE_ROC(IX,IY,IZ,K,0,LTWCEN)
     *                           +DE_ROC(IX,IY,IZ,K,1,LTWCEN))
C
                  XNEUTR=+CROT_S* DE_ROC(IX,IY,IZ,K,0,LTWCEN)
                  XPROTO=+CROT_S* DE_ROC(IX,IY,IZ,K,1,LTWCEN)
C
                  VNEUTR=VNEUTR+XTOTAL+XNEUTR
                  VPROTO=VPROTO+XTOTAL+XPROTO
C
                  VE_SPI(IX,IY,IZ,K,0,LTWCEN)=
     *            VE_SPI(IX,IY,IZ,K,0,LTWCEN) * XOLDOD + VNEUTR * XNEWOD
                  VE_SPI(IX,IY,IZ,K,1,LTWCEN)=
     *            VE_SPI(IX,IY,IZ,K,1,LTWCEN) * XOLDOD + VPROTO * XNEWOD
C
C=======================================================================
C                 S.O. TERM (<= W0) - AUXILIARY FIELD
C=======================================================================
C
                  XTOTAL =-CDIV_T*(DE_GRR(IX,IY,IZ,K,0,LTWCEN)
     *                           + DE_GRR(IX,IY,IZ,K,1,LTWCEN))
C
                  XNEUTR =-CDIV_S* DE_GRR(IX,IY,IZ,K,0,LTWCEN)
                  XPROTO =-CDIV_S* DE_GRR(IX,IY,IZ,K,1,LTWCEN)
C
                  ANEUTR(IX,IY,IZ,K)=XTOTAL+XNEUTR
                  APROTO(IX,IY,IZ,K)=XTOTAL+XPROTO
C
               END DO
            END DO
         END DO
C
      END DO
C
      DO L=1,NDKART
         DO K=1,NDKART
C
            DO IZ=1,NZHERM
               DO IY=1,NYHERM
                  DO IX=1,NXHERM
C
C=======================================================================
C                 T  E  N  S  O  R    F  I  E  L  D    F O L L O W S
C=======================================================================
C
C=======================================================================
C                 S.O. TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.4))
C=======================================================================
C
                     XTOTAL=+CSCU_T*(DE_SCU(IX,IY,IZ,K,L,0,LTWCEN)
     *                              +DE_SCU(IX,IY,IZ,K,L,1,LTWCEN))
     *                                                       *2.0D0
C
                     XNEUTR=+CSCU_S* DE_SCU(IX,IY,IZ,K,L,0,LTWCEN)*2.0D0
                     XPROTO=+CSCU_S* DE_SCU(IX,IY,IZ,K,L,1,LTWCEN)*2.0D0
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                     XNEUTR=XNEUTR
     *                +CJ2CBR(0,0,0)*DE_SCU(IX,IY,IZ,K,L,0,LTWCEN)*2.0D0
     *                +CJ2CBR(0,1,0)*DE_SCU(IX,IY,IZ,K,L,1,LTWCEN)*2.0D0
     *                +CJ3CBR(0,0,0)*DE_SCU(IX,IY,IZ,K,L,0,LTWCEN)*2.0D0
     *                +CJ3CBR(0,1,0)*DE_SCU(IX,IY,IZ,K,L,1,LTWCEN)*2.0D0
C
                     XPROTO=XPROTO
     *                +CJ2CBR(1,1,0)*DE_SCU(IX,IY,IZ,K,L,1,LTWCEN)*2.0D0
     *                +CJ2CBR(0,1,0)*DE_SCU(IX,IY,IZ,K,L,0,LTWCEN)*2.0D0
     *                +CJ3CBR(1,1,0)*DE_SCU(IX,IY,IZ,K,L,1,LTWCEN)*2.0D0
     *                +CJ3CBR(0,1,0)*DE_SCU(IX,IY,IZ,K,L,0,LTWCEN)*2.0D0
C
C=======================================================================
C                 F TERM
C                 (SEE: PERLINSKA ET AL, EQ.(47d,83d))
CBaczykKonieczka - OMMITING MULTIPLIER *2.0D0
C                  deduced from comparison of 47b and 47d Perlinska
C TODO write switch to non-standard treatment KETA_J
C TODO mixed pn term to add
C=======================================================================
C TRANSPOSE J
                     XTOTAL=XTOTAL
     *                     +CSCT_T*(DE_SCU(IX,IY,IZ,L,K,0,LTWCEN)
     *                            + DE_SCU(IX,IY,IZ,L,K,1,LTWCEN))
C
                     XNEUTR=XNEUTR
     *                     +CSCT_S* DE_SCU(IX,IY,IZ,L,K,0,LTWCEN)
                     XPROTO=XPROTO
     *                     +CSCT_S* DE_SCU(IX,IY,IZ,L,K,1,LTWCEN)
C
                     IF (K.EQ.L) THEN
C CALCULATING TRACE OF SPIN CURRENT PSEUDOTENSOR DENSITY
C TODO MOVE TO ANOTHER PLACE
                        TRJNEU = C_ZERO
                        TRJPRO = C_ZERO
                        TRJTOT = C_ZERO
                        DO IDX=1,NDKART
                           TRJNEU = TRJNEU+
     *                              DE_SCU(IX,IY,IZ,IDX,IDX,0,LTWCEN)
                           TRJPRO = TRJPRO+
     *                              DE_SCU(IX,IY,IZ,IDX,IDX,1,LTWCEN)
                        END DO
                        TRJTOT = TRJPRO + TRJNEU
C
                        XTOTAL=XTOTAL+CSCT_T*TRJTOT
                        XNEUTR=XNEUTR+CSCT_S*TRJNEU
                        XPROTO=XPROTO+CSCT_S*TRJPRO
                     END IF
C
                     VNEUTR=XTOTAL+XNEUTR
                     VPROTO=XTOTAL+XPROTO
C
C=======================================================================
C                 S.O. TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.4))
C=======================================================================
C
                     VNEUTR=VNEUTR+                ISIEPS(K,L)
     *                            *ANEUTR(IX,IY,IZ,INDEPS(K,L))
                     VPROTO=VPROTO+                ISIEPS(K,L)
     *                            *APROTO(IX,IY,IZ,INDEPS(K,L))
C
                     VE_SOR(IX,IY,IZ,K,L,0,LTWCEN)=
     *               VE_SOR(IX,IY,IZ,K,L,0,LTWCEN)*XOLDEV+VNEUTR*XNEWEV
                     VE_SOR(IX,IY,IZ,K,L,1,LTWCEN)=
     *               VE_SOR(IX,IY,IZ,K,L,1,LTWCEN)*XOLDEV+VPROTO*XNEWEV
C
                  END DO
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
      DEALLOCATE(ANEUTR,APROTO)
C=======================================================================
C
      CALL CPUTIM('SKFILD',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SKFINP(XOLDEV,XOLDOD,LDPNMX)
C=======================================================================
      USE HE_DEN
      USE PD_DEN
      USE VE_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          ANE_PR
      COMPLEX
     *          XNE_PR,VNE_PR
      COMPLEX
     *          DENSIC,DENCHC
      COMPLEX
     *          DENPOW
C
      DIMENSION
     *          ISIEPS(NDKART,NDKART),INDEPS(NDKART,NDKART)
C
C=======================================================================
      ALLOCATABLE ANE_PR(:,:,:,:)
C=======================================================================
C
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /CCPSKY/ CRHO_T,CRHO_S,CRHODT,CRHODS,
     *                CLPR_T,CLPR_S,
     *                CTAU_T,CTAU_S,
     *                CSCU_T,CSCU_S,
     *                CDIV_T,CDIV_S,
     *                CSPI_T,CSPI_S,CSPIDT,CSPIDS,
     *                CLPS_T,CLPS_S,
     *                CCUR_T,CCUR_S,
     *                CKIS_T,CKIS_S,
     *                CROT_T,CROT_S,
     *                CSCT_T,CSCT_S,
     *                CKIT_T,CKIT_S,
     *                CSPT_T,CSPT_S
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /INTSKY/ T0,X0,T1,X1,T2,X2,T3,X3,W0,POWER
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMAT/ NOIINP,MIXMAT
      COMMON
     *       /EDFPAR/ V0NEFF,V0PEFF,COUSCA
      COMMON
     *       /CC2CBR/ CR2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CS2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CT2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CK2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CL2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CP2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CC2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CJ2CBR(0:NDISOS,0:NDISOS,0:1)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THE FOLLOWING CONSTRUCTION ALLOWS US TO CALCULATE  CONTRACTIONS
C        WITH THE TOTALLY ANTISYMMETRIC LEVY-CIVITTA TENSOR.
C
C        INDEPS CONTAINS  THE  THIRD  INDEX  FOR  THE  FIRST  TWO GIVEN.
C               (IN  CASE  OF  EQUAL  FIRST  INDICES IT CONTAINS A DUMMY
C                NON-ZERO INDEX VALUE TO AVOID CALLING  MATRIX  ELEMENTS
C                OUTSIDE THE   D E C L A R E D   F O R T R A N   BOUNDS)
C        ISIEPS CONTAINS THE SIGN OF THE TENSOR (+1 OR -1) FOR THE FIRST
C               TWO GIVEN INDICES.
C               (IN  CASE  OF  EQUAL  FIRST  INDICES IT CONTAINS A ZERO.
C                IN  THIS  WAY  THE  INDEX IN INDEPS IS THEN IMMATERIAL)
C=======================================================================
C
      DATA   ISIEPS /  0, -1, +1,
     *                +1,  0, -1,
     *                -1, +1,  0/
C
      DATA   INDEPS /  1,  3,  2,
     *                 3,  2,  1,
     *                 2,  1,  3/
C
C=======================================================================
C
      CALL CPUTIM('SKFINP',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE NEUTRON-PROTON SKYRME FIELDS
C=======================================================================
C
C        THE EFFECTIVE COUPLING CONSTANTS ARE CODED AS:
C                      'C'//'XXX'//'N'//'TYP'
C
C        WHERE THE SYMBOLS:  'C', 'XXX', 'N', AND 'TYP'
C        ARE EXPLAINED IN THE SUBROUTINE "ESKYRM"
C
C=======================================================================
C
C        THE CODING IS BASED ON SUBROUTINE "SKFILD" AND THE FOLLOWING
C        DERIVATIONS:
C
C        1. THE ISOVECTOR TERMS IN THE EDF READ:
C           CXXX_M * ((DNN-DPP)*(TNN-TPP)+2*DNP*TPN+2*DPN*TNP)
C           WHERE: CXXX_M ARE THE ISOVECTOR CC'S EQUAL CXXX_S/2
C                  DNN AND TNN ARE THE NEUTRON-NEUTRON DENSITIES
C                  DPP AND TPP ARE THE  PROTON-PROTON  DENSITIES
C                  DNP AND TNP ARE THE NEUTRON-PROTON  DENSITIES
C                  DPN AND TPN ARE THE  PROTON-NEUTRON DENSITIES
C        2. THE NEUTRON-PROTON MEAN FIELDS READ:
C           CXXX_S * ( DNP * T + TNP * D)
C           WHERE  T  AND  D  ARE OPERATORS RELATED TO VARIATIONS OF
C                  THE TXX AND DXX DENSITIES
C
C=======================================================================
C
      IF (LDPNMX.LT.2)
     *    STOP ' LDPNMX > 1 REQUIRED IN SKFINP'
C
C=======================================================================
C
      XNEWOD=1.00D0-XOLDOD
      XNEWEV=1.00D0-XOLDEV
C
C=======================================================================
C
      ALLOCATE(ANE_PR(NDXHRM,NDYHRM,NDZHRM,NDKART))
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               DENPOW=DENSIC(IX,IY,IZ,1)**POWER
C
C=======================================================================
C              S  C  A  L  A  R     F I E L D S     F O L L O W
C=======================================================================
C              EFFECTIVE MASS TERM (SEE: ENGEL ET AL, EQ.(B.2))
C=======================================================================
C
               XNE_PR=CTAU_S* DE_RHO(IX,IY,IZ,2,1)
C
               VNE_PR=XNE_PR
C
C=======================================================================
C              AS ABOVE BUT FROM CHARGE SYMMETRY BREAKING FORCES
C=======================================================================
C
               XNE_PR=CT2CBR(0,1,1) * DE_RHO(IX,IY,IZ,2,1)
     *               +CT2CBR(1,1,1) * DE_RHO(IX,IY,IZ,3,1)
C
               VNE_PR = VNE_PR+XNE_PR
C
               VE_MAS(IX,IY,IZ,2,1) =
     *         VE_MAS(IX,IY,IZ,2,1)*XOLDEV+XNEWEV*VNE_PR
C
C=======================================================================
C=======================================================================
C              CENTRAL TERM (<= T0) - (SEE: ENGEL ET AL, EQ.(B.3))
C=======================================================================
C
               XNE_PR=CRHO_S* DE_RHO(IX,IY,IZ,2,1)  * 2.0D0
C
               VNE_PR = XNE_PR
C
C=======================================================================
C              AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
               XNE_PR=CR2CBR(0,1,1) * DE_RHO(IX,IY,IZ,2,1) * 2.0D0
     *               +CR2CBR(1,1,1) * DE_RHO(IX,IY,IZ,3,1) * 2.0D0
C
               VNE_PR = VNE_PR+XNE_PR
C
C=======================================================================
C              CENTRAL TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.3))
C=======================================================================
C
               XNE_PR=CLPR_S* DE_LPR(IX,IY,IZ,2,1)  * 2.0D0
     *               +CTAU_S* DE_TAU(IX,IY,IZ,2,1)
C
               VNE_PR = VNE_PR+XNE_PR
C
C=======================================================================
C              AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
               XNE_PR=CL2CBR(0,1,1) * DE_LPR(IX,IY,IZ,2,1) * 2.0D0
     *               +CL2CBR(1,1,1) * DE_LPR(IX,IY,IZ,3,1) * 2.0D0
C
               VNE_PR = VNE_PR+XNE_PR
C
C
               XNE_PR=CT2CBR(0,1,1) * DE_TAU(IX,IY,IZ,2,1)
     *               +CT2CBR(1,1,1) * DE_TAU(IX,IY,IZ,3,1)
C
               VNE_PR = VNE_PR+XNE_PR
C
C=======================================================================
C              CENTRAL TERM (<= T3) - (N O T E THAT THIS IS A DENSITY
C                                      DEPENDENT  TERM  REPLACING THE
C                                      ENGEL'S THREE BODY INTERACTION)
C=======================================================================
C
               XNE_PR=CRHODS* DE_RHO(IX,IY,IZ,2,1)  * 2.0D0 * DENPOW
C
               VNE_PR = VNE_PR+XNE_PR
C
C=======================================================================
C              CENTRAL TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.3))
C=======================================================================
C
               XNE_PR=CDIV_S* DE_DIV(IX,IY,IZ,2,1)
C
               VNE_PR = VNE_PR+XNE_PR
C
               VE_CEN(IX,IY,IZ,2,1) =
     *         VE_CEN(IX,IY,IZ,2,1)*XOLDEV+XNEWEV*VNE_PR
C
            END DO
         END DO
      END DO
C
      DO K=1,NDKART
C
         DO IZ=1,NZHERM
            DO IY=1,NYHERM
               DO IX=1,NXHERM
C
                  DENPOW=DENSIC(IX,IY,IZ,1)**POWER
C
C=======================================================================
C              V  E  C  T  O  R    F  I  E  L  D  S    F O L L O W
C=======================================================================
C
C=======================================================================
C                 CURRENT TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.5))
C=======================================================================
C
                  XNE_PR=+CCUR_S* DE_CUR(IX,IY,IZ,K,2,1)  * 2.0D0
C
                  VNE_PR=XNE_PR
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                  XNE_PR=CC2CBR(0,1,1) * DE_CUR(IX,IY,IZ,K,2,1) * 2.0D0
     *                  +CC2CBR(1,1,1) * DE_CUR(IX,IY,IZ,K,3,1) * 2.0D0
C
                  VNE_PR=VNE_PR+XNE_PR
C
C=======================================================================
C                 CURRENT TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.5))
C=======================================================================
C
                  XNE_PR=+CROT_S* DE_ROS(IX,IY,IZ,K,2,1)
C
                  VNE_PR=VNE_PR+XNE_PR
C
                  VE_CUR(IX,IY,IZ,K,2,1)=
     *            VE_CUR(IX,IY,IZ,K,2,1) * XOLDOD + VNE_PR * XNEWOD
C
C=======================================================================
C                 KINET.SPIN TERM (<= T1-T2) - (SEE: ENGEL ET AL, (B.6))
C=======================================================================
C
                  XNE_PR=+CKIS_S* DE_SPI(IX,IY,IZ,K,2,1)
C
                  VNE_PR=XNE_PR
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                  XNE_PR=CK2CBR(0,1,1) * DE_SPI(IX,IY,IZ,K,2,1)
     *                  +CK2CBR(1,1,1) * DE_SPI(IX,IY,IZ,K,3,1)
C
                  VNE_PR=VNE_PR+XNE_PR
C
                  VE_KIS(IX,IY,IZ,K,2,1)=VE_KIS(IX,IY,IZ,K,2,1)*XOLDOD
     *                                +VNE_PR              *XNEWOD
C
C=======================================================================
C                 SPIN TERM (<= T0) - (SEE: ENGEL ET AL, EQ.(B.7))
C=======================================================================
C
                  XNE_PR=+CSPI_S* DE_SPI(IX,IY,IZ,K,2,1)  * 2.0D0
C
                  VNE_PR=XNE_PR
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                  XNE_PR=CS2CBR(0,1,1) * DE_SPI(IX,IY,IZ,K,2,1) * 2.0D0
     *                  +CS2CBR(1,1,1) * DE_SPI(IX,IY,IZ,K,3,1) * 2.0D0
C
                  VNE_PR=VNE_PR+XNE_PR
C
C=======================================================================
C                 SPIN TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.7))
C=======================================================================
C
                  XNE_PR=+CKIS_S* DE_KIS(IX,IY,IZ,K,2,1)
     *                   +CLPS_S* DE_LPS(IX,IY,IZ,K,2,1)  * 2.0D0
C
                  VNE_PR=VNE_PR+XNE_PR
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                  XNE_PR=CK2CBR(0,1,1) * DE_KIS(IX,IY,IZ,K,2,1)
     *                  +CK2CBR(1,1,1) * DE_KIS(IX,IY,IZ,K,3,1)
C
                  VNE_PR=VNE_PR+XNE_PR
C
C
                  XNE_PR=CP2CBR(0,1,1) * DE_LPS(IX,IY,IZ,K,2,1) * 2.0D0
     *                  +CP2CBR(1,1,1) * DE_LPS(IX,IY,IZ,K,3,1) * 2.0D0
C
                  VNE_PR=VNE_PR+XNE_PR
C
C=======================================================================
C                 SPIN TERM (<= T3) - (N O T E THAT THIS IS A DENSITY
C                                      DEPENDENT  TERM  REPLACING THE
C                                      ENGEL'S THREE BODY INTERACTION)
C=======================================================================
C
                  XNE_PR=+CSPIDS*DE_SPI(IX,IY,IZ,K,2,1) * 2.0D0 * DENPOW
C
                  VNE_PR=VNE_PR+XNE_PR
C
C=======================================================================
C                 SPIN TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.7))
C=======================================================================
C
                  XNE_PR=+CROT_S* DE_ROC(IX,IY,IZ,K,2,1)
C
                  VNE_PR=VNE_PR+XNE_PR
C
                  VE_SPI(IX,IY,IZ,K,2,1)=
     *            VE_SPI(IX,IY,IZ,K,2,1)*XOLDOD + VNE_PR*XNEWOD
C
C=======================================================================
C                 S.O. TERM (<= W0) - AUXILIARY FIELD
C=======================================================================
C
                  XNE_PR =-CDIV_S* DE_GRR(IX,IY,IZ,K,2,1)
C
                  ANE_PR(IX,IY,IZ,K)=XNE_PR
C
               END DO
            END DO
         END DO
C
      END DO
C
      DO L=1,NDKART
         DO K=1,NDKART
C
            DO IZ=1,NZHERM
               DO IY=1,NYHERM
                  DO IX=1,NXHERM
C
C=======================================================================
C                 T  E  N  S  O  R    F  I  E  L  D    F O L L O W S
C=======================================================================
C
C=======================================================================
C                 S.O. TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.4))
C=======================================================================
C
                     XNE_PR=+CSCU_S* DE_SCU(IX,IY,IZ,K,L,2,1) *2.0D0
C
                     VNE_PR=XNE_PR
C
C=======================================================================
C                 AS ABOVE BUT FROM THE CHARGE-SYMMETRY-BREAKING TERMS
C=======================================================================
C
                     XNE_PR=
     *                 CJ2CBR(0,1,1) * DE_SCU(IX,IY,IZ,K,L,2,1) * 2.0D0
     *                +CJ2CBR(1,1,1) * DE_SCU(IX,IY,IZ,K,L,3,1) * 2.0D0
C
                     VNE_PR=VNE_PR+XNE_PR
C
C=======================================================================
C                 S.O. TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.4))
C=======================================================================
C
                     VNE_PR=VNE_PR+                ISIEPS(K,L)
     *                            *ANE_PR(IX,IY,IZ,INDEPS(K,L))
C
                     VE_SOR(IX,IY,IZ,K,L,2,1)=
     *               VE_SOR(IX,IY,IZ,K,L,2,1)*XOLDEV+VNE_PR*XNEWEV
C
                  END DO
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
      DEALLOCATE(ANE_PR)
C=======================================================================
C
      CALL CPUTIM('SKFINP',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SKPAIR(XOLDPA,LTWCEN)
C=======================================================================
      USE HE_DEN
      USE PD_DEN
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
      USE ADBATC, only : DE_RHO_SAV, PD_RHO_SAV, DE_SPI_SAV
C=======================================================================
      COMPLEX
     *          PNEUTR,PPROTO,
     *          XNEUTR,XPROTO
      COMPLEX
     *          DENNEU,DENPRO,SPINEU(NDKART),SPIPRO(NDKART)
      COMPLEX
     *          PAINEU,PAIPRO
C
      COMPLEX
     *          APANEU,APAPRO
      ALLOCATABLE
     *          APANEU(:,:,:),APAPRO(:,:,:)
C
      COMMON
     *       /DENTOT/ DENSIT(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHA(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /CCPSKP/ PRHO_0,PRHOD0,PTAU_1,PTAU_2,PLPR_0,PSCU_1,
     *                PSCU_2,PSCU_3
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /INTSKY/ T0,X0,T1,X1,T2,X2,T3,X3,W0,POWER
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMAT/ NOIINP,MIXMAT
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /ADBLNM/ IADBLN
C
C=======================================================================
C
      CALL CPUTIM('SKPAIR',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE PAIRING FIELDS BASED ON THE REF.
C        DOBACZEWSKI ET AL. NP422 (1984) 103 REFERRED TO AS DFT.
C=======================================================================
C        THE EFFECTIVE COUPLING CONSTANTS ARE CODED AS:
C                      'P'//'XXX'//'N'//'TYP'
C
C        WHERE THE SYMBOLS:  'P', 'XXX', 'N', AND 'TYP'
C        ARE EXPLAINED IN THE SUBROUTINE "ESKYRM"
C
C=======================================================================
C        ATTENTION: THE REAL DENSITY IS USED  IN  THE  DENSITY-DEPENDENT
C                   TERM, SO THE ROUTINE CAN ONLY BE USED IN THE SINGLE-
C                   REFERENCE FRAMEWORK
C=======================================================================
C
      IF (LTWCEN.LT.1.AND.LTWCEN.GT.16)
     *    STOP 'LTWCEN INCOMPATIBLE IN SKPAIR'
C
      XNEWPA=1.0D0-XOLDPA
C
      ALLOCATE(APANEU(NDXHRM,NDYHRM,NDZHRM))
      ALLOCATE(APAPRO(NDXHRM,NDYHRM,NDZHRM))
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               IF (IADBLN.EQ.0) THEN
C
                   DENNEU=     DE_RHO(IX,IY,IZ,0,1)  *EXPAUX(IX,IY,IZ,1)
                   DENPRO=     DE_RHO(IX,IY,IZ,1,1)  *EXPAUX(IX,IY,IZ,1)
C
                   SPINEU(1)=  DE_SPI(IX,IY,IZ,1,0,1)*EXPAUX(IX,IY,IZ,1)
                   SPIPRO(1)=  DE_SPI(IX,IY,IZ,1,1,1)*EXPAUX(IX,IY,IZ,1)
C
                   SPINEU(2)=  DE_SPI(IX,IY,IZ,2,0,1)*EXPAUX(IX,IY,IZ,1)
                   SPIPRO(2)=  DE_SPI(IX,IY,IZ,2,1,1)*EXPAUX(IX,IY,IZ,1)
C
                   SPINEU(3)=  DE_SPI(IX,IY,IZ,3,0,1)*EXPAUX(IX,IY,IZ,1)
                   SPIPRO(3)=  DE_SPI(IX,IY,IZ,3,1,1)*EXPAUX(IX,IY,IZ,1)
C
                   PAINEU=     PD_RHO(IX,IY,IZ,0,1)  *EXPAUX(IX,IY,IZ,1)
                   PAIPRO=     PD_RHO(IX,IY,IZ,1,1)  *EXPAUX(IX,IY,IZ,1)
C
               ELSE
C
                   DENNEU= DE_RHO_SAV(IX,IY,IZ,0,1)  *EXPAUX(IX,IY,IZ,1)
                   DENPRO= DE_RHO_SAV(IX,IY,IZ,1,1)  *EXPAUX(IX,IY,IZ,1)
C
                   SPINEU(1)=DE_SPI_SAV(IX,IY,IZ,1,0,1)
     *                                              *EXPAUX(IX,IY,IZ,1)
                   SPIPRO(1)=DE_SPI_SAV(IX,IY,IZ,1,1,1)
     *                                              *EXPAUX(IX,IY,IZ,1)
C
                   SPINEU(2)=DE_SPI_SAV(IX,IY,IZ,2,0,1)
     *                                              *EXPAUX(IX,IY,IZ,1)
                   SPIPRO(2)=DE_SPI_SAV(IX,IY,IZ,2,1,1)
     *                                              *EXPAUX(IX,IY,IZ,1)
C
                   SPINEU(3)=DE_SPI_SAV(IX,IY,IZ,3,0,1)
     *                                              *EXPAUX(IX,IY,IZ,1)
                   SPIPRO(3)=DE_SPI_SAV(IX,IY,IZ,3,1,1)
     *                                              *EXPAUX(IX,IY,IZ,1)
C
                   PAINEU=   PD_RHO_SAV(IX,IY,IZ,0,1)
     *                                              *EXPAUX(IX,IY,IZ,1)
                   PAIPRO=   PD_RHO_SAV(IX,IY,IZ,1,1)
     *                                              *EXPAUX(IX,IY,IZ,1)
C
               ENDIF
C
C=======================================================================
C              S  C  A  L  A  R     F I E L D S     F O L L O W
C=======================================================================
C=======================================================================
C              CENTRAL TERM (<= T0) - (SEE: DFT EQ.(A5.B))
C=======================================================================
C
               XNEUTR = PRHO_N * PD_RHO(IX,IY,IZ,0,LTWCEN) / 2.0D0
               XPROTO = PRHO_P * PD_RHO(IX,IY,IZ,1,LTWCEN) / 2.0D0
C
               PNEUTR = XNEUTR
               PPROTO = XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= T3)
C=======================================================================
C
               XNEUTR = PRHODN * PD_RHO(IX,IY,IZ,0,LTWCEN) / 2.0D0
     *                         * DENSIT(IX,IY,IZ,LTWCEN)**POWERN
               XPROTO = PRHODP * PD_RHO(IX,IY,IZ,1,LTWCEN) / 2.0D0
     *                         * DENSIT(IX,IY,IZ,LTWCEN)**POWERP
C
               PNEUTR = PNEUTR+XNEUTR
               PPROTO = PPROTO+XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= 2-BODY Skyrme pairing)
C=======================================================================
               XNEUTR = PRHO_0 * PD_RHO(IX,IY,IZ,0,LTWCEN)
     *                + PTAU_2 * PD_TAU(IX,IY,IZ,0,LTWCEN)
     *                + PLPR_0 * PD_LPR(IX,IY,IZ,0,LTWCEN)
               XPROTO = PRHO_0 * PD_RHO(IX,IY,IZ,1,LTWCEN)
     *                + PTAU_2 * PD_TAU(IX,IY,IZ,1,LTWCEN)
     *                + PLPR_0 * PD_LPR(IX,IY,IZ,1,LTWCEN)
C
               PNEUTR = PNEUTR+XNEUTR*2
               PPROTO = PPROTO+XPROTO*2
C
C=======================================================================
C              CENTRAL TERM (<= T3 Skyrme pairing )
C=======================================================================
C
               XNEUTR = PRHOD0 * PD_RHO(IX,IY,IZ,0,LTWCEN) / 2.0D0
     *                         * DENSIT(IX,IY,IZ,LTWCEN)**POWER
               XPROTO = PRHOD0 * PD_RHO(IX,IY,IZ,1,LTWCEN) / 2.0D0
     *                         * DENSIT(IX,IY,IZ,LTWCEN)**POWER
C
               PNEUTR = PNEUTR+XNEUTR
               PPROTO = PPROTO+XPROTO
C
C=======================================================================
C              CENTRAL TERM (<= 3-BODY TREM)
C=======================================================================
C
C=======================================================================
C              ATTENTION: TWO-CENTER BASIS OPTION INCOMPATIBLE WITH
C                         3/4 BODY FORCES
C=======================================================================
C
               XNEUTR = THREEB * PD_RHO(IX,IY,IZ,0,1)
     *                         * DENPRO * 3.0D0 / 4.0D0
               XPROTO = THREEB * PD_RHO(IX,IY,IZ,1,1)
     *                         * DENNEU * 3.0D0 / 4.0D0
C
               PNEUTR = PNEUTR+XNEUTR*2
               PPROTO = PPROTO+XPROTO*2
C
C=======================================================================
C              CENTRAL TERM (<= 4-BODY KAPPA-KAPPA-RHO-RHO TREM)
C=======================================================================
C
               XNEUTR = FOURBD * PD_RHO(IX,IY,IZ,0,1)
     *                         * ( DENPRO   **2
     *                           - SPIPRO(1)**2
     *                           - SPIPRO(2)**2
     *                           - SPIPRO(3)**2 )
     *                         * 3.0D0 / 4.0D0
               XPROTO = FOURBD * PD_RHO(IX,IY,IZ,1,1)
     *                         * ( DENNEU   **2
     *                           - SPINEU(1)**2
     *                           - SPINEU(2)**2
     *                           - SPINEU(3)**2 )
     *                         * 3.0D0 / 4.0D0
C
               PNEUTR = PNEUTR+XNEUTR*2
               PPROTO = PPROTO+XPROTO*2
C
C=======================================================================
C              CENTRAL TERM (<= 4-BODY KAPPA-KAPPA-KAPPA-KAPPA TREM)
C=======================================================================
C
               XNEUTR = FOURBD * PD_RHO(IX,IY,IZ,0,1)
     *                         * PAIPRO * CONJG(PAIPRO)
     *                         * 3.0D0 / 4.0D0
               XPROTO = FOURBD * PD_RHO(IX,IY,IZ,1,1)
     *                         * PAINEU * CONJG(PAINEU)
     *                         * 3.0D0 / 4.0D0
C
               PNEUTR = PNEUTR+XNEUTR*2
               PPROTO = PPROTO+XPROTO*2
C
               WD_CEN(IX,IY,IZ,0,LTWCEN) =
     *         WD_CEN(IX,IY,IZ,0,LTWCEN)*XOLDPA+ XNEWPA*PNEUTR
               WD_CEN(IX,IY,IZ,1,LTWCEN) =
     *         WD_CEN(IX,IY,IZ,1,LTWCEN)* XOLDPA+XNEWPA*PPROTO
C
C=======================================================================
C              KINETIC TERM (<= 2-BODY Skyrme pairing)
C=======================================================================
C
               XNEUTR = PTAU_1 * PD_RHO(IX,IY,IZ,0,LTWCEN)
               XPROTO = PTAU_1 * PD_RHO(IX,IY,IZ,1,LTWCEN)
C
               PNEUTR = XNEUTR*2
               PPROTO = XPROTO*2
C
               WD_TAU(IX,IY,IZ,0,LTWCEN) =
     *         WD_TAU(IX,IY,IZ,0,LTWCEN) * XOLDPA + XNEWPA*PNEUTR
               WD_TAU(IX,IY,IZ,1,LTWCEN) =
     *         WD_TAU(IX,IY,IZ,1,LTWCEN) * XOLDPA + XNEWPA*PPROTO
C
C=======================================================================
C                 S.O. TERM (<= W0) - AUXILIARY FIELD
C=======================================================================
C
               APANEU(IX,IY,IZ) = 0.0D0
               APAPRO(IX,IY,IZ) = 0.0D0
C
               DO K=1,NDKART
C
                 APANEU(IX,IY,IZ) = APANEU(IX,IY,IZ)
     *                            + PD_SCU(IX,IY,IZ,K,K,0,LTWCEN)
                 APAPRO(IX,IY,IZ) = APAPRO(IX,IY,IZ)
     *                            + PD_SCU(IX,IY,IZ,K,K,1,LTWCEN)
C
               END DO
C
            END DO
         END DO
      END DO
C
      DO L=1,NDKART
         DO K=1,NDKART
C
            DO IZ=1,NZHERM
               DO IY=1,NYHERM
                  DO IX=1,NXHERM
C
C=======================================================================
C                 T  E  N  S  O  R    F  I  E  L  D    F O L L O W S
C=======================================================================
C
C=======================================================================
C                 S.O. TERM (<= T1-T2) - (SEE: ENGEL ET AL, EQ.(B.4))
C=======================================================================
C
                     XNEUTR = PSCU_1 * PD_SCU(IX,IY,IZ,K,L,0,LTWCEN)
                     XPROTO = PSCU_1 * PD_SCU(IX,IY,IZ,K,L,1,LTWCEN)
C
                     PNEUTR = XNEUTR*2
                     PPROTO = XPROTO*2
C
C=======================================================================
C                 S.O. TERM (<= W0) - (SEE: ENGEL ET AL, EQ.(B.4))
C=======================================================================
C
                     IF(K.EQ.L)THEN
                       XNEUTR = PSCU_2 * APANEU(IX,IY,IZ)
                       XPROTO = PSCU_2 * APAPRO(IX,IY,IZ)
C
                       PNEUTR = PNEUTR+XNEUTR*2
                       PPROTO = PPROTO+XPROTO*2
                     END IF
C
                     XNEUTR = PSCU_3 * PD_SCU(IX,IY,IZ,L,K,0,LTWCEN)
                     XPROTO = PSCU_3 * PD_SCU(IX,IY,IZ,L,K,1,LTWCEN)
C
                     PNEUTR = PNEUTR+XNEUTR*2
                     PPROTO = PPROTO+XPROTO*2
C
                     WD_SOR(IX,IY,IZ,K,L,0,LTWCEN)=
     *               WD_SOR(IX,IY,IZ,K,L,0,LTWCEN)*XOLDPA+PNEUTR*XNEWPA
                     WD_SOR(IX,IY,IZ,K,L,1,LTWCEN)=
     *               WD_SOR(IX,IY,IZ,K,L,1,LTWCEN)*XOLDPA+PPROTO*XNEWPA
C
C
                  END DO
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
      DEALLOCATE(APANEU,APAPRO)
C=======================================================================
C
      CALL CPUTIM('SKPAIR',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SKP_IN
C=======================================================================
      USE BROYIN
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /BROTEN/ KSCALA,KVECTO,KTENSO,KLIPKI
     *       /BROSIZ/ NSCALR,NVECTO,NTENSO,NMATRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE STORES OLD PAIRING FIELDS TO BE USED IN THE
C        BROYDEN METHOD
C=======================================================================
C
      INDEXX=KLIPKI+KSCALA+KVECTO+KTENSO
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               INDEXX=INDEXX+1
C
               BRO_IN(INDEXX)         =REAL (WD_CEN(IX,IY,IZ,0,1))
     *                                      *EXPAUX(IX,IY,IZ,1)
               BRO_IN(INDEXX+  NSCALR)=AIMAG(WD_CEN(IX,IY,IZ,0,1))
     *                                      *EXPAUX(IX,IY,IZ,1)
               BRO_IN(INDEXX+2*NSCALR)=REAL (WD_CEN(IX,IY,IZ,1,1))
     *                                      *EXPAUX(IX,IY,IZ,1)
               BRO_IN(INDEXX+3*NSCALR)=AIMAG(WD_CEN(IX,IY,IZ,1,1))
     *                                      *EXPAUX(IX,IY,IZ,1)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SKP_OU
C=======================================================================
      USE BROYOU
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /BROTEN/ KSCALA,KVECTO,KTENSO,KLIPKI
     *       /BROSIZ/ NSCALR,NVECTO,NTENSO,NMATRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE STORES NEW PAIRING FIELDS TO BE USED IN THE
C        BROYDEN METHOD
C=======================================================================
C
      INDEXX=KLIPKI+KSCALA+KVECTO+KTENSO
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               INDEXX=INDEXX+1
C
               BRO_OU(INDEXX)         =REAL (WD_CEN(IX,IY,IZ,0,1))
     *                                      *EXPAUX(IX,IY,IZ,1)
               BRO_OU(INDEXX+  NSCALR)=AIMAG(WD_CEN(IX,IY,IZ,0,1))
     *                                      *EXPAUX(IX,IY,IZ,1)
               BRO_OU(INDEXX+2*NSCALR)=REAL (WD_CEN(IX,IY,IZ,1,1))
     *                                      *EXPAUX(IX,IY,IZ,1)
               BRO_OU(INDEXX+3*NSCALR)=AIMAG(WD_CEN(IX,IY,IZ,1,1))
     *                                      *EXPAUX(IX,IY,IZ,1)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CALBRO_FIELDS(IROTAT,ISIMPY,IPAHFB,LIPKIN,LIPKIP,
     *                         NXHERM,NYHERM,NZHERM,IBROYD,NOFBRO)
C=======================================================================
      USE BROYIN
      USE BROYOU
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CNSNUM/ NOFCNS
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BROTEN/ KSCALA,KVECTO,KTENSO,KLIPKI
     *       /BROSIZ/ NSCALR,NVECTO,NTENSO,NMATRI
      COMMON
     *       /CFIPRI/ NFIPRI
C=======================================================================
C        THIS SUBROUTINE COMPUTES THE EXPECTED SIZE OF THE BROYDEN
C        VECTOR, DEPENDING ON THE OPTIONS CHOSEN BY THE USER (SUCH
C        AS PAIRING, CONSERVED/BROKEN SIMPLEX, LN METHOD, ETC.). BY
C        COMPUTING THE EXACT SIZE OF THE VECTOR, IT OPTIMIZES THE
C        MEMORY USAGE. THE 'IN'AND 'OUT' BROYDEN VECTORS ARE ALLOCA-
C        TED AT THE END OF THE SUBROUTINE. SEVERAL USEFUL NUMBERS
C        ARE ALSO DEFINED HERE.
C=======================================================================
C
      NSCALR=NXHERM*NYHERM*NZHERM
      NVECTO=NXHERM*NYHERM*NZHERM*NDKART
      NTENSO=NXHERM*NYHERM*NZHERM*NDKART*NDKART
C
      NMATRI=4*LDBASE*LDBASE
C
      KSCALA=4*NSCALR ! scalar fields
      KVECTO=6*NVECTO*IROTAT ! vector fields
      KTENSO=2*NTENSO ! tensor fields
C
      IF (IPAHFB.LT.1) THEN
          KPAIRI=0        ! no pairing
      ELSE
          KPAIRI=4*NSCALR ! pairing fields
      END IF
C
      KLIPKI= LIPKIN+LIPKIP
     *      +(LIPKIN+LIPKIP)*NMATRI
     *      +(LIPKIN+LIPKIP)*NMATRI*(1-ISIMPY) ! Lipkin-Nogami
C
      IF (IBROYD.LE.1) THEN
          NOFBRO=KLIPKI+KSCALA+KVECTO+KTENSO+KPAIRI+NOFCNS
      ELSE
          NOFBRO=KLIPKI+KSCALA+KVECTO+KTENSO+KPAIRI
      END IF
C
      IALLOC=0
C
C=======================================================================
      IF (     ALLOCATED(BRO_IN)) DEALLOCATE (BRO_IN)
      IF (.NOT.ALLOCATED(BRO_IN)) THEN
          ALLOCATE (BRO_IN(1:NOFBRO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BRO_IN','CALBRO')
      END IF
C=======================================================================
      IF (     ALLOCATED(BRO_OU)) DEALLOCATE (BRO_OU)
      IF (.NOT.ALLOCATED(BRO_OU)) THEN
          ALLOCATE (BRO_OU(1:NOFBRO),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BRO_OU','CALBRO')
      END IF
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DOBROY_FIELDS(ITERUN,NOFBRO,NSWBRO,ITAKEN,IROTAT,
     *                         IPAHFB,SLOWEV,ESTABN,IF_RPA,LDPNMX)
C=======================================================================
      USE BROYIN
      USE BROYOU
      USE VE_FLD
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /NCKVAL/ Q0NECK,G_NECK
     *       /NCKFLA/ IFNECK
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      COMMON
     *       /CNSOLD/ VECOLD(1:NDCONS)
     *       /CNSQLM/ VECCNS(1:NDCONS)
      COMMON
     *       /CNSCOR/ LAMCNS(1:NDCONS),MIUCNS(1:NDCONS)
     *       /CNSNUM/ NOFCNS
      COMMON
     *       /QLASTR/ GALMUQ(0:NDMULT,-NDMULT:NDMULT),
     *                QLINEA(0:NDMULT,-NDMULT:NDMULT),
     *                IFLALQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /BROTEN/ KSCALA,KVECTO,KTENSO,KLIPKI
     *       /BROSIZ/ NSCALR,NVECTO,NTENSO,NMATRI
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMIX/ ALPHAM,BROTRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C
      CALL CPUTIM('DOBROY',1)
C
C=======================================================================
C        THIS SUBROUTINE APPLIES THE BROYDEN METHOD
C=======================================================================
C
      IF (LDPNMX.NE.1)
     *    STOP ' LDPNMX=1 REQUIRED IN DOBROY_FIELDS'
C
C=======================================================================
C
C      Adding linear constraints parameters
C
      IF (IF_RPA.GE.1.AND.NOFCNS.GE.1.AND.IBROYD.LE.1) THEN
          DO I=1,NOFCNS
             BRO_IN(NOFBRO-I+1)=VECOLD(I)
             BRO_OU(NOFBRO-I+1)=VECCNS(I)
          END DO
      END IF
C
      SCALEF=1.0
C
C      Automatic switching on of Broyden correction for stability less
C      than BROTRI. If condition not met, we continue with standard
C      linear mixing as defined in HFODD input.
C
      IF (ABS(ESTABN).LE.BROTRI.AND.ITAKEN.EQ.0) THEN
          NSWBRO=ITERUN-1
          ITAKEN=1
      END IF
C
C      If Broyden is off, we do standard linear mixing with the
C      slow-down parameter of the time-even fields SLOWEV
C
      ITEACT=ITERUN-NSWBRO
C
C=======================================================================
C      PRIOR TO VERSION 2.49C, "ALCURR"  BELOW WAS SET WRONGLY TO BE
C      EQUAL TO 1-SLOWEV, WHICH MADE THE VARIABLE "ALPHAM" REDUNDANT
C      AND COULD LEAD TO MISUSE OF THE BROYDEN PARAMETERS. THIS  BUG
C      WAS CORRECTED ON 23/09/2010.
C=======================================================================
C
      NSTART=1
      ALCURR=ALPHAM
C
      IF (ITEACT.LT.0) THEN
          NSTART=0
          ALCURR=1.0D0-SLOWEV
      END IF
C
      W0_BRO=0.01D0
      WN_BRO=1.00D0
C
C=======================================================================
C
      IERROR=0
C
      IF (IBROYD.EQ.1) THEN
          CALL broyden(NOFBRO,NOFBRO,BRO_OU,BRO_IN,ALCURR,dr2,ITEACT,
     *                            N_ITER,W0_BRO,WN_BRO,NSTART,IERROR)
      END IF
C
C=======================================================================
C
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
      IF (IF_RPA.GE.1.AND.NOFCNS.GE.1.AND.IBROYD.LE.1) THEN
C
          IF (IFNECK.LE.1) THEN
C
              DO I=1,NOFCNS
                 LAMBDA=LAMCNS(I)
                 MIU   =MIUCNS(I)
                 GALMUQ(LAMBDA,MIU)=BRO_IN(NOFBRO-I+1)
              END DO
C
          ELSE
C
              DO I=1,NOFCNS-1
                 LAMBDA=LAMCNS(I)
                 MIU   =MIUCNS(I)
                 GALMUQ(LAMBDA,MIU)=BRO_IN(NOFBRO-I+1)
              END DO
              G_NECK=BRO_IN(NOFBRO-NOFCNS+1)
C
          END IF
C
      END IF
C@@@ NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK - NECK
C
C      Reconstructing fields from the Broyden vectors
C
C      Scalar fields
C
      INDEXX=KLIPKI
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               INDEXX=INDEXX+1
C
               VE_MAS(IX,IY,IZ,0,1)=BRO_IN(INDEXX)
     *                                               /EXPAUX(IX,IY,IZ,1)
               VE_MAS(IX,IY,IZ,1,1)=BRO_IN(INDEXX+  NSCALR)
     *                                               /EXPAUX(IX,IY,IZ,1)
C
               VE_CEN(IX,IY,IZ,0,1)=BRO_IN(INDEXX+2*NSCALR)
     *                                               /EXPAUX(IX,IY,IZ,1)
               VE_CEN(IX,IY,IZ,1,1)=BRO_IN(INDEXX+3*NSCALR)
     *                                               /EXPAUX(IX,IY,IZ,1)
C
            END DO
         END DO
      END DO
C
C      Vector fields
C
      IF (IROTAT.NE.0) THEN
C
          INDEXX=KLIPKI+KSCALA
C
          DO K=1,NDKART
C
             DO IZ=1,NZHERM
                DO IY=1,NYHERM
                   DO IX=1,NXHERM
C
                      INDEXX=INDEXX+1
C
                      VE_CUR(IX,IY,IZ,K,0,1)=BRO_IN(INDEXX)
     *                                               /EXPAUX(IX,IY,IZ,1)
                      VE_CUR(IX,IY,IZ,K,1,1)=BRO_IN(INDEXX+  NVECTO)
     *                                               /EXPAUX(IX,IY,IZ,1)
C
                      VE_KIS(IX,IY,IZ,K,0,1)=BRO_IN(INDEXX+2*NVECTO)
     *                                               /EXPAUX(IX,IY,IZ,1)
                      VE_KIS(IX,IY,IZ,K,1,1)=BRO_IN(INDEXX+3*NVECTO)
     *                                               /EXPAUX(IX,IY,IZ,1)
C
                      VE_SPI(IX,IY,IZ,K,0,1)=BRO_IN(INDEXX+4*NVECTO)
     *                                               /EXPAUX(IX,IY,IZ,1)
                      VE_SPI(IX,IY,IZ,K,1,1)=BRO_IN(INDEXX+5*NVECTO)
     *                                               /EXPAUX(IX,IY,IZ,1)
C
                  END DO
               END DO
            END DO
C
         END DO
C
      END IF
C
C      Tensor fields
C
      INDEXX=KLIPKI+KSCALA+KVECTO
C
      DO L=1,NDKART
         DO K=1,NDKART
C
            DO IZ=1,NZHERM
               DO IY=1,NYHERM
                  DO IX=1,NXHERM
C
                  INDEXX=INDEXX+1
C
                  VE_SOR(IX,IY,IZ,K,L,0,1)=BRO_IN(INDEXX)
     *                                               /EXPAUX(IX,IY,IZ,1)
                  VE_SOR(IX,IY,IZ,K,L,1,1)=BRO_IN(INDEXX+NTENSO)
     *                                               /EXPAUX(IX,IY,IZ,1)
C
                  END DO
               END DO
            END DO
C
         END DO
      END DO
C
C      Pairing fields
C
      IF (IPAHFB.GE.1) THEN
C
          INDEXX=KLIPKI+KSCALA+KVECTO+KTENSO
C
          DO IZ=1,NZHERM
             DO IY=1,NYHERM
                DO IX=1,NXHERM
C
                INDEXX=INDEXX+1
C
                WD_CEN(IX,IY,IZ,0,1)=CMPLX(BRO_IN(INDEXX),
     *                                   BRO_IN(INDEXX+  NSCALR))
     *                                          /EXPAUX(IX,IY,IZ,1)
                WD_CEN(IX,IY,IZ,1,1)=CMPLX(BRO_IN(INDEXX+2*NSCALR),
     *                                   BRO_IN(INDEXX+3*NSCALR))
     *                                          /EXPAUX(IX,IY,IZ,1)
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('DOBROY',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CALBRO_MATRIX(MREVER,IROTAT,ISIMPY,IPAHFB,NOFBRN,
     *                                NOFBRP,LIPKIN,LIPKIP,IBROYD)
C=======================================================================
      USE BROYIN_NEUTRON
      USE BROYOU_NEUTRON
      USE BROYIN_PROTON
      USE BROYOU_PROTON
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BRODIM/ N_REAL,N_IMAG,N_TOTA,N_RISO,N_ISOS,NMATRN,NMATRP
C=======================================================================
C        THIS SUBROUTINE COMPUTES THE EXPECTED SIZE OF THE BROYDEN
C        VECTOR, DEPENDING ON THE OPTIONS CHOSEN BY THE USER (SUCH
C        AS PAIRING, CONSERVED/BROKEN SIMPLEX, LN METHOD, ETC.). BY
C        COMPUTING THE EXACT SIZE OF THE VECTOR, IT OPTIMIZES THE
C        MEMORY USAGE. THE 'IN'AND 'OUT' BROYDEN VECTORS ARE ALLOCA-
C        TED AT THE END OF THE SUBROUTINE. SEVERAL USEFUL NUMBERS
C        ARE ALSO DEFINED HERE.
C=======================================================================
C
      N_REAL=LDBASE*(LDBASE+1)/2 ! Number of real elements
                                 ! in a Hermitian matrix
      N_IMAG=LDBASE*(LDBASE-1)/2 ! Number of pure imaginary ones
      N_TOTA=N_REAL+N_IMAG       ! Total number of independent elements
                                 ! in a Hermitian matrix
C
      N_ISOS=(MREVER+1)*N_TOTA ! total for one kind of nucleon only
      N_RISO=(MREVER+1)*N_REAL
C
      NMATRN=N_ISOS
      NMATRP=N_ISOS
C
      IF (IPAHFB.LT.1) THEN
          JPAHFB=0
      ELSE
          JPAHFB=1
      END IF
      NOFBRO=N_ISOS+(1-ISIMPY)*N_ISOS
     *                +JPAHFB *(N_REAL+IROTAT*N_IMAG)
     *                +JPAHFB ! Fermi level
C
      NOFBRN=NOFBRO+LIPKIN*IBROYD
      NOFBRP=NOFBRO+LIPKIP*IBROYD
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (ALLOCATED(BRONIN)) DEALLOCATE(BRONIN,BRONOU)
      IF (.NOT.ALLOCATED(BRONIN)) THEN
          ALLOCATE (BRONIN(1:NOFBRN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BRONIN','CALBRO')
      END IF
      IF (.NOT.ALLOCATED(BRONOU)) THEN
          ALLOCATE (BRONOU(1:NOFBRN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BRONOU','CALBRO')
      END IF
C
      IF (ALLOCATED(BROPIN)) DEALLOCATE(BROPIN,BROPOU)
      IF (.NOT.ALLOCATED(BROPIN)) THEN
          ALLOCATE (BROPIN(1:NOFBRP),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BROPIN','CALBRO')
      END IF
      IF (.NOT.ALLOCATED(BROPOU)) THEN
          ALLOCATE (BROPOU(1:NOFBRP),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BROPOU','CALBRO')
      END IF
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DOBROY_MATRIX(ITERUN,NSWBRO,ITAKEN,
     *                         NOICAN,SLOWEV,ESTABN,
     *                         EFERMX,EFEXIN,EFEXOU,
     *                         EFER2X,EF2XIN,EF2XOU,
     *                         LIPKIX,NOFBRX,ICHARG,
     *                                       IPAHFB)
C=======================================================================
      USE BROYIN_NEUTRON
      USE BROYOU_NEUTRON
      USE BROYIN_PROTON
      USE BROYOU_PROTON
C=======================================================================
      COMMON
     *       /BRODIM/ N_REAL,N_IMAG,N_TOTA,N_RISO,N_ISOS,NMATRN,NMATRP
      COMMON
     *       /BROINI/ IBROYD,N_ITER
     *       /BROMIX/ ALPHAM,BROTRI
     *       /BROMAT/ NOIINP,MIXMAT
C
C=======================================================================
C
      CALL CPUTIM('DOBROY',1)
C
C=======================================================================
C        THIS SUBROUTINE APPLIES THE BROYDEN METHOD
C=======================================================================
C
      SCALEF=1.0
C
      XNNORM=0.0D0
      XPNORM=0.0D0
C
      N_TRUE=NOFBRX
C
C      In addition to matrix elements, the Broyden vectors
C      contain the Fermi level (HFB only) and the lambda_2
C      parameter (HFB+LN only).
C
      IF (IPAHFB.GE.1) THEN
C
          IF (ICHARG.EQ.0) THEN
C
              BRONIN(NOFBRX)=EFEXIN
              BRONOU(NOFBRX)=EFEXOU
C
              IF (LIPKIX.EQ.1.AND.IBROYD.GE.1) THEN
                  BRONIN(NOFBRX-1)=EF2XIN
                  BRONOU(NOFBRX-1)=EF2XOU
              END IF
C
          ELSE
C
              BROPIN(NOFBRX)=EFEXIN
              BROPOU(NOFBRX)=EFEXOU
C
              IF (LIPKIX.EQ.1.AND.IBROYD.GE.1) THEN
                  BROPIN(NOFBRX-1)=EF2XIN
                  BROPOU(NOFBRX-1)=EF2XOU
              END IF
C
          END IF
      END IF
C
C      By default, NSWBRO=1000000, so that NSTART=0
C      in the Broyden routines, an only a very standard
C      linear mixing is performed. When stability is less
C      than BROTRI, we switch on the broyden routine
C
      IF (ABS(ESTABN).LT.BROTRI.AND.ITAKEN.EQ.0.AND.IBROYD.GE.1) THEN
          NSWBRO=ITERUN
          ITAKEN=1
      END IF
C
C      When the Broyden routine is already switched on, it
C      is sometimes advantageous to erase the Broyden vector
C      every now and then. This reduces the numerical noise
C      which is produced when mixing matrix elements. When
C      the current number of iterations is a multiple of
C      NOICAN, the Broyden memory is erased.
C
      IF (ITAKEN.EQ.1.AND.MOD(ITERUN,NOICAN).EQ.0.AND.IBROYD.GE.1) THEN
          NSWBRO=ITERUN
      END IF
C
C      In practice, ITEACT controls whether or not the Broyden
C      procedure is switched on or off. When off (ITEACT <= 0),
C      standard linear mixing is done.
C
      ITEACT=ITERUN-NSWBRO
C
      NSTART=1
      ALCURR=ALPHAM
C
      IF (ITEACT.LE.0) THEN
          NSTART=0
          ALCURR=1.0-SLOWEV
      END IF
C
      W0_BRO=0.01
      WN_BRO=1.00
C
C=======================================================================
      IF (ICHARG.EQ.0)
     *CALL broyden_n(N_TRUE,N_TRUE,BRONOU,BRONIN,ALCURR,dr2,ITEACT,
     *                               N_ITER,W0_BRO,WN_BRO,NSTART)
C=======================================================================
      IF (ICHARG.EQ.1)
     *CALL broyden_p(N_TRUE,N_TRUE,BROPOU,BROPIN,ALCURR,dr2,ITEACT,
     *                               N_ITER,W0_BRO,WN_BRO,NSTART)
C=======================================================================
C
      IF (IPAHFB.EQ.1) THEN
C
          IF (ICHARG.EQ.0) THEN
                  EFERMX=BRONIN(NOFBRX)
              IF (LIPKIX.EQ.1.AND.IBROYD.GE.1) THEN
                  EFER2X=BRONIN(NOFBRX-1)
              END IF
          ELSE
                  EFERMX=BROPIN(NOFBRX)
              IF (LIPKIX.EQ.1.AND.IBROYD.GE.1) THEN
                  EFER2X=BROPIN(NOFBRX-1)
              END IF
          END IF
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('DOBROY',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HPH_IN(ISIMPY,MREVER,ICHARG)
C=======================================================================
      USE BROYIN_NEUTRON
      USE BROYOU_NEUTRON
      USE BROYIN_PROTON
      USE BROYOU_PROTON
      USE MAT_PP
      USE MAT_PM
      USE MAF_PP
      USE MAF_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BRODIM/ N_REAL,N_IMAG,N_TOTA,N_RISO,N_ISOS,NMATRN,NMATRP
C
C=======================================================================
C      THIS SUBROUTINE UPDATES THE 'IN' AND 'OUT' BROYDEN VECTORS
C      WITH THE P-H PART OF THE HFB MATRIX. THIS IS DONE SEPARATELY
C      FOR NEUTRONS AND PROTONS. SINCE THE P-H PART OF THE HFB MATRIX
C      IS HERMITIAN, ONLY THE INDEPENDENT MATRIX ELEMENTS NEED TO BE
C      CONSIDERED. ALSO, IN HFODD, THIS MATRIX IS COMPLEX, SO THE
C      REAL PART AND IMAGINARY PART ARE CONSIDERED INDEPENDENT.
C=======================================================================
C
      IF (ICHARG.EQ.0) THEN
C
          DO IREVER=0,MREVER
C
             INDEXX=0
             INDIMA=0
C
             DO J=1,LDBASE
C
                INDEXX=INDEXX+1
C
                BRONIN(INDEXX+IREVER*N_TOTA)
     *                  =REAL(FIL_PP(J,J,IREVER,ICHARG))
                BRONOU(INDEXX+IREVER*N_TOTA)
     *                  =REAL(BIG_PP(J,J,IREVER))
C
                DO I=J+1,LDBASE
C
                   INDEXX=INDEXX+1
                   INDIMA=INDIMA+1
C
                   BRONIN(INDEXX+IREVER*N_TOTA)
     *                  =REAL(FIL_PP(I,J,IREVER,ICHARG))
                   BRONOU(INDEXX+IREVER*N_TOTA)
     *                  =REAL(BIG_PP(I,J,IREVER))
C
                   BRONIN(INDIMA+IREVER*N_TOTA+N_REAL)
     *                  =AIMAG(FIL_PP(I,J,IREVER,ICHARG))
                   BRONOU(INDIMA+IREVER*N_TOTA+N_REAL)
     *                  =AIMAG(BIG_PP(I,J,IREVER))
C
                END DO
             END DO
C
          END DO
C
C          Case of non-conserved simplex
C
          IF (ISIMPY.NE.1) THEN
C
              DO IREVER=0,MREVER
C
                 INDEXX=N_ISOS
                 INDIMA=N_ISOS
C
                 DO J=1,LDBASE
C
                    INDEXX=INDEXX+1
C
                    BRONIN(INDEXX+IREVER*N_TOTA)
     *                      =REAL(FIL_PM(J,J,IREVER,ICHARG))
                    BRONOU(INDEXX+IREVER*N_TOTA)
     *                      =REAL(BIG_PM(J,J,IREVER))
C
                    DO I=J+1,LDBASE
C
                       INDEXX=INDEXX+1
                       INDIMA=INDIMA+1
C
                       BRONIN(INDEXX+IREVER*N_TOTA)
     *                         =REAL(FIL_PM(I,J,IREVER,ICHARG))
                       BRONOU(INDEXX+IREVER*N_TOTA)
     *                         =REAL(BIG_PM(I,J,IREVER))
C
                       BRONIN(INDIMA+IREVER*N_TOTA+N_REAL)
     *                        =AIMAG(FIL_PM(I,J,IREVER,ICHARG))
                       BRONOU(INDIMA+IREVER*N_TOTA+N_REAL)
     *                        =AIMAG(BIG_PM(I,J,IREVER))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ICHARG.EQ.1) THEN
C
          DO IREVER=0,MREVER
C
             INDEXX=0
             INDIMA=0
C
             DO J=1,LDBASE
C
                INDEXX=INDEXX+1
C
                BROPIN(INDEXX+IREVER*N_TOTA)
     *                  =REAL(FIL_PP(J,J,IREVER,ICHARG))
                BROPOU(INDEXX+IREVER*N_TOTA)
     *                  =REAL(BIG_PP(J,J,IREVER))
C
                DO I=J+1,LDBASE
C
                   INDEXX=INDEXX+1
                   INDIMA=INDIMA+1
C
                   BROPIN(INDEXX+IREVER*N_TOTA)
     *                  =REAL(FIL_PP(I,J,IREVER,ICHARG))
                   BROPOU(INDEXX+IREVER*N_TOTA)
     *                  =REAL(BIG_PP(I,J,IREVER))
C
                   BROPIN(INDIMA+IREVER*N_TOTA+N_REAL)
     *                  =AIMAG(FIL_PP(I,J,IREVER,ICHARG))
                   BROPOU(INDIMA+IREVER*N_TOTA+N_REAL)
     *                  =AIMAG(BIG_PP(I,J,IREVER))
C
                END DO
             END DO
C
          END DO
C
C          Case of non-conserved simplex
C
          IF (ISIMPY.NE.1) THEN
C
              DO IREVER=0,MREVER
C
                 INDEXX=N_ISOS
                 INDIMA=N_ISOS
C
                 DO J=1,LDBASE
C
                    INDEXX=INDEXX+1
C
                    BROPIN(INDEXX+IREVER*N_TOTA)
     *                      =REAL(FIL_PM(J,J,IREVER,ICHARG))
                    BROPOU(INDEXX+IREVER*N_TOTA)
     *                      =REAL(BIG_PM(J,J,IREVER))
C
                    DO I=J+1,LDBASE
C
                       INDEXX=INDEXX+1
                       INDIMA=INDIMA+1
C
                       BROPIN(INDEXX+IREVER*N_TOTA)
     *                         =REAL(FIL_PM(I,J,IREVER,ICHARG))
                       BROPOU(INDEXX+IREVER*N_TOTA)
     *                         =REAL(BIG_PM(I,J,IREVER))
C
                       BROPIN(INDIMA+IREVER*N_TOTA+N_REAL)
     *                        =AIMAG(FIL_PM(I,J,IREVER,ICHARG))
                       BROPOU(INDIMA+IREVER*N_TOTA+N_REAL)
     *                        =AIMAG(BIG_PM(I,J,IREVER))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HPH_OU(ISIMPY,MREVER,ICHARG)
C=======================================================================
      USE BROYIN_NEUTRON
      USE BROYIN_PROTON
      USE MAF_PP
      USE MAF_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BRODIM/ N_REAL,N_IMAG,N_TOTA,N_RISO,N_ISOS,NMATRN,NMATRP
C
C=======================================================================
C      THIS SUBROUTINE UPDATES THE MATRIX ELEMENTS OF THE HFB MATRIX
C      WITH THE RESULTS OF THE BROYDEN MIXING DONE IN 'DOBROY'. THE
C      UPDATE OF THE HFB MATRIX IS DONE SEPARATELY FOR NEUTRONS AND
C      PROTONS, FLAG icharg CONTROLS THIS. ALSO, SINCE THE P-H MATRIX
C      IS HERMITIAN, ONLY THE INDEPENDENT MATRIX ELEMENTS ARE UPDATED
C      (THERE ARE n x (n+1)/2 REAL and n x (n-1)/2 IMAGINARY FOR A
C      (n x n) MATRIX.
C=======================================================================
C
C      Updating the neutron HFB matrix
C
      IF (ICHARG.EQ.0) THEN
C
          DO IREVER=0,MREVER
C
             INDEXX=0
             INDIMA=0
C
             DO J=1,LDBASE
C
                INDEXX=INDEXX+1
C
                FIL_PP(J,J,IREVER,0)
     *          =CMPLX(BRONIN(INDEXX+IREVER*N_TOTA),0.0D0)
C
                DO I=J+1,LDBASE
C
                   INDEXX=INDEXX+1
                   INDIMA=INDIMA+1
C
                   FIL_PP(I,J,IREVER,0)
     *            =CMPLX(BRONIN(INDEXX+IREVER*N_TOTA),
     *                   BRONIN(INDIMA+IREVER*N_TOTA+N_REAL))
C
                   FIL_PP(J,I,IREVER,0)=CONJG(FIL_PP(I,J,IREVER,0))
C
                END DO
C
             END DO
C
          END DO
C
          IF (MREVER.EQ.0) THEN
C
              DO J=1,LDBASE
                 DO I=1,LDBASE
                    FIL_PP(I,J,1,0)=CONJG(FIL_PP(I,J,0,0))
                 END DO
              END DO
C
          END IF
C
          IF (ISIMPY.NE.1) THEN
C
              DO IREVER=0,MREVER
C
                 INDEXX=N_ISOS
                 INDIMA=N_ISOS
C
                 DO J=1,LDBASE
C
                    INDEXX=INDEXX+1
C
                    FIL_PM(J,J,IREVER,0)
     *                  =CMPLX(BRONIN(INDEXX+IREVER*N_TOTA),0.0D0)
C
                    DO I=J+1,LDBASE
C
                       INDEXX=INDEXX+1
                       INDIMA=INDIMA+1
C
                       FIL_PM(I,J,IREVER,0)
     *                =CMPLX(BRONIN(INDEXX+IREVER*N_TOTA),
     *                       BRONIN(INDIMA+IREVER*N_TOTA+N_REAL))
C
                       FIL_PM(J,I,IREVER,0)=CONJG(FIL_PM(I,J,IREVER,0))
C
                    END DO
                 END DO
C
              END DO
C
              IF (MREVER.EQ.0) THEN
C
                  DO J=1,LDBASE
                     DO I=1,LDBASE
                        FIL_PM(I,J,1,0)=CONJG(FIL_PM(I,J,0,0))
                     END DO
                  END DO
C
              END IF
C
          END IF
C
      END IF
C
C      Updating the proton HFB matrix
C
      IF (ICHARG.EQ.1) THEN
C
          DO IREVER=0,MREVER
C
             INDEXX=0
             INDIMA=0
C
             DO J=1,LDBASE
C
                INDEXX=INDEXX+1
C
                FIL_PP(J,J,IREVER,1)
     *              =CMPLX(BROPIN(INDEXX+IREVER*N_TOTA),0.0D0)
C
                DO I=J+1,LDBASE
C
                   INDEXX=INDEXX+1
                   INDIMA=INDIMA+1
C
                   FIL_PP(I,J,IREVER,1)
     *            =CMPLX(BROPIN(INDEXX+IREVER*N_TOTA),
     *                   BROPIN(INDIMA+IREVER*N_TOTA+N_REAL))
C
                   FIL_PP(J,I,IREVER,1)=CONJG(FIL_PP(I,J,IREVER,1))
C
                END DO
C
             END DO
C
          END DO
C
          IF (MREVER.EQ.0) THEN
C
              DO J=1,LDBASE
                 DO I=1,LDBASE
                    FIL_PP(I,J,1,1)=CONJG(FIL_PP(I,J,0,1))
                 END DO
              END DO
C
          END IF
C
          IF (ISIMPY.NE.1) THEN
C
              DO IREVER=0,MREVER
C
                 INDEXX=N_ISOS
                 INDIMA=N_ISOS
C
                 DO J=1,LDBASE
C
                    INDEXX=INDEXX+1
C
                    FIL_PM(J,J,IREVER,1)
     *              =CMPLX(BROPIN(INDEXX+IREVER*N_TOTA),0.0)
C
                    DO I=J+1,LDBASE
C
                       INDEXX=INDEXX+1
                       INDIMA=INDIMA+1
C
                       FIL_PM(I,J,IREVER,1)
     *                =CMPLX(BROPIN(INDEXX+IREVER*N_TOTA),
     *                       BROPIN(INDIMA+IREVER*N_TOTA+N_REAL))
C
                       FIL_PM(J,I,IREVER,1)=CONJG(FIL_PM(I,J,IREVER,1))
C
                    END DO
                 END DO
C
              END DO
C
              IF (MREVER.EQ.0) THEN
C
                  DO J=1,LDBASE
                     DO I=1,LDBASE
                        FIL_PM(I,J,1,1)=CONJG(FIL_PM(I,J,0,1))
                     END DO
                  END DO
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEL_IN(MREVER,IROTAT,ICHARG)
C=======================================================================
      USE BROYIN_NEUTRON
      USE BROYOU_NEUTRON
      USE BROYIN_PROTON
      USE BROYOU_PROTON
      USE MAPIDE
      USE PAIDEL
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BRODIM/ N_REAL,N_IMAG,N_TOTA,N_RISO,N_ISOS,NMATRN,NMATRP
C
C=======================================================================
C      THIS SUBROUTINE UPDATES THE 'IN' AND 'OUT' BROYDEN VECTORS WITH
C      THE PAIRING MATRIX ELEMENTS OF THE HFB MATRIX. THIS IS DONE
C      SEPARATELY FOR NEUTRONS AND PROTONS, FLAG icharg CONTROLS THIS.
C      CONTRARY TO THE P-H CHANNEL, THE PAIRING PART OF THE HFB MATRIX
C      IS NOT NECESSARY HERMITIAN. ALSO, FOR SURFACE-VOLUME PAIRING
C      INTERACTION, THE TIME-EVEN TERMS ARE PURELY REAL NUMBERS, WHILE
C      THE TIME-ODD TERMS ARE PURELY IMAGINARY.
C=======================================================================
C
C      Broyden vector for neutrons
C      Real part of HAMIDE: time-even terms
C
      IF (ICHARG.EQ.0) THEN
C
          DO IREVER=0,MREVER
C
             INDEXX=NMATRN
C
             DO J=1,LDBASE
                DO I=J,LDBASE
C
                   INDEXX=INDEXX+1
C
                   BRONIN(INDEXX+IREVER*N_REAL)
     *              =REAL(FIPIDE(I,J,IREVER,ICHARG))
                   BRONOU(INDEXX+IREVER*N_REAL)
     *              =REAL(HAMIDE(I,J,IREVER))
C
                END DO
             END DO
C
          END DO
C
C          Imaginary part of HAMIDE: time-odd terms
C
          IF (IROTAT.EQ.1) THEN
C
              DO IREVER=0,MREVER
C
                 INDIMA=NMATRN+(MREVER+1)*N_REAL
C
                 DO J=1,LDBASE
                    DO I=J+1,LDBASE
C
                       INDIMA=INDIMA+1
C
                       BRONIN(INDIMA+IREVER*N_IMAG)
     *                    =AIMAG(FIPIDE(I,J,IREVER,ICHARG))
                       BRONOU(INDIMA+IREVER*N_IMAG)
     *                    =AIMAG(HAMIDE(I,J,IREVER))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
C      Broyden vector for protons
C      Real part of HAMIDE: time-even terms
C
      IF (ICHARG.EQ.1) THEN
C
          DO IREVER=0,MREVER
C
             INDEXX=NMATRP
C
             DO J=1,LDBASE
                DO I=J,LDBASE
C
                   INDEXX=INDEXX+1
C
                   BROPIN(INDEXX+IREVER*N_REAL)
     *              =REAL(FIPIDE(I,J,IREVER,ICHARG))
                   BROPOU(INDEXX+IREVER*N_REAL)
     *              =REAL(HAMIDE(I,J,IREVER))
C
                END DO
             END DO
C
          END DO
C
C          Imaginary part of HAMIDE: time-odd terms
C
          IF (IROTAT.EQ.1) THEN
C
              DO IREVER=0,MREVER
C
                 INDIMA=NMATRP+(MREVER+1)*N_REAL
C
                 DO J=1,LDBASE
                    DO I=J+1,LDBASE
C
                       INDIMA=INDIMA+1
C
                       BROPIN(INDIMA+IREVER*N_IMAG)
     *                    =AIMAG(FIPIDE(I,J,IREVER,ICHARG))
                       BROPOU(INDIMA+IREVER*N_IMAG)
     *                    =AIMAG(HAMIDE(I,J,IREVER))
C
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEL_OU(MREVER,IROTAT,ICHARG)
C=======================================================================
      USE BROYIN_NEUTRON
      USE BROYIN_PROTON
      USE MAPIDE
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BRODIM/ N_REAL,N_IMAG,N_TOTA,N_RISO,N_ISOS,NMATRN,NMATRP
C
C=======================================================================
C      THIS SUBROUTINE UPDATES THE PAIRING MATRIX ELEMENTS OF THE HFB
C      MATRIX WITH THE RESULTS OF THE BROYDEN MIXING DONE IN 'DOBROY'.
C      THE UPDATE OF THE HFB MATRIX IS DONE SEPARATELY FOR NEUTRONS AND
C      PROTONS, FLAG icharg CONTROLS THIS. CONTRARY TO THE P-H CHANNEL,
C      THE PAIRING PART OF THE HFB MATRIX IS NOT NECESSARY HERMITIAN.
C      ALSO, FOR SURFACE-VOLUME PAIRING INTERACTION, THE TIME-EVEN
C      TERMS ARE PURELY REAL NUMBERS, WHILE THE TIME-ODD TERMS ARE
C      PURELY IMAGINARY.
C=======================================================================
C
C      Updating the neutron HFB matrix
C      Real part of HAMIDE: time-even terms
C
      IF (ICHARG.EQ.0) THEN
C
          DO IREVER=0,MREVER
C
             INDEXX=NMATRN
C
             DO J=1,LDBASE
                DO I=J,LDBASE
C
                   INDEXX=INDEXX+1
C
                   FIPIDE(I,J,IREVER,0)
     *            =CMPLX(BRONIN(INDEXX+IREVER*N_REAL),0.0D0)
C
                   FIPIDE(J,I,IREVER,0)
     *            =FIPIDE(I,J,IREVER,0)
C
                END DO
C
             END DO
C
          END DO
C
C          Imaginary part of HAMIDE: time-odd terms
C
          IF (IROTAT.EQ.1) THEN
C
              DO IREVER=0,MREVER
C
                 INDIMA=NMATRN+(MREVER+1)*N_REAL
C
                 DO J=1,LDBASE
                    DO I=J+1,LDBASE
C
                       INDIMA=INDIMA+1
C
                       FIPIDE(I,J,IREVER,0)=FIPIDE(I,J,IREVER,0)
     *                    +CMPLX(0.0D0,BRONIN(INDIMA+IREVER*N_REAL))
C
                       FIPIDE(J,I,IREVER,0)
     *                =CONJG(FIPIDE(I,J,IREVER,0))
                    END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
C      Updating the proton HFB matrix
C      Real part of HAMIDE: time-even terms
C
      IF (ICHARG.EQ.1) THEN
C
          DO IREVER=0,MREVER
C
             INDEXX=NMATRP
C
             DO J=1,LDBASE
                DO I=J,LDBASE
C
                   INDEXX=INDEXX+1
C
                   FIPIDE(I,J,IREVER,1)
     *            =CMPLX(BROPIN(INDEXX+IREVER*N_REAL),0.0D0)
C
                   FIPIDE(J,I,IREVER,1)
     *            =FIPIDE(I,J,IREVER,1)
C
                END DO
             END DO
C
          END DO
C
C          Imaginary part of HAMIDE: time-odd terms
C
          IF (IROTAT.EQ.1) THEN
C
              DO IREVER=0,MREVER
C
                 INDIMA=NMATRP+(MREVER+1)*N_REAL
C
                 DO J=1,LDBASE
                    DO I=J+1,LDBASE
C
                       INDIMA=INDIMA+1
C
                       FIPIDE(I,J,IREVER,1)=FIPIDE(I,J,IREVER,1)
     *                    +CMPLX(0.0D0,BROPIN(INDIMA+IREVER*N_REAL))
C
                       FIPIDE(J,I,IREVER,1)
     *                =CONJG(FIPIDE(I,J,IREVER,1))
C
                   END DO
                 END DO
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZEFILD(ITPNMX)
C=======================================================================
      USE VE_FLD
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C        THIS SUBROUTINE PUTS ZEROS IN THE SKYRME FIELDS.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C              S  C  A  L  A  R     F  I  E  L  D  S    F  O  L  L  O  W
C=======================================================================
C
      VE_MAS(:,:,:,ITPNMX,:) = C_ZERO
      VE_CEN(:,:,:,ITPNMX,:) = C_ZERO
      VE_SPT(:,:,:,ITPNMX,:) = C_ZERO
      WD_CEN(:,:,:,ITPNMX,:) = C_ZERO
      WD_TAU(:,:,:,ITPNMX,:) = C_ZERO
C
C=======================================================================
C              V  E  C  T  O  R    F  I  E  L  D  S     F  O  L  L  O  W
C=======================================================================
C
      VE_CUR(:,:,:,:,ITPNMX,:)= C_ZERO
      VE_KIS(:,:,:,:,ITPNMX,:)= C_ZERO
      VE_SPI(:,:,:,:,ITPNMX,:)= C_ZERO
      VE_KIT(:,:,:,:,ITPNMX,:)= C_ZERO
C
C=======================================================================
C               T  E  N  S  O  R    F  I  E  L  D  S    F  O  L  L  O  W
C=======================================================================
C
      VE_SOR(:,:,:,:,:,ITPNMX,:)=C_ZERO
      WD_SOR(:,:,:,:,:,ITPNMX,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PHASES(ITWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          PHASPI,UNIT_I
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
C
C=======================================================================
C
C        THIS SUBROUTINE REPRESENTS THE CENTRAL PART OF THE W H O L E
C        PROGRAM. THE PHASE CONVENTION CORRESPONDS  TO THE |T_BASIS>.
C        THE CORRESPONDING EXPRESSIONS ARE OBTAINED ASSUMING THE H.O.
C        CARTESIAN  BASIS WITH THE OVERALL PHASE FACTOR:
C
C                                (0,1) ** NY
C
C        AND CONSEQUENTLY
C
C        |T+> = NORM. * ( (0,1)**( NY ) |UP> - (0,1) ** (1-NY) |DOWN> )
C        |T-> = NORM. * ( (0,1)**(NY-1) |UP> + (0,1) ** (-NY ) |DOWN> )
C
C        THE THIRD INDEX REPRESENTS PAULI MATRICES WITH THE ZERO VALUE
C        USED FOR THE IDENTITY MATRIX.
C
C=======================================================================
C
      CALL TPHASE(ITWCEN)
C
C=======================================================================
C
      DSQRT2=SQRT(2.0D0)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C
C        PHASPI(IBASE,ISPIN)   IS A PHASE FACTOR WHICH MULTIPLIES THE
C        ISPIN-TH COMPONENT OF THE   |NX,NY,NZ,ISPIN>   SPINOR IN THE
C        FORMULA GIVING THE BASIS IN WHICH THE MEAN FIELD HAMILTONIAN
C        HAS BEEN DIAGONALIZED
C
C=======================================================================
C
C        ISPIN=1 CORRESPONDS TO THE SPIN UP
C        ISPIN=0 CORRESPONDS TO THE SPIN DOWN
C
C=======================================================================
C
C        CURRENT CHOICE CORRESPONDS TO THE T_+ BASIS
C
C=======================================================================
C
      DO LTWCEN=1,ITWCEN
C
         DO IBASE=1,LDBATW(LTWCEN)
C
            NY=NYVECT(IBASE,LTWCEN)
C           PRINT *, NY
C
            PHASPI(IBASE,0,1,LTWCEN)=+UNIT_I**   NY /DSQRT2
            PHASPI(IBASE,0,0,LTWCEN)=-UNIT_I**(1-NY)/DSQRT2
C
         END DO
C
      END DO
C
      DO LTWCEN=1,ITWCEN
C
         DO IBASE=1,LDBATW(LTWCEN)
C
            NY=NYVECT(IBASE,LTWCEN)
C
            PHASPI(IBASE,1,1,LTWCEN)=-UNIT_I**(1+NY)/DSQRT2
            PHASPI(IBASE,1,0,LTWCEN)=+UNIT_I**( -NY)/DSQRT2
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TPHASE(ITWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          PHACOM
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /B_PHAS/ JPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                JPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /COMPHA/ PHACOM(0:NDKART)
C
C=======================================================================
C
      IFAZA(N)=((1+(-1)**N)/2)*(-1)**(N/2)
C
C=======================================================================
C
C        THIS SUBROUTINE REPRESENTS THE CENTRAL PART OF THE W H O L E
C        PROGRAM. THE PHASE CONVENTION CORRESPONDS  TO THE |T_BASIS>.
C        THE CORRESPONDING EXPRESSIONS ARE OBTAINED ASSUMING THE H.O.
C        CARTESIAN BASIS WITH THE OVERALL PHASE FACTOR:
C
C                                (0,1) ** NY
C
C        CONSEQUENTLY:
C
C        |T+> = NORM. * ((0,1)**( NY ) |UP> - (0,1) ** (1-NY) |DOWN>)
C        |T-> = NORM. * ((0,1)**(NY-1) |UP> + (0,1) ** (-NY ) |DOWN>)
C
C        THE THIRD INDEX REPRESENTS PAULI  MATRICES  WITH  ZERO VALUE
C        FOR THE IDENTITY.
C
C        W A R N I N G:   THE "T+,T+"=PP, "T+,T-"=PM, "T-,T+"=MP, AND
C                         "T-,T-"=MM  PHASES FOR  KARTEZ=3  SHOULD BE
C                         MULTIPLIED BY IMAGINARY UNIT.  HOWEVER,  IT
C                         IS  EASIER TO KEEP PHASES REAL.  THEREFORE,
C                         WE  D O  N O T  MULTIPLY   KARTEZ=3  PHASES
C                         BY i, AND  HAVE  TO  R E M E M B E R  ABOUT
C                         IT NOW AND ALWAYS TILL THE END OF THE WORLD
C
C                         THIS IMAGINARY UNIT IS PUT INTO  THE  ARRAY
C                         "PHACOM"
C
C        THIS SUBROUTINE  CALCULATES  THE PHASES FOR ALL THE 4 BLOCKS
C                         IN THE BASIS "T" (GOOD SIMPLEX BASIS FOR RY)
C
C                         BLOCK "T+,T+"  (PP)
C                         BLOCK "T+,T-"  (PM)
C                         BLOCK "T-,T+"  (MP)
C                         BLOCK "T-,T-"  (MM)
C
C=======================================================================
C
      IF (MAXVAL(NYMAXV,ITWCEN).GT.NDYMAX)
     *    STOP 'MAXVAL(NYMAXV,ITWCEN).GT.NDYMAX IN TPHASE'
C
      DO NY=0,MAXVAL(NYMAXV,ITWCEN)
         DO MY=0,MAXVAL(NYMAXV,ITWCEN)
C
C=======================================================================
C        HERE ARE THE PHASES PERTAING TO THE PARTICLE-HOLE CHANNEL
C=======================================================================
C
C                        KARTEZ
C
            IPHAPP(NY,MY,   0  )=IFAZA(NY-MY  )
            IPHAPM(NY,MY,   0  )=IFAZA(NY-MY+1)
            IPHAMP(NY,MY,   0  )=IFAZA(NY-MY-1)
            IPHAMM(NY,MY,   0  )=IFAZA(NY-MY  )
C
            IPHAPP(NY,MY,   1  )=IFAZA(NY+MY+1)
            IPHAPM(NY,MY,   1  )=IFAZA(NY+MY  )
            IPHAMP(NY,MY,   1  )=IFAZA(NY+MY  )
            IPHAMM(NY,MY,   1  )=IFAZA(NY+MY-1)
C
            IPHAPP(NY,MY,   2  )=IFAZA(NY+MY+2)
            IPHAPM(NY,MY,   2  )=IFAZA(NY+MY+1)
            IPHAMP(NY,MY,   2  )=IFAZA(NY+MY+1)
            IPHAMM(NY,MY,   2  )=IFAZA(NY+MY  )
C
            IPHAPP(NY,MY,   3  )=IFAZA(NY-MY+1)
            IPHAPM(NY,MY,   3  )=IFAZA(NY-MY+2)
            IPHAMP(NY,MY,   3  )=IFAZA(NY-MY  )
            IPHAMM(NY,MY,   3  )=IFAZA(NY-MY+1)
C
C=======================================================================
C        HERE ARE THE PHASES PERTAING TO THE PARTICLE-PARTICLE CHANNEL
C        SEE NOTES 90-E
C=======================================================================
C
C                        KARTEZ
C
            JPHAPP(NY,MY,   0  )=IFAZA(NY-MY-1)
            JPHAPM(NY,MY,   0  )=IFAZA(NY-MY  )
            JPHAMP(NY,MY,   0  )=IFAZA(NY-MY+2)
            JPHAMM(NY,MY,   0  )=IFAZA(NY-MY-1)
C
            JPHAPP(NY,MY,   1  )=IFAZA(NY+MY+2)
            JPHAPM(NY,MY,   1  )=IFAZA(NY+MY+1)
            JPHAMP(NY,MY,   1  )=IFAZA(NY+MY+1)
            JPHAMM(NY,MY,   1  )=IFAZA(NY+MY  )
C
            JPHAPP(NY,MY,   2  )=IFAZA(NY+MY-1)
            JPHAPM(NY,MY,   2  )=IFAZA(NY+MY+2)
            JPHAMP(NY,MY,   2  )=IFAZA(NY+MY+2)
            JPHAMM(NY,MY,   2  )=IFAZA(NY+MY+1)
C
            JPHAPP(NY,MY,   3  )=IFAZA(NY-MY+2)
            JPHAPM(NY,MY,   3  )=IFAZA(NY-MY-1)
            JPHAMP(NY,MY,   3  )=IFAZA(NY-MY+1)
            JPHAMM(NY,MY,   3  )=IFAZA(NY-MY+2)
C
         END DO
      END DO
C
C=======================================================================
C
      PHACOM(0)=CMPLX(1.0D0,0.0D0)
      PHACOM(1)=CMPLX(1.0D0,0.0D0)
      PHACOM(2)=CMPLX(1.0D0,0.0D0)
      PHACOM(3)=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TRUTOD(ITWCEN,LDTWCE)
C=======================================================================
      USE HE_DEN
      USE TRUINT
      USE PD_DEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DENSIC,DENCHC,DENSIU
C
      COMMON
     *       /DENTOT/ DENSIT(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHA(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENTOU/ DENSIU(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /IDENTU/ IDENSU,JDENSU
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES  T R U E  DENSITY OF PARTICLES
C        IN THE   T R U E   DENSITIES,  THE  EXPONENTIAL  FACTORS:
C                          EXP(-(ETA/SQRT(2))**2)
C        (ETA DENOTES THE GAUSS ZEROS)  ARE INCLUDED,  WHEREAS THE
C        PROGRAM USES THE EXPONENTIAL FACTORS IMPLICITLY  'HIDDEN'
C        IN THE GAUSS-HERMITE INTEGRATION WEIGHTS.
C
C        FOR JDENSU=1, A FIXED DENSITY IS SUPPOSED TO  BE  ALREADY
C        AVAILABLE IN ARRAY "DENSIU".
C=======================================================================
C
      IF (ITWCEN.EQ.2) THEN
C
          IF(ALLOCATED(DDTRHO)) DEALLOCATE(DDTRHO,DDTSPI,PDTRHO)
C
          IALLOC=0
          ALLOCATE(DDTRHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDTWHE,0:NDISOS),
     *                                                     STAT=IALLOC)
C
          IF (IALLOC.NE.0) THEN
              WRITE(NFIPRI,'(''ERROR ALLOCATING DDTRHO IN TRUTOD'')')
          END IF
C
          IALLOC=0
          ALLOCATE(DDTSPI(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,
     *                                      1:NDTWHE,0:NDISOS),
     *                                            STAT=IALLOC)
C
          IF (IALLOC.NE.0) THEN
              WRITE(NFIPRI,'(''ERROR ALLOCATING DDTSPI IN TRUTOD'')')
          END IF
C
          IALLOC=0
          ALLOCATE(PDTRHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDTWHE,0:NDISOS),
     *                                                     STAT=IALLOC)
C
          IF (IALLOC.NE.0) THEN
              WRITE(NFIPRI,'(''ERROR ALLOCATING PDTRHO IN TRUTOD'')')
          END IF
C
      END IF
C
C=======================================================================
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               IF (JDENSU.NE.1) THEN
C
                   IF (ITWCEN.EQ.1) THEN
C
                       DENSIC(IX,IY,IZ,1) =(DE_RHO(IX,IY,IZ,0,1)
     *                                    + DE_RHO(IX,IY,IZ,1,1))
     *                                    * EXPAUX(IX,IY,IZ,1)
C
                       DENSIT(IX,IY,IZ,1) = REAL(DENSIC(IX,IY,IZ,1))
C
                   ELSEIF (ITWCEN.EQ.2) THEN
C
                       DO LTWCEN=1,LDTWCE
C
                       IF (LTWCEN.EQ.1) THEN
C
                           IEXP11=1
                           IEXP22=17
                           IEXP21=18
                           IEXP12=23
C
                       ELSEIF (LTWCEN.EQ.2.OR.LTWCEN.EQ.3.OR.
     *                         LTWCEN.EQ.5.OR.LTWCEN.EQ.9) THEN
C
                           IEXP11=5
                           IEXP22=19
                           IEXP21=3
                           IEXP12=2
C
                       ELSEIF (LTWCEN.EQ.4 .OR.LTWCEN.EQ.6 .OR.
     *                         LTWCEN.EQ.7 .OR.LTWCEN.EQ.10.OR.
     *                         LTWCEN.EQ.11.OR.LTWCEN.EQ.13) THEN
C
                           IEXP11=13
                           IEXP22=4
                           IEXP21=7
                           IEXP12=6
C
                       ELSEIF (LTWCEN.EQ.8 .OR.LTWCEN.EQ.12.OR.
     *                         LTWCEN.EQ.14.OR.LTWCEN.EQ.15) THEN
C
                           IEXP11=20
                           IEXP22=8
                           IEXP21=15
                           IEXP12=14
C
                       ELSEIF (LTWCEN.EQ.16) THEN
C
                           IEXP11=21
                           IEXP22=16
                           IEXP21=22
                           IEXP12=24
C
                       END IF
C
C=======================================================================
C     PARTICLE DENSITY-DEPENDENT TERMS
C=======================================================================
C
                       DDTRHO(IX,IY,IZ,LTWCEN,0) =
     *                 DE_RHO(IX,IY,IZ,0,IEXP11)*EXPAUX(IX,IY,IZ,IEXP11)
     *           +     DE_RHO(IX,IY,IZ,0,IEXP22)*EXPAUX(IX,IY,IZ,IEXP22)
     *           +     2.D0 *REAL(DE_RHO(IX,IY,IZ,0,IEXP21))
     *           *                               EXPAUX(IX,IY,IZ,IEXP21)

                       DDTRHO(IX,IY,IZ,LTWCEN,1) =
     *                 DE_RHO(IX,IY,IZ,1,IEXP11)*EXPAUX(IX,IY,IZ,IEXP11)
     *           +     DE_RHO(IX,IY,IZ,1,IEXP22)*EXPAUX(IX,IY,IZ,IEXP22)
     *           +     2.D0 *REAL(DE_RHO(IX,IY,IZ,1,IEXP21))
     *           *                               EXPAUX(IX,IY,IZ,IEXP21)
C
                       DENSIC(IX,IY,IZ,LTWCEN)=
     *                 DDTRHO(IX,IY,IZ,LTWCEN,0)
     *           +     DDTRHO(IX,IY,IZ,LTWCEN,1)
C
                       DENSIT(IX,IY,IZ,LTWCEN) =
     *                 REAL(DENSIC(IX,IY,IZ,LTWCEN))
C
! FOR PAIRING-DENSITY DEPENDENT TERMS
                       PDTRHO(IX,IY,IZ,LTWCEN,0) =
     *                 PD_RHO(IX,IY,IZ,0,IEXP11)*EXPAUX(IX,IY,IZ,IEXP11)
     *           +     PD_RHO(IX,IY,IZ,0,IEXP22)*EXPAUX(IX,IY,IZ,IEXP22)
     *           +     PD_RHO(IX,IY,IZ,0,IEXP21)*EXPAUX(IX,IY,IZ,IEXP21)
     *           +     PD_RHO(IX,IY,IZ,0,IEXP12)*EXPAUX(IX,IY,IZ,IEXP12)

                       PDTRHO(IX,IY,IZ,LTWCEN,1) =
     *                 PD_RHO(IX,IY,IZ,1,IEXP11)*EXPAUX(IX,IY,IZ,IEXP11)
     *           +     PD_RHO(IX,IY,IZ,1,IEXP22)*EXPAUX(IX,IY,IZ,IEXP22)
     *           +     PD_RHO(IX,IY,IZ,1,IEXP21)*EXPAUX(IX,IY,IZ,IEXP21)
     *           +     PD_RHO(IX,IY,IZ,1,IEXP12)*EXPAUX(IX,IY,IZ,IEXP12)
C
C
C=======================================================================
C     SPIN DENSITY-DEPENDENT TERMS
C=======================================================================
C
                       DO K=1,NDKART
C
                     DDTSPI(IX,IY,IZ,K,LTWCEN,0) =
     *               DE_SPI(IX,IY,IZ,K,0,IEXP11)*EXPAUX(IX,IY,IZ,IEXP11)
     *           +   DE_SPI(IX,IY,IZ,K,0,IEXP22)*EXPAUX(IX,IY,IZ,IEXP22)
     *           +     2.D0 *REAL(DE_SPI(IX,IY,IZ,K,0,IEXP21))
     *           *                               EXPAUX(IX,IY,IZ,IEXP21)

                     DDTSPI(IX,IY,IZ,K,LTWCEN,1) =
     *               DE_SPI(IX,IY,IZ,K,1,IEXP11)*EXPAUX(IX,IY,IZ,IEXP11)
     *           +   DE_SPI(IX,IY,IZ,K,1,IEXP22)*EXPAUX(IX,IY,IZ,IEXP22)
     *           +     2.D0 *REAL(DE_SPI(IX,IY,IZ,K,1,IEXP21))
     *           *                               EXPAUX(IX,IY,IZ,IEXP21)
C
                       END DO
C
                      END DO
C
                   END IF
C
               ELSE
C
                   DENSIC(IX,IY,IZ,1) = DENSIU(IX,IY,IZ)
C
               END IF
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TRUCHD
C=======================================================================
      USE HE_DEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DENSIC,DENCHC
C
      COMMON
     *       /DENTOT/ DENSIT(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHA(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENTOC/ DENSIC(NDXHRM,NDYHRM,NDZHRM,NDTWHE),
     *                DENCHC(NDXHRM,NDYHRM,NDZHRM)
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES  T R U E  DENSITY  OF  CHARGE.
C        IN THE   T R U E   DENSITIES, THE  EXPONENTIAL   FACTORS:
C                          EXP(-(ETA/SQRT(2))**2)
C        (ETA DENOTES THE GAUSS ZEROS)  ARE INCLUDED,  WHEREAS THE
C        PROGRAM USES THE EXPONENTIAL FACTORS IMPLICITLY  'HIDDEN'
C        IN THE GAUSS-HERMITE INTEGRATION WEIGHTS.
C=======================================================================
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               DENCHC(IX,IY,IZ) =DE_RHO(IX,IY,IZ,1,1)*EXPAUX(IX,IY,IZ,1)
C
               DENCHA(IX,IY,IZ) = REAL(DENCHC(IX,IY,IZ))
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SAVDIS
C=======================================================================
      USE HE_DEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMPLEX
     *          DENDIS
C
      COMMON
     *       /DISDEN/ DENDIS(NDXHRM,NDYHRM,NDZHRM,0:NDISOS)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE "DIV S" DENSITIES AND STORES
C        THEM IN THE "DENDIS"  ARRAY FOR NEUTRONS AND PROTONS.
C=======================================================================
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
               DENDIS(IX,IY,IZ,0) = CMPLX(0.0D0,0.0D0)
               DENDIS(IX,IY,IZ,1) = CMPLX(0.0D0,0.0D0)
C
               DO K=1,NDKART
                   DENDIS(IX,IY,IZ,0) = DENDIS(IX,IY,IZ,0)+
     *                                  DE_DES(IX,IY,IZ,K,K,0,1)
                   DENDIS(IX,IY,IZ,1) = DENDIS(IX,IY,IZ,1)+
     *                                  DE_DES(IX,IY,IZ,K,K,1,1)
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEFEXP(ITWCEN,LDTWDD)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /INTSTO/ FOURWG(1:NDGAUS,1:NDKART),
     *                FOURPT(1:NDGAUS,1:NDKART)
C
      COMMON
     *       /DENEXP/ EXPAUX(NDXHRM,NDYHRM,NDZHRM,NDTWDD)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /TWPOIN/ XZERLE(1:NDGAUS,1:NDKART,1:NDTWDD),
     *                XZERRI(1:NDGAUS,1:NDKART,1:NDTWDD),
     *                PNTWC4(1:NDGAUS,1:NDKART,1:NDTWHE)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES  THE EXPONENTIAL FACTORS:
C                          EXP(-(ETA/SQRT(2))**2)
C        (ETA DENOTES THE GAUSS ZEROS).
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          DO IZ=1,NZHERM
             DO IY=1,NYHERM
                DO IX=1,NXHERM
C
                   EXPAUX(IX,IY,IZ,1)=EXP(-(FOURPT(IX,1)**2
     *                                     +FOURPT(IY,2)**2
     *                                     +FOURPT(IZ,3)**2))
C
                END DO
             END DO
          END DO
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          DO LTWCEN=1,LDTWDD
C
             DO IZ=1,NZHERM
                DO IY=1,NYHERM
                   DO IX=1,NXHERM
C
                      EXPAUX(IX,IY,IZ,LTWCEN)=
     *                EXP(-0.5D0*(XZERLE(IX,1,LTWCEN)**2
     *                           +XZERLE(IY,2,LTWCEN)**2
     *                           +XZERLE(IZ,3,LTWCEN)**2)
     *                    -0.5D0*(XZERRI(IX,1,LTWCEN)**2
     *                           +XZERRI(IY,2,LTWCEN)**2
     *                           +XZERRI(IZ,3,LTWCEN)**2))
C
                   END DO
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE D_HERM(XD,N,HERD,DHERD,NDIM)
      IMPLICIT REAL*16 (A-H,O-Z)
      REAL XD,HERD,DHERD
      DIMENSION
     *          HER(NDIM),DHER(NDIM)
      DIMENSION
     *          HERD(NDIM),DHERD(NDIM)
C
C=======================================================================
C
C         D_HERM CALCULATES HERMITE POLYNOMIALS AT POINT X UP TO N-TH
C         DEGREE. IT  ALSO CALCULATES  DERIVATIVES  DHER(I)  OF THESE
C         POLYNOMIALS.
C                            DHER(I)=2*I*HER(I-1)
C=======================================================================
C
      X=XD
C
      HER (1)=1.0Q0
      DHER(1)=0.0Q0
C
      HERD (1)=HER (1)
      DHERD(1)=DHER(1)
C
      IF (N.LE.0) RETURN
C
      HER (2)=X + X
      DHER(2)=2.0Q0
C
      HERD (2)=HER (2)
      DHERD(2)=DHER(2)
C
      IF (N.LE.1) RETURN
C
      DO I=2,N
C
         F=X*HER(I)-(I-1)*HER(I-1)
         HER(I+1)=F+F
C
         DF=(I)*HER(I)
         DHER(I+1)=DF+DF
C
      END DO
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (3.23W)  AND  (3.24C),  STATEMENTS
C                    BELOW WERE INCORRECTLY CODED AND THE CODE  WAS  NOT
C                    GIVING MEANINGFUL RESULTS. THIS BUG  WAS  CORRECTED
C                    ON 28/02/2024 IN VERSION (3.22D).
C=======================================================================
C
      HERD (2:N+1)=HER (2:N+1)
      DHERD(2:N+1)=DHER(2:N+1)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE D_HERQ(XD,N,HER,DHER,NDIM)
      IMPLICIT REAL*16 (A-H,O-Z)
      DIMENSION
     *          HER(NDIM),DHER(NDIM)
C
C=======================================================================
C
C         IDENTICAL TO D_HERM BUT IN QUADRUPLE PRECISION.
C
C         D_HERQ CALCULATES HERMITE POLYNOMIALS AT POINT X UP TO N-TH
C         DEGREE. IT  ALSO CALCULATES  DERIVATIVES  DHER(I)  OF THESE
C         POLYNOMIALS.
C                            DHER(I)=2*I*HER(I-1)
C=======================================================================
C
      TWO=2
C
      X=XD
C
      HER (1)=1
      DHER(1)=0
C
      IF (N.LE.0) RETURN
C
      HER (2)=X + X
      DHER(2)=TWO
C
      IF (N.LE.1) RETURN
C
      DO I=2,N
C
         F=X*HER(I)-(I-1)*HER(I-1)
         HER(I+1)=F+F
C
         DF=(I)*HER(I)
         DHER(I+1)=DF+DF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ORDER1(EL,KL,N)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          EL(NFIRST:N),KL(NFIRST:N)
      DIMENSION
     *          EM(NFIRST:NLAST),KM(NFIRST:NLAST)
      DIMENSION
     *          KWHER(NFIRST:NLAST),
     *          KFROM(NFIRST:NLAST)
C
C=======================================================================
C         THIS ROUTINE PERFORMS THE ORDERING OF THE VECTOR EL, RECORDING
C         AS WELL THE INFORMATION ABOUT THE ORIGINAL ORDER (STORE:  KL )
C=======================================================================
C
      IF (N.GT.NLAST) STOP 'NLAST TOO SMALL IN ORD'
C
      IF (N.LE.NFIRST) RETURN
C
C=======================================================================
C         REWRITING INPUT ARRAYS TO AUXILIARY ONES
C=======================================================================
C
      DO I=NFIRST,N
         KWHER(I)=NFIRST
         EM(I)=EL(I)
         KM(I)=KL(I)
      END DO
C
C=======================================================================
C        HOW MANY ELEMENTS ARE SMALLER THAN THE I-TH ONE? ANOTHER WORDS
C        WHERE SHOULD IT GO WITH RESPECT TO THE OFFSET POSITION NFIRST?
C=======================================================================
C
      DO J=NFIRST,N
         DO I=NFIRST,N
C
            IF (EM(J).LT.EM(I)) KWHER(I)=KWHER(I)+1
C
         END DO
      END DO
C
C=======================================================================
C        NOW WE ONLY HAVE TO RESOLVE THE CASE OF IDENTICAL ELEMENTS
C=======================================================================
C        FROM WHERE THE I-TH ELEMENT SHOULD COME?
C=======================================================================
C
      DO I=NFIRST,N
         KFROM(I)=NFIRST-1
      END DO
C
      DO I=NFIRST,N
         KFROM(KWHER(I))=I
      END DO
C
C=======================================================================
C        IF SOME ELEMENTS ARE EQUAL THERE WILL BE UNFILLED PLACES
C        IN THE KFROM  ARRAY. FILL THEM UP NOW.
C=======================================================================
C
    1 DO I=NFIRST,N
         IF (KFROM(I).EQ.NFIRST-1) THEN
            IEQUAL=I-1
            IFILLL=I-1
            GO TO 2
         END IF
      END DO
C
      GO TO 3
C
    2 DO I=NFIRST,N
C
         IF (KWHER(I).EQ.IEQUAL) THEN
            KFROM(IFILLL)=I
            IFILLL=IFILLL+1
         END IF
C
      END DO
C
      GO TO 1
C
    3 CONTINUE
C
C=======================================================================
C        FINALLY WE MAY REWRITE THE INPUT ARRAYS IN THE RIGHT ORDER
C=======================================================================
C
      DO I=NFIRST,N
         EL(I)=EM(KFROM(I))
         KL(I)=KM(KFROM(I))
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PARAMS(SKYRME,LANODD,LANSCA,HBMSAT,RHOSAT,EFFSAT,
     *                 ISTAND,
     *                 KETA_J,KETA_W,KETACM,KETA_M,KETA_P,KETA_T,KETAPA,
     *                 JETA_J,JETA_W,JETACM,JETA_M,JETA_P,JETA_T,JETAPA)
C=======================================================================
      USE hfodd_functional
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *            SKYRME*4,NCPALL*4
      CHARACTER
     *            NRHO_N*4,NRHODN*4,
     *            NLPR_N*4,
     *            NTAU_N*4,
     *            NSCU_N*4,
     *            NDIV_N*4,
     *            NSPI_N*4,NSPIDN*4,
     *            NLPS_N*4,
     *            NCUR_N*4,
     *            NKIS_N*4,
     *            NROT_N*4,
     *            NSCT_N*4,
     *            NKIT_N*4,
     *            NSPT_N*4
      CHARACTER
     *            NSCR_N*4,
     *            NDIS_N*4,
     *            NDSR_N*4,
     *            NSCS_N*4,
     *            NSCJ_N*4,
     *            NCUS_N*4,
     *            NROS_N*4,
     *            NDES_N*4,
     *            NRHSXN*4,
     *            NRHSYN*4,
     *            NRHSZN*4,
     *            NRHCXN*4,
     *            NRHCYN*4,
     *            NRHCZN*4
C
      DIMENSION
     *             CCPALL(NDCOUT), NCPALL(NDCOUT/2)
      DIMENSION
     *             STSALL(NDCOUT), SPMALL(NDCOUT)
      DIMENSION
     *             ATSALL(NDCOUT), APMALL(NDCOUT)
      EQUIVALENCE
     *            (CCPALL,CRHO_T),(NCPALL,NRHO_N)
      EQUIVALENCE
     *            (STSALL,SRHO_T),(SPMALL,SRHO_P)
      EQUIVALENCE
     *            (ATSALL,ARHO_T),(APMALL,ARHO_P)
C
      COMMON
     *       /STSSKY/ SRHO_T,SRHO_S,SRHODT,SRHODS,
     *                SLPR_T,SLPR_S,
     *                STAU_T,STAU_S,
     *                SSCU_T,SSCU_S,
     *                SDIV_T,SDIV_S,
     *                SSPI_T,SSPI_S,SSPIDT,SSPIDS,
     *                SLPS_T,SLPS_S,
     *                SCUR_T,SCUR_S,
     *                SKIS_T,SKIS_S,
     *                SROT_T,SROT_S,
     *                SSCT_T,SSCT_S,
     *                SKIT_T,SKIT_S,
     *                SSPT_T,SSPT_S
      COMMON
     *       /SPMSKY/ SRHO_P,SRHO_M,SRHODP,SRHODM,
     *                SLPR_P,SLPR_M,
     *                STAU_P,STAU_M,
     *                SSCU_P,SSCU_M,
     *                SDIV_P,SDIV_M,
     *                SSPI_P,SSPI_M,SSPIDP,SSPIDM,
     *                SLPS_P,SLPS_M,
     *                SCUR_P,SCUR_M,
     *                SKIS_P,SKIS_M,
     *                SROT_P,SROT_M,
     *                SSCT_P,SSCT_M,
     *                SKIT_P,SKIT_M,
     *                SSPT_P,SSPT_M
      COMMON
     *       /ATSSKY/ ARHO_T,ARHO_S,ARHODT,ARHODS,
     *                ALPR_T,ALPR_S,
     *                ATAU_T,ATAU_S,
     *                ASCU_T,ASCU_S,
     *                ADIV_T,ADIV_S,
     *                ASPI_T,ASPI_S,ASPIDT,ASPIDS,
     *                ALPS_T,ALPS_S,
     *                ACUR_T,ACUR_S,
     *                AKIS_T,AKIS_S,
     *                AROT_T,AROT_S,
     *                ASCT_T,ASCT_S,
     *                AKIT_T,AKIT_S,
     *                ASPT_T,ASPT_S
      COMMON
     *       /APMSKY/ ARHO_P,ARHO_M,ARHODP,ARHODM,
     *                ALPR_P,ALPR_M,
     *                ATAU_P,ATAU_M,
     *                ASCU_P,ASCU_M,
     *                ADIV_P,ADIV_M,
     *                ASPI_P,ASPI_M,ASPIDP,ASPIDM,
     *                ALPS_P,ALPS_M,
     *                ACUR_P,ACUR_M,
     *                AKIS_P,AKIS_M,
     *                AROT_P,AROT_M,
     *                ASCT_P,ASCT_M,
     *                AKIT_P,AKIT_M,
     *                ASPT_P,ASPT_M
      COMMON
     *       /NCPSKY/ NRHO_N,NRHODN,
     *                NLPR_N,
     *                NTAU_N,
     *                NSCU_N,
     *                NDIV_N,
     *                NSPI_N,NSPIDN,
     *                NLPS_N,
     *                NCUR_N,
     *                NKIS_N,
     *                NROT_N,
     *                NSCT_N,
     *                NKIT_N,
     *                NSPT_N
      COMMON
     *       /CCPSKY/ CRHO_T,CRHO_S,CRHODT,CRHODS,
     *                CLPR_T,CLPR_S,
     *                CTAU_T,CTAU_S,
     *                CSCU_T,CSCU_S,
     *                CDIV_T,CDIV_S,
     *                CSPI_T,CSPI_S,CSPIDT,CSPIDS,
     *                CLPS_T,CLPS_S,
     *                CCUR_T,CCUR_S,
     *                CKIS_T,CKIS_S,
     *                CROT_T,CROT_S,
     *                CSCT_T,CSCT_S,
     *                CKIT_T,CKIT_S,
     *                CSPT_T,CSPT_S
      COMMON
     *       /CCPTEN/ TLPSET,TLPSES,
     *                TKISET,TKISES,
     *                TSCUET,TSCUES,
     *                TLPSOT,TLPSOS,
     *                TKISOT,TKISOS,
     *                TSCUOT,TSCUOS,
     *
     *                TKITET,TKITES,
     *                TSCTET,TSCTES,
     *                TSPTET,TSPTES,
     *                TKITOT,TKITOS,
     *                TSCTOT,TSCTOS,
     *                TSPTOT,TSPTOS
      COMMON
     *       /CCPSKP/ PRHO_0,PRHOD0,PTAU_1,PTAU_2,PLPR_0,PSCU_1,
     *                PSCU_2,PSCU_3
      COMMON
     *       /MCPSKY/ NSCR_N,
     *                NDIS_N,
     *                NDSR_N,
     *                NSCS_N,
     *                NSCJ_N,
     *                NCUS_N,
     *                NROS_N,
     *                NDES_N,
     *                NRHSXN,
     *                NRHSYN,
     *                NRHSZN,
     *                NRHCXN,
     *                NRHCYN,
     *                NRHCZN
      COMMON
     *       /EDFINP/ IF_EDF
     *       /EDFPAR/ V0NEFF,V0PEFF,COUSCA
      COMMON
     *       /INTSKY/ T0,X0,T1,X1,T2,X2,T3,X3,W0,POWER
      COMMON
     *       /SKYINP/ T0_INP,X0_INP,T1_INP,X1_INP,T2_INP,X2_INP,
     *                T3_INP,X3_INP,WW_INP,PO_INP
      COMMON
     *       /INTSKT/ TETENS,TOTENS
      COMMON
     *       /INTINP/ TEINPU,TOINPU
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /SO_PAR/ W0_INP,W0PINP
      COMMON
     *       /CCPPAI/ PRHO_N,PRHODN,PRHOSN,POWERN,
     *                PRHO_P,PRHODP,PRHOSP,POWERP
      COMMON
     *       /ATWOBO/ TWOBOD,TWOINP,ITWOIN
      COMMON
     *       /ATHREE/ THREEB,THRINP,ITHRIN
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /AFOURB/ FOURBD,FOUINP,IFOUIN
      COMMON
     *       /CBRPA2/ T02CBR,X02CBR,
     *                T12CBR,X12CBR,
     *                T22CBR,X22CBR
     *       /CBRPA3/ T03CBR,X03CBR,
     *                T13CBR,X13CBR,
     *                T23CBR,X23CBR
     *       /CBRSWI/ I_2CBR,I_3CBR
      COMMON
     *       /CC2CBR/ CR2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CS2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CT2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CK2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CL2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CP2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CC2CBR(0:NDISOS,0:NDISOS,0:1),
     *                CJ2CBR(0:NDISOS,0:NDISOS,0:1)
     *       /CC3CBR/ CR3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CS3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CT3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CK3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CL3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CP3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CC3CBR(0:NDISOS,0:NDISOS,0:1),
     *                CJ3CBR(0:NDISOS,0:NDISOS,0:1)
     *       /GC2CBR/ GR2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GS2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GT2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GK2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GL2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GP2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GC2CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GJ2CBR(0:NDISOS,0:NDISOS,0:1,0:2)
     *       /GC3CBR/ GR3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GS3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GT3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GK3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GL3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GP3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GC3CBR(0:NDISOS,0:NDISOS,0:1,0:2),
     *                GJ3CBR(0:NDISOS,0:NDISOS,0:1,0:2)
      COMMON
     *       /DPOWER/ POWERD
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DEFINES PARAMETERS OF THE  SKYRME  FUNCTIONAL
C=======================================================================
C         THE PARAMETERS OF THE SKYRME  FORCE  "SKYRME"  ARE  FIXED  BY
C         GIVING THE EXPLICIT VALUES THAT ARE STANDARD FOR  EACH  FORCE.
C         THE STANDARD VALUES INCLUDE PARAMETERS "IETA_J", "IETA_W" AND
C         "IETACM" (THAT DEFINE THE  WAY  THE  "J^2",  SPIN-ORBIT,  AND
C         CENTER-OF-MASS TERMS HAVE TO BE HANDLED FOR THE GIVEN  FORCE).
C         THESE STANDARD  VALUES ARE USED  FOR  ISTAND = 1,  WHILE  FOR
C         ISTAND = 0 ONE USES  THE  CORRESPONDING  PARAMETERS  "KETA_J",
C         "KETA_W", AND "KETACM".
C=======================================================================
C         THE STANDARD PARAMETERS ALSO INCLUDE THE VALUE OF MASS HBMSKY.
C=======================================================================
C         IETA_J DEFINES THE TREATMENT OF THE "J^2" TERMS:
C         IETA_J=0  ==>  "J^2" TERMS ARE OMITTED.
C         IETA_J=1  ==>  "J^2" TERMS ARE INCLUDED.
C=======================================================================
C         IETA_W DEFINES THE TREATMENT OF THE SPIN-ORBIT TERMS:
C         IETA_W=0  ==>  SPIN-ORBIT TERMS TAKEN FROM THE SKYRME FORCE.
C         IETA_W=1  ==>  SPIN-ORBIT TERMS GENERALIZED (REINHARD-FLOCARD)
C         IETA_W=2  ==>  SPIN-ORBIT PARAMETERS READ FROM THE INPUT DATA.
C=======================================================================
C         IETACM DEFINES THE TREATMENT OF THE CENTER-OF-MASS (CM) TERMS:
C         IETACM=0  ==>  CM TERMS BEFORE VARIATION (DIRECT PART ONLY).
C         IETACM=1  ==>  CM TERMS AFTER  VARIATION (FULL TWO-BODY).
C         IETACM=2  ==>  CM TERMS BEFORE VARIATION (FULL TWO-BODY).
C         IETACM=3  ==>  CM TERMS NOT INCLUDED.
C=======================================================================
C         IETA_M DEFINES THE TREATMENT OF THE MASS TERM (HBMASS).
C         IETA_M=0  ==>  MASS TERM AS IN THE OLDER VERSIONS OF HFODD.
C         IETA_M=1  ==>  MASS TERM CONSISTENT WITH THE GIVEN FORCE.
C         IETA_M=2  ==>  MASS TERM READ FROM THE INPUT DATA.
C=======================================================================
C         IETA_P DEFINES THE TREATMENT OF THE POWER OF THE
C                        DENSITY-DEPENDENT TERM (POWERD).
C         IETA_P=1  ==>  POWER CONSISTENT WITH THE GIVEN FORCE.
C         IETA_P=2  ==>  POWER READ FROM THE INPUT DATA.
C=======================================================================
C         IETA_T DEFINES THE TREATMENT OF THE SKYRME TENSOR INTERACTION.
C         IETA_T=0  ==>  TENSOR INTERACTION NOT INCLUDED.
C         IETA_T=1  ==>  TENSOR INTERACTION FROM THE GIVEN FORCE.
C         IETA_T=2  ==>  TENSOR INTERACTION READ FROM THE INPUT DATA.
C=======================================================================
C         IETAPA DEFINES THE TREATMENT OF THE SKYRME PAIRING INTERACTION
C         IETAPA=0  ==>  SKYRME PAIRING INTERACTION NOT INCLUDED.
C         IETAPA=1  ==>  SKYRME PAIRING INTERACTION FROM THE GIVEN FORCE
C         IETAPA=2  ==>  SKYRME PAIRING FROM SPIN-ORBIT NOT INCLUDED.
C=======================================================================
C
      T0 = +.0000000D+04
      X0 = +.0000000D+00
C
      T1 = +.0000000D+03
      X1 = +.0000000D+00
C
      T2 = +.0000000D+02
      X2 = +.0000000D+00
C
      T3 = +.0000000D+05
      X3 = +.0000000D+01
C
      W0 = +.0000000D+00
      W0P= +.0000000D+00
C
      B4 = +.0000000D+00
      B4P= +.0000000D+00
C
      POWER = .10000D+01
C
      TETENS = +.0000000D+00
      TOTENS = +.0000000D+00
C
      TE_THO = +.0000000D+00
      TO_THO = +.0000000D+00
C
      IETA_J = 1
      IETA_W = 0
      IETACM = 0
      IETA_M = 1
      IETA_P = 1
      IETA_T = 0
      IETAPA = 0
C
      COUSCA = 1.0D0
C
      HBMSKY = 20.73620941D0
      RHOSKY = -1.00000000D0
      EFFSKY = -1.00000000D0
C
      THREEB = +.0000000D+00
      FOURBD = +.0000000D+00
C
      CR2CBR = +.0000000D+00
      CS2CBR = +.0000000D+00
      CT2CBR = +.0000000D+00
      CK2CBR = +.0000000D+00
      CL2CBR = +.0000000D+00
      CP2CBR = +.0000000D+00
      CC2CBR = +.0000000D+00
      CJ2CBR = +.0000000D+00
C
      CR3CBR = +.0000000D+00
      CS3CBR = +.0000000D+00
      CT3CBR = +.0000000D+00
      CK3CBR = +.0000000D+00
      CL3CBR = +.0000000D+00
      CP3CBR = +.0000000D+00
      CC3CBR = +.0000000D+00
      CJ3CBR = +.0000000D+00
C
      GR2CBR = +.0000000D+00
      GS2CBR = +.0000000D+00
      GT2CBR = +.0000000D+00
      GK2CBR = +.0000000D+00
      GL2CBR = +.0000000D+00
      GP2CBR = +.0000000D+00
      GC2CBR = +.0000000D+00
      GC2CBR = +.0000000D+00
C
      GR3CBR = +.0000000D+00
      GS3CBR = +.0000000D+00
      GT3CBR = +.0000000D+00
      GK3CBR = +.0000000D+00
      GL3CBR = +.0000000D+00
      GP3CBR = +.0000000D+00
      GC3CBR = +.0000000D+00
      GC3CBR = +.0000000D+00
C
C=======================================================================
C
      ISKYRM=0
C
C=======================================================================
C
      IF (SKYRME.EQ.'ZERO') THEN
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'T3X3') THEN
C
          T3 = -.6772500D+04
          X3 = +.4500000D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'T0X0') THEN
C
          T0 = -.1128750D+04
          X0 = +.4500000D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'DELT') THEN
C
          T0 = -.4000000D+03
          X0 = -.1000000D+01
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'ATOM') THEN
C
          T0 = -.1000000D+01
          X0 = -.1000000D+01
C
          HBMSKY = 3.0D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'T0T3') THEN
C
          T0 = -.1128750D+04
          X0 = +.4500000D+00
C
          T3 = +.1400000D+05
          X3 = +.1000000D+01
C
          POWER = .10000D+01
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'T03W') THEN
C
          T0 = -.1128750D+04
          X0 = +.4500000D+00
C
          T3 = +.1400000D+05
          X3 = +.1000000D+01
C
          POWER = .10000D+01
C
          W0 = +.1200000D+03
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'NOW0') THEN
C
          T0 = -.1128750D+04
          X0 = +.4500000D+00
C
          T1 = +.3950000D+03
          X1 = +.0000000D+00
C
          T2 = -.9500000D+02
          X2 = +.0000000D+00
C
          T3 = +.1400000D+05
          X3 = +.1000000D+01
C
          POWER = .10000D+01
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'T013') THEN
C
          T0 = -.1128750D+04
          X0 = +.4500000D+00
C
          T1 = +.3950000D+03
          X1 = +.0000000D+00
C
          T3 = +.1400000D+05
          X3 = +.1000000D+01
C
          POWER = .10000D+01
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'T023') THEN
C
          T0 = -.1128750D+04
          X0 = +.4500000D+00
C
          T2 = -.9500000D+02
          X2 = +.0000000D+00
C
          T3 = +.1400000D+05
          X3 = +.1000000D+01
C
          POWER = .10000D+01
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SII----
C=======================================================================
C
      IF (SKYRME.EQ.'SII ') THEN
C
          T0 = -.1169900D+04
          X0 = +.3400000D+00
C
          T1 = +.5866000D+03
          X1 = +.0000000D+00
C
          T2 = -.2710000D+02
          X2 = +.0000000D+00
C
          T3 = +.0933110D+05
          X3 = +.1000000D+01
C
          W0 = +.1050000D+03
C
          POWER = .10000D+01
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.730D0
          RHOSKY =  0.145D0
          EFFSKY =  0.580D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SIII----
C=======================================================================
C
      IF (SKYRME.EQ.'SIII') THEN
C
          T0 = -.1128750D+04
          X0 = +.4500000D+00
C
          T1 = +.3950000D+03
          X1 = +.0000000D+00
C
          T2 = -.9500000D+02
          X2 = +.0000000D+00
C
          T3 = +.1400000D+05
          X3 = +.1000000D+01
C
          W0 = +.1200000D+03
C
          POWER = .10000D+01
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73533D0
          RHOSKY =  0.14500D0
          EFFSKY =  0.76300D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SV----
C=======================================================================
C
      IF (SKYRME.EQ.'SV  ') THEN
C
          T0 = -.1248290D+04
          X0 = -.1700000D+00
C
          T1 = +.9705600D+03
          X1 = +.0000000D+00
C
          T2 = +.1072200D+03
          X2 = +.0000000D+00
C
          T3 = +.0000000D+00
          X3 = +.1000000D+01
C
          W0 = +.1500000D+03
C
          POWER = .10000D+01
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SVT----
C=======================================================================
C
      IF (SKYRME.EQ.'SVT ') THEN
C
          T0 = -.1248290D+04
          X0 = -.1700000D+00
C
          T1 = +.9705600D+03
          X1 = +.0000000D+00
C
          T2 = +.1072200D+03
          X2 = +.0000000D+00
C
          T3 = +.0000000D+00
          X3 = +.1000000D+01
C
          W0 = +.1500000D+03
C
          POWER = .10000D+01
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SVI----
C=======================================================================
C
      IF (SKYRME.EQ.'SVI ') THEN
C
          T0 = -.1101810D+04
          X0 = +.5830000D+00
C
          T1 = +.2716700D+03
          X1 = +.0000000D+00
C
          T2 = -.1383300D+03
          X2 = +.0000000D+00
C
          T3 = +.1700000D+05
          X3 = +.1000000D+01
C
          W0 = +.1150000D+03
C
          POWER = .10000D+01
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.730D0
          RHOSKY =  0.145D0
          EFFSKY =  0.950D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SHZ1----
C=======================================================================
C
      ! fit to 4 nuclei (see file sv_4nucrep.r)
      IF (SKYRME.EQ.'SHZ1') THEN
C
          T0 = -0.12240267D+04
          X0 = +0.11260714D+00
C
          T1 = +0.97628621D+03
          X1 = +.000000000D+00
C
          T2 = +0.58213207D+02
          X2 = +0.00000000D+00
C
          T3 = +.000000000D+00
          X3 = +.100000000D+01
C
          W0 = +.1500000D+03
C
          POWER = .10000D+01
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SHZ2----
C=======================================================================
C
      ! fit to 5 nuclei (see file sv_5nuc5p.r)
      IF (SKYRME.EQ.'SHZ2') THEN
C
          T0 = -0.12449883D+04
          X0 = +0.19062507D-01
C
          T1 = +0.97001156D+03
          X1 = +0.00000000D+00
C
          T2 = +0.99501971D+02
          X2 = +0.00000000D+00
C
          T3 = +0.00000000D+00
          X3 = +0.10000000D+01
C
          W0 = +.1500000D+03
C
          POWER = .10000D+01
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKM*----
C=======================================================================
C
      IF (SKYRME.EQ.'SKM*') THEN
C
          T0 = -.2645000D+04
          X0 = +.0900000D+00
C
          T1 = +.4100000D+03
          X1 = +.0000000D+00
C
          T2 = -.1350000D+03
          X2 = +.0000000D+00
C
          T3 = +.1559500D+05
          X3 = +.0000000D+00
C
          W0 = +.1300000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
C=======================================================================
C         ATTENTION: IN ALL VERSIONS AFTER 1.93B AND BEFORE  2.05F,  THE
C                    VALUE OF VARIABLE "HBMSKY" FOR THE SKM*  FORCE  WAS
C                    INCORRECTLY SET TO 20.7525. THIS BUG WAS  CORRECTED
C                    IN VERSION 2.05F ON 07/12/2003.
C=======================================================================
C
          HBMSKY = 20.730D0
          RHOSKY =  0.160D0
          EFFSKY =  0.789D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKP----
C=======================================================================
C
      IF (SKYRME.EQ.'SKP ') THEN
C
          T0 = -.2931696D+04
          X0 = 0.2921515D+00
C
          T1 = 0.3206182D+03
          X1 = 0.6531765D+00
C
          T2 = -.3374091D+03
          X2 = -.5373230D+00
C
          T3 = 0.1870896D+05
          X3 = 0.1810269D+00
C
          W0 = 0.1000000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.730D0
          RHOSKY =  0.162D0
          EFFSKY =  1.000D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKMP----
C=======================================================================
C
      IF (SKYRME.EQ.'SKMP') THEN
C
          T0 = -.237224D+04
          X0 = -.157563D+00
C
          T1 = 0.503623D+03
          X1 = -.402886D+00
C
          T2 = 0.572783D+02
          X2 = -.295571D+01
C
          T3 = 0.125853D+05
          X3 = -.267933D+00
C
          W0 = 0.1600000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKI1----
C=======================================================================
C
      IF (SKYRME.EQ.'SKI1') THEN
C
          T0 = -.1913623D+04
          X0 = -.9545340D+00
C
          T1 = 0.4398080D+03
          X1 =-5.7824040D+00
C
          T2 = 0.2697599D+04
          X2 =-1.2873790D+00
C
          T3 = 0.10592296D+05
          X3 =-1.5614160D+00
C
          W0 = 0.1242590D+03
C
          POWER = 1.0D0/4.0D0
C
          IETA_J = 0
          IETA_W = 0
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.7525D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKI2----
C                                Source: Nucl. Phys. A585 (1995) 467-488
C=======================================================================
C
      IF (SKYRME.EQ.'SKI2') THEN
C
          T0 = -.191543D+04
          X0 = -.210800D+00
C
          T1 = 0.438449D+03
          X1 =-1.737600D+00
C
          T2 = 0.305446D+03
          X2 =-1.533600D+00
C
          T3 = 0.105489D+05
          X3 =-0.178000D+00
C
          B4 = 0.60301D+02
          B4P= 0.60301D+02
C
          POWER = 1.0D0/4.0D0
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.7525D0
          RHOSKY =  0.1580D0
          EFFSKY =  0.6850D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKI3----
C                                Source: Nucl. Phys. A585 (1995) 467-488
C=======================================================================
C
      IF (SKYRME.EQ.'SKI3') THEN
C
          T0 = -.176288D+04
          X0 = 0.308300D+00
C
          T1 = 0.561608D+03
          X1 =-1.172200D+00
C
          T2 = -.227090D+03
          X2 =-1.090700D+00
C
          T3 = 0.810620D+04
          X3 = 1.292600D+00
C
          B4 = 0.94254D+02
          B4P= 0.0D0
C
          POWER = 1.0D0/4.0D0
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.7525D0
          RHOSKY =  0.1580D0
          EFFSKY =  0.5770D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKI4----
C                                Source: Nucl. Phys. A585 (1995) 467-488
C=======================================================================
C
      IF (SKYRME.EQ.'SKI4') THEN
C
          T0 = -.185583D+04
          X0 = 0.405100D+00
C
          T1 = 0.473829D+03
          X1 =-2.889100D+00
C
          T2 = 0.100686D+04
          X2 =-1.325200D+00
C
          T3 = 0.970361D+04
          X3 = 1.145200D+00
C
          B4 = 0.183097D+03
          B4P= -.180351D+03
C
          POWER = 1.0D0/4.0D0
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.7525D0
          RHOSKY =  0.1600D0
          EFFSKY =  0.6500D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKI5----
C                                Source: Nucl. Phys. A585 (1995) 467-488
C=======================================================================
C
      IF (SKYRME.EQ.'SKI5') THEN
C
          T0 = -.177291D+04
          X0 = -.117100D+00
C
          T1 = 0.550840D+03
          X1 =-1.308800D+00
C
          T2 = -.126685D+03
          X2 =-1.048700D+00
C
          T3 = 0.820625D+04
          X3 = 0.341000D+00
C
          B4 = 0.618150D+02
          B4P= 0.618150D+02
C
          POWER = 1.0D0/4.0D0
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.7525D0
          RHOSKY =  0.1560D0
          EFFSKY =  0.5790D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SVMA----
C           THIS FORCE IS EQUIVALENT TO SV-min OF PRC 79, 034310 (2009),
C           HOWEVER, THE DIFFERENCE BETWEEN THE NEUTRON AND PROTON  MASS
C           NOT YET IMPLEMETED AND THE AVARAGE MASS OF HBMSKY=20.7355405
C           IS BELOW USED INSTEAD OF THE NEUTRON (20.721260) AND  PROTON
C           (20.749821) VALUES REQUIRED.
C=======================================================================
C
      IF (SKYRME.EQ.'SVMA') THEN
C
          T0 =-0.21122480D+04
          X0 = 0.24388600D+00
C
          T1 = 0.29578100D+03
          X1 =-1.43492600D+00
C
          T2 = 0.14226800D+03
          X2 =-2.62589900D+00
C
          T3 = 0.13988567D+05
          X3 = 0.25807000D+00
C
          T4X = 0.1112910D+03   ! = t4  IN PRC 79, 034310 (2009)
          B4XP= 0.4593615D+02   ! = b4' IN PRC 79, 034310 (2009)
C
          B4  = T4X/2           ! see Michaels's email of 12/05/2022
          B4P = B4XP            ! see Michaels's email of 12/05/2022
C
          POWER = 0.255368D+00
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 2
          IETA_M = 1
C
          HBMSKY = 20.7355405D0
          RHOSKY =  0.161D0
          EFFSKY =  0.950D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKO----
C=======================================================================
C
      IF (SKYRME.EQ.'SKO ') THEN
C
          T0 =-0.2103653D+04
          X0 =-0.2107010D+00
C
          T1 = 0.3033520D+03
          X1 =-2.8107520D+00
C
          T2 = 0.7916740D+03
          X2 =-1.4615950D+00
C
          T3 = 0.13553252D+05
          X3 =-0.4298810D+00
C
          B4 = 0.1765780D+03
          B4P=-0.1987490D+03
C
          POWER = 1.0D0/4.0D0
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.73553D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKOP----
C=======================================================================
C
      IF (SKYRME.EQ.'SKOP') THEN
C
          T0 =-0.2099419D+04
          X0 =-0.0295030D+00
C
          T1 = 0.3015310D+03
          X1 =-1.3257320D+00
C
          T2 = 0.1547810D+03
          X2 =-2.3234390D+00
C
          T3 = 0.13526464D+05
          X3 =-0.1474040D+00
C
          B4 = 0.1438950D+03
          B4P=-0.8288880D+02
C
          POWER = 1.0D0/4.0D0
C
          IETA_J = 1
          IETA_W = 1
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.16000D0
          EFFSKY =  0.89600D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SLY4----
C=======================================================================
C         ATTENTION: UP TO THE VERSION  2.44R  OF  THE  CODE,  THE  SLY4
C                    VALUES WERE DIFFERENT THAN THOSE IN THE PUBLICATION
C                    OF CHABANAT ET AL. NP635-231 BECAUSE SUCH HAVE BEEN
C                    RECOMMENDED  BY  THE  AUTHORS  OF  THE  FORCE.  THE
C                    DIFFERENCES BASICALLY CONCERED THE UNROUNDED VALUES
C                    OF THE PARAMETERS. HOWEVER, THIS RECOMMENDATION WAS
C                    WITHDRAWN  IN  THE  EMAIL  OF  KARIM  BENNACEUR  OF
C                    21/12/2009 WHO RECOMMENDED USING THE ORIGINAL  ONES
C                    FROM NP635-231. THIS  BUG  HAS  BEEN  CORRECTED  IN
C                    VERSION 2.44R ON 25/12/2009.
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.44R AND 2.52I, THE  ACRONYMS  OF
C                    BAD (OLD) AND GOOD (NEW)  PARAMETERS  OF  THE  SLY4
C                    FORCE WERE EXCHANGED AS COMPARED TO  WHAT HAS  BEEN
C                    WRITTEN IN SEC. 2.4.2 OF CPC183-166. THIS  BUG  WAS
C                    CORRECTED ON 10/02/2012 IN VERSIONS 2.52J,  NAMELY,
C                    AT PRESENT, THE CORRECT PARAMETERS HAVE THE ACRONYM
C                    "SLY4" AND THE PREVIOUS, INCORRECT ONES, ARE  STILL
C                    KEPT IN THE CODE UNDER THE ACRONYM OF "sLy4".
C=======================================================================
C
      IF (SKYRME.EQ.'SLY4') THEN
C
          T0 = -0.2488910D+04
          X0 =  0.8340000D+00
C
          T1 =  0.4868200D+03
          X1 = -0.3440000D+00
C
          T2 = -0.5463900D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1377700D+05
          X3 =  1.3540000D+00
C
          W0 =  0.1230000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.16000D0
          EFFSKY =  0.69400D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SLY5----
C=======================================================================
C         ATTENTION: UP T0 THE VERSION  2.44K  OF  THE  CODE,  THE  SLY5
C                    VALUES WERE DIFFERENT THAN THOSE IN THE PUBLICATION
C                    OF CHABANAT ET AL. NP635-231 BECAUSE SUCH HAVE BEEN
C                    RECOMMENDED BY THE AUTHORS OF THE  FORCE.  HOWEVER,
C                    THIS RECOMMENDATION WAS WITHDRAWN IN THE  EMAIL  OF
C                    KARIM BENNACEUR OF 17/12/2009 WHO RECOMMENDED USING
C                    THE ORIGINAL VALUES FROM NP635-231.  THIS  BUG  HAS
C                    BEEN CORRECTED IN VERSION 2.44L ON 18/12/2009.
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.44R AND 2.52I, THE  ACRONYMS  OF
C                    BAD (OLD) AND GOOD (NEW)  PARAMETERS  OF  THE  SLY5
C                    FORCE WERE EXCHANGED AS COMPARED TO  WHAT HAS  BEEN
C                    WRITTEN IN SEC. 2.4.2 OF CPC183-166. THIS  BUG  WAS
C                    CORRECTED ON 10/02/2012 IN VERSIONS 2.52J,  NAMELY,
C                    AT PRESENT, THE CORRECT PARAMETERS HAVE THE ACRONYM
C                    "SLY5" AND THE PREVIOUS, INCORRECT ONES, ARE  STILL
C                    KEPT IN THE CODE UNDER THE ACRONYM OF "sLy5".
C=======================================================================
C
      IF (SKYRME.EQ.'SLY5') THEN
C
          T0 = -2484.880D+00
          X0 =     0.778D+00
C
          T1 =   483.130D+00
          X1 =    -0.328D+00
C
          T2 =  -549.400D+00
          X2 =    -1.000D+00
C
          T3 = 13763.000D+00
          X3 =     1.267D+00
C
          W0 =   126.000D+00
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.16000D0
          EFFSKY =  0.69700D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SLY6----
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.44R AND 2.52I, THE  ACRONYMS  OF
C                    BAD (OLD) AND GOOD (NEW)  PARAMETERS  OF  THE  SLY6
C                    FORCE WERE EXCHANGED AS COMPARED TO  WHAT HAS  BEEN
C                    WRITTEN IN SEC. 2.4.2 OF CPC183-166. THIS  BUG  WAS
C                    CORRECTED ON 10/02/2012 IN VERSIONS 2.52J,  NAMELY,
C                    AT PRESENT, THE CORRECT PARAMETERS HAVE THE ACRONYM
C                    "SLY6" AND THE PREVIOUS, INCORRECT ONES, ARE  STILL
C                    KEPT IN THE CODE UNDER THE ACRONYM OF "sLy6".
C=======================================================================
C         ATTENTION: UP TO THE VERSION  2.52J  OF  THE  CODE,  THE  SLY6
C                    PARAMETERS  WERE  INCORRECTLY  ACCOMPANIED  BY  THE
C                    SWITCH IETACM = 1  (TWO-BODY  CM  CORRECTION  AFTER
C                    VARIATION, WHEREAS THE FORCE HAS BEEN  FITTED  WITH
C                    THE CM CORRECTION BEFORE VARIATION AND SHOULD  HAVE
C                    BEEN ACCOMPANIED WITH THE SWITCH IETACM=2. THIS BUG
C                    HAS BEEN CORRECTED ON 10/02/2012 IN VERSION 2.52J.
C=======================================================================
C
      IF (SKYRME.EQ.'SLY6') THEN
C
          T0 = -0.2479500D+04
          X0 =  0.8250000D+00
C
          T1 =  0.4621800D+03
          X1 = -0.4650000D+00
C
          T2 = -0.4486100D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1367300D+05
          X3 =  1.3550000D+00
C
          W0 =  0.1220000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 0
          IETA_W = 0
          IETACM = 2
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15900D0
          EFFSKY =  0.69000D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SLY7----
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.44R AND 2.52I, THE  ACRONYMS  OF
C                    BAD (OLD) AND GOOD (NEW)  PARAMETERS  OF  THE  SLY7
C                    FORCE WERE EXCHANGED AS COMPARED TO  WHAT HAS  BEEN
C                    WRITTEN IN SEC. 2.4.2 OF CPC183-166. THIS  BUG  WAS
C                    CORRECTED ON 10/02/2012 IN VERSIONS 2.52J,  NAMELY,
C                    AT PRESENT, THE CORRECT PARAMETERS HAVE THE ACRONYM
C                    "SLY7" AND THE PREVIOUS, INCORRECT ONES, ARE  STILL
C                    KEPT IN THE CODE UNDER THE ACRONYM OF "sLy7".
C=======================================================================
C         ATTENTION: UP T0 THE VERSION  2.52J  OF  THE  CODE,  THE  SLY7
C                    PARAMETERS  WERE  INCORRECTLY  ACCOMPANIED  BY  THE
C                    SWITCH IETACM = 1  (TWO-BODY  CM  CORRECTION  AFTER
C                    VARIATION, WHEREAS THE FORCE HAS BEEN  FITTED  WITH
C                    THE CM CORRECTION BEFORE VARIATION AND SHOULD  HAVE
C                    BEEN ACCOMPANIED WITH THE SWITCH IETACM=2. THIS BUG
C                    HAS BEEN CORRECTED ON 10/02/2012 IN VERSION 2.52J.
C=======================================================================
C
      IF (SKYRME.EQ.'SLY7') THEN
C
          T0 = -2482.410D+00
          X0 =     0.846D+00
C
          T1 =   457.970D+00
          X1 =    -0.511D+00
C
          T2 =  -419.850D+00
          X2 =    -1.000D+00
C
          T3 = 13677.000D+00
          X3 =     1.391D+00
C
          W0 =   126.000D+00
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETACM = 2
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15800D0
          EFFSKY =  0.68800D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SL4d----
C         CALLED SLy4d IN J. Phys. G: Nucl. Part. Phys. 23 (1997) 1267
C=======================================================================
C
      IF (SKYRME.EQ.'SL4d') THEN
C
          T0 = -0.2479662D+04
          X0 =  0.8122000D+00
C
          T1 =  0.4732160D+03
          X1 = -0.7228000D+00
C
          T2 = -0.3336540D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1348700D+05
          X3 =  1.3980000D+00
C
          W0 =  0.1280000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 0
          IETA_W = 0
          IETACM = 3
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15900D0
          EFFSKY =  0.69000D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----sLy4----
C=======================================================================
C         ATTENTION: SEE THE COMMENT REGARDING THE sLy4 FORCE ABOVE
C=======================================================================
C
      IF (SKYRME.EQ.'sLy4') THEN
C
          T0 = -0.2488913D+04
          X0 =  0.8340000D+00
C
          T1 =  0.4868180D+03
          X1 = -0.3440000D+00
C
          T2 = -0.5463950D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1377700D+05
          X3 =  1.3540000D+00
C
          W0 =  0.1230000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.16000D0
          EFFSKY =  0.69400D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----sly4----
C=======================================================================
C         ATTENTION: THIS IS A COPY OF sLy4 TO CORRECT FOR  THE  ACRONYM
C                    INCORRECTLY PRINTED IN  CPC183-166  AND  CPC216-145
C=======================================================================
C
      IF (SKYRME.EQ.'sly4') THEN
C
          T0 = -0.2488913D+04
          X0 =  0.8340000D+00
C
          T1 =  0.4868180D+03
          X1 = -0.3440000D+00
C
          T2 = -0.5463950D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1377700D+05
          X3 =  1.3540000D+00
C
          W0 =  0.1230000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 0
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.16000D0
          EFFSKY =  0.69400D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----sLy5----
C=======================================================================
C         ATTENTION: UP TO THE VERSION 2.11 OF THE CODE,  THE  VALUE  OF
C                    T0 WAS INCORRECTLY SET TO -0.2488345D+04, THIS  BUG
C                    HAS BEEN CORRECTED IN VERSION 2.11A ON  19/07/2004.
C=======================================================================
C         ATTENTION: SEE THE COMMENT REGARDING THE sLy5 FORCE ABOVE
C=======================================================================
C
      IF (SKYRME.EQ.'sLy5') THEN
C
          T0 = -0.2483450D+04
          X0 =  0.7760000D+00
C
          T1 =  0.4842300D+03
          X1 = -0.3170000D+00
C
          T2 = -0.5566900D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1375700D+05
          X3 =  1.2630000D+00
C
          W0 =  0.1250000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.16100D0
          EFFSKY =  0.69800D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----sly5----
C=======================================================================
C         ATTENTION: THIS IS A COPY OF sLy5 TO CORRECT FOR  THE  ACRONYM
C                    INCORRECTLY PRINTED IN  CPC183-166  AND  CPC216-145
C=======================================================================
C
      IF (SKYRME.EQ.'sly5') THEN
C
          T0 = -0.2483450D+04
          X0 =  0.7760000D+00
C
          T1 =  0.4842300D+03
          X1 = -0.3170000D+00
C
          T2 = -0.5566900D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1375700D+05
          X3 =  1.2630000D+00
C
          W0 =  0.1250000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.16100D0
          EFFSKY =  0.69800D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----sLy7----
C=======================================================================
C         ATTENTION: SEE THE COMMENT REGARDING THE sLy7 FORCE ABOVE
C=======================================================================
C
      IF (SKYRME.EQ.'sLy7') THEN
C
          T0 = -0.2480800D+04
          X0 =  0.8480000D+00
C
          T1 =  0.4612900D+03
          X1 = -0.4920000D+00
C
          T2 = -0.4339300D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1366900D+05
          X3 =  1.3930000D+00
C
          W0 =  0.1250000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15800D0
          EFFSKY =  0.68800D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----sly7----
C=======================================================================
C         ATTENTION: THIS IS A COPY OF sLy7 TO CORRECT FOR  THE  ACRONYM
C                    INCORRECTLY PRINTED IN  CPC183-166  AND  CPC216-145
C=======================================================================
C
      IF (SKYRME.EQ.'sly7') THEN
C
          T0 = -0.2480800D+04
          X0 =  0.8480000D+00
C
          T1 =  0.4612900D+03
          X1 = -0.4920000D+00
C
          T2 = -0.4339300D+03
          X2 = -1.0000000D+00
C
          T3 =  0.1366900D+05
          X3 =  1.3930000D+00
C
          W0 =  0.1250000D+03
C
          POWER = 1.0D0/6.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETACM = 1
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15800D0
          EFFSKY =  0.68800D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----MSK1----
C=======================================================================
C
      IF (SKYRME.EQ.'MSK1') THEN
C
          T0 = -0.1813030D+04
          X0 =  0.3653950D+00
C
          T1 =  0.2748280D+03
          X1 = -0.5000000D+00
C
          T2 = -0.2748280D+03
          X2 = -0.5000000D+00
C
          T3 =  0.1305010D+05
          X3 =  0.4498820D+00
C
          W0 =  0.1167080D+03
C
          POWER = 1.0D0/3.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15750D0
          EFFSKY =  1.00000D0
C
          ISKYRM=1
C
          WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *          1H*,10X,''ATTENTION:  THE SKYRME FORCE  "'',A4,''"  '',
     *                  ''REQUIRES A SPECIAL'',  11X,1H*,/,
     *          1H*,10X,''TREATMENT OF THE TENSOR TERM THAT IS NOT '',
     *                  ''YET IMPLEMENTED'',     11X,1H*,/,
     *                                       1H*,77X,1H*)')
     *      SKYRME
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----MSK2----
C=======================================================================
C
      IF (SKYRME.EQ.'MSK2') THEN
C
          T0 = -0.1830670D+04
          X0 =  0.3568750D+00
C
          T1 =  0.2603010D+03
          X1 = -0.5000000D+00
C
          T2 = -0.2937420D+03
          X2 = -0.5000000D+00
C
          T3 =  0.1344210D+05
          X3 =  0.4097590D+00
C
          W0 =  0.1166630D+03
C
          POWER = 1.0D0/3.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15750D0
          EFFSKY =  1.05000D0
C
          ISKYRM=1
C
          WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *          1H*,10X,''ATTENTION:  THE SKYRME FORCE  "'',A4,''"  '',
     *                  ''REQUIRES A SPECIAL'',  11X,1H*,/,
     *          1H*,10X,''TREATMENT OF THE TENSOR TERM THAT IS NOT '',
     *                  ''YET IMPLEMENTED'',     11X,1H*,/,
     *                                       1H*,77X,1H*)')
     *      SKYRME
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----MSK3----
C=======================================================================
C
      IF (SKYRME.EQ.'MSK3') THEN
C
          T0 = -0.1810320D+04
          X0 =  0.6314850D+00
C
          T1 =  0.2690920D+03
          X1 = -0.5000000D+00
C
          T2 = -0.2690920D+03
          X2 = -0.5000000D+00
C
          T3 =  0.1302750D+05
          X3 =  0.9036800D+00
C
          W0 =  0.1168710D+03
C
          POWER = 1.0D0/3.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15750D0
          EFFSKY =  1.00000D0
C
          WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *          1H*,10X,''ATTENTION:  THE SKYRME FORCE  "'',A4,''"  '',
     *                  ''REQUIRES A SPECIAL'',  11X,1H*,/,
     *          1H*,10X,''TREATMENT OF THE TENSOR TERM THAT IS NOT '',
     *                  ''YET IMPLEMENTED'',     11X,1H*,/,
     *                                       1H*,77X,1H*)')
     *      SKYRME
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----MSK4----
C=======================================================================
C
      IF (SKYRME.EQ.'MSK4') THEN
C
          T0 = -0.1827960D+04
          X0 =  0.6103600D+00
C
          T1 =  0.2541290D+03
          X1 = -0.5000000D+00
C
          T2 = -0.2875690D+03
          X2 = -0.5000000D+00
C
          T3 =  0.1341950D+05
          X3 =  0.8350630D+00
C
          W0 =  0.1159430D+03
C
          POWER = 1.0D0/3.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15750D0
          EFFSKY =  1.05000D0
C
          ISKYRM=1
C
          WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *          1H*,10X,''ATTENTION:  THE SKYRME FORCE  "'',A4,''"  '',
     *                  ''REQUIRES A SPECIAL'',  11X,1H*,/,
     *          1H*,10X,''TREATMENT OF THE TENSOR TERM THAT IS NOT '',
     *                  ''YET IMPLEMENTED'',     11X,1H*,/,
     *                                       1H*,77X,1H*)')
     *      SKYRME
C
      END IF
C
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----MSK5----
C=======================================================================
C
      IF (SKYRME.EQ.'MSK5') THEN
C
          T0 = -0.1827960D+04
          X0 =  0.6051520D+00
C
          T1 =  0.2543260D+03
          X1 = -0.5000000D+00
C
          T2 = -0.2877660D+03
          X2 = -0.5000000D+00
C
          T3 =  0.1341950D+05
          X3 =  0.8271820D+00
C
          W0 =  0.1159320D+03
C
          POWER = 1.0D0/3.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15750D0
          EFFSKY =  1.05000D0
C
          ISKYRM=1
C
          WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *          1H*,10X,''ATTENTION:  THE SKYRME FORCE  "'',A4,''"  '',
     *                  ''REQUIRES A SPECIAL'',  11X,1H*,/,
     *          1H*,10X,''TREATMENT OF THE TENSOR TERM THAT IS NOT '',
     *                  ''YET IMPLEMENTED'',     11X,1H*,/,
     *                                       1H*,77X,1H*)')
     *      SKYRME
C
      END IF
C
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----MSK6----
C=======================================================================
C
      IF (SKYRME.EQ.'MSK6') THEN
C
          T0 = -0.1827960D+04
          X0 =  0.5765910D+00
C
          T1 =  0.2584830D+03
          X1 = -0.5000000D+00
C
          T2 = -0.2919240D+03
          X2 = -0.5000000D+00
C
          T3 =  0.1341950D+05
          X3 =  0.7839560D+00
C
          W0 =  0.1188070D+03
C
          POWER = 1.0D0/3.0D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D0
          RHOSKY =  0.15750D0
          EFFSKY =  1.05000D0
C
          ISKYRM=1
C
          WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
     *          1H*,10X,''ATTENTION:  THE SKYRME FORCE  "'',A4,''"  '',
     *                  ''REQUIRES A SPECIAL'',  11X,1H*,/,
     *          1H*,10X,''TREATMENT OF THE TENSOR TERM THAT IS NOT '',
     *                  ''YET IMPLEMENTED'',     11X,1H*,/,
     *                                       1H*,77X,1H*)')
     *      SKYRME
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKX----
C         [Brown PRC58 (1998) 220]  (m_eff=0.99)
C=======================================================================
C
      IF (SKYRME.EQ.'SKX ') THEN
C
          T0 = -.1445300D+04
          X0 = +.3400000D+00
C
          T1 = +.2469000D+03
          X1 = +.5800000D+00
C
          T2 = -.1318000D+03
          X2 = +.1270000D+00
C
          T3 = +.1210390D+05
          X3 = +.0300000D+00
C
          B4 = +.0743000D+03
          B4P=  .0000000D+00
C
          POWER = .50000D+00
C
          IETA_J = 1
          IETA_W = 1
          IETA_M = 1
C
          COUSCA = 0.0D0
C
          HBMSKY = 20.73D0
          RHOSKY =  0.16D0
          EFFSKY =  0.99D0
C
          ISKYRM=1
C
C          WRITE(NFIPRI,'(79(1H*),/,          1H*,77X,1H*,/,
C     *          1H*,10X,''ATTENTION:  THE SKYRME FORCE  "'',A4,''"  '',
C     *                  ''REQUIRES  REMOVING'',  11X,1H*,/,
C     *          1H*,10X,''THE  COULOMB  EXCHANGE  TERM THAT IS NOT '',
C     *                  ''YET IMPLEMENTED'',     11X,1H*,/,
C     *                                       1H*,77X,1H*)')
C     *      SKYRME
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SKXc----
C         [Brown PRC58 (1998) 220]  (m_eff=0.99)
C=======================================================================
C
      IF (SKYRME.EQ.'SKXC') THEN
C
          T0 = -.1438000D+04
          X0 = +.2880000D+00
C
          T1 = +.2443000D+03
          X1 = +.6110000D+00
C
          T2 = -.1337000D+03
          X2 = +.1450000D+00
C
          T3 = +.1211630D+05
          X3 = -.0560000D+00
C
          B4 = +.0728500D+03
          B4P=  .0000000D+00
C
          POWER = .50000D+00
C
          IETA_J = 1
          IETA_W = 1
          IETA_M = 1
C
          HBMSKY = 20.73D0
          RHOSKY =  0.16D0
          EFFSKY =  0.99D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----UDFZ----
C         [Kortelainen PRC82, 024313 (2010), Mario email 06/11/2010)
C=======================================================================
C
      IF (SKYRME.EQ.'UDFZ') THEN
C
          T0 = -1883.68798062D+00
          X0 =     0.01018196D+00
C
          T1 =   277.50021379D+00
          X1 =    -1.77862413D+00
C
          T2 =   607.56489660D+00
          X2 =    -1.67759899D+00
C
          T3 = 13901.94904377D+00
          X3 =    -0.37954859D+00
C
          B4 =   125.16099930D+00
          B4P=   -91.26039886D+00
C
          POWER =  0.32195595D+00
C
          IETA_J = 0
          IETA_W = 1
          IETA_M = 1
C
          HBMSKY = 20.73553D+00
          RHOSKY = 0.160526D+00
          EFFSKY = 0.900000D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----UDFz----
C         [Kortelainen PRC82, 024313 (2010), Mario email 06/11/2010)
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.48V AND 2.51, THE PARAMETER  SET
C                    UDF0 WAS INCORRECTLY CODED WITH THE STANDARD  VALUE
C                    OF THE C-O-M CORRECTION SWITCH OF IETACM=0, WHEREAS
C                    THE FORCE WAS FITTED WITHOUT THE  C-O-M  CORRECTION
C                    AND THUS REQUIRES IETACM=3. THIS BUG WAS  CORRECTED
C                    ON 03/10/2011 IN VERSIONS 2.51A AND 2.49X, HOWEVER,
C                    THE INCORRECT FORCE IS STILL KEPT IN THE CODE UNDER
C                    THE ACRONYM OF "UDFZ".
C=======================================================================
C
      IF (SKYRME.EQ.'UDFz') THEN
C
          T0 = -1883.68798062D+00
          X0 =     0.01018196D+00
C
          T1 =   277.50021379D+00
          X1 =    -1.77862413D+00
C
          T2 =   607.56489660D+00
          X2 =    -1.67759899D+00
C
          T3 = 13901.94904377D+00
          X3 =    -0.37954859D+00
C
          B4 =   125.16099930D+00
          B4P=   -91.26039886D+00
C
          POWER =  0.32195595D+00
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 3
          IETA_M = 1
C
          HBMSKY = 20.73553D+00
          RHOSKY = 0.160526D+00
          EFFSKY = 0.900000D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----UDF0----
C         [Kortelainen PRC82, 024313 (2010), Marcus email 09/11/2011)
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.49T AND 2.51A, THE PARAMETER SET
C                    UDF0 WAS NOT CODED  IN  AGREEMENT  WITH  THE  DRAFT
C                    PAPER OF THE  UNEDF  COLLABORATION.  THIS  BUG  WAS
C                    CORRECTED ON 09/11/2011 IN VERSIONS 2.51B AND 2.49Y
C                    BASED ON VALUES GIVEN IN  MARCUS'  EMAIL,  HOWEVER,
C                    THE PREVIOUS FORCE IS STILL KEPT IN THE CODE  UNDER
C                    THE ACRONYM OF "UDFz".
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.51A AND 2.552, THE PARAMETER SET
C                    UDF0  WAS  INCORRECTLY  CODED  WITHOUT  THE   C-O-M
C                    CORRECTION, IETACM=3, WHEREAS THE FORCE WAS  FITTED
C                    WITH  THE  STANDARD  C-O-M  CORRECTION   AND   THUS
C                    REQUIRES IETACM=0. THIS BUG WAS CORRECTED
C                    ON 04/11/2012 IN VERSION 2.553.
C=======================================================================
C
      IF (SKYRME.EQ.'UDF0') THEN
C
          T0 = -1883.68781034D+00
          X0 =    +0.00974375D+00
C
          T1 =  +277.50021224D+00
          X1 =    -1.77784395D+00
C
          T2 =  +608.43090559D+00
          X2 =    -1.67699035D+00
C
          T3 =+13901.94834463D+00
          X3 =    -0.38079041D+00
C
          B4 =  +125.16100000D+00
          B4P=    -91.2604000D+00
C
          POWER =  0.32195599D+00
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 0
          IETA_M = 1
C
          HBMSKY = 20.73553D+00
          RHOSKY = 0.160526D+00
          EFFSKY = 0.900000D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----UDFL----
C         Markus' email 27/09/2011)
C=======================================================================
C
      IF (SKYRME.EQ.'UDFL') THEN
C
          T0 =  -2078.32802325563625D+00
          X0 =  0.543043709322549584D-01
C
          T1 =   239.400812041522045D+00
          X1 =  -5.07814768633786962D+00
C
          T2 =   1574.24304337273043D+00
          X2 =  -1.36657048130840808D+00
C
          T3 =   14263.6462470775750D+00
          X3 = -0.161168850358621302D+00
C
          B4 =   38.3680720616682009D+00
          B4P=   71.3165222295833985D+00
C
          POWER =  0.270018011502708211D+00
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 3
          IETA_M = 1
C
          HBMSKY = 20.735530000000000000000D+00
          RHOSKY =  0.158706769332587000000D+00
          EFFSKY =  1.0D0/0.992423332283364D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----UDf1----
C         Markus' email 09/11/2011)
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.49X AND 2.51A, THE PARAMETER SET
C                    UDF1 WAS NOT CODED  IN  AGREEMENT  WITH  THE  DRAFT
C                    PAPER OF THE  UNEDF  COLLABORATION.  THIS  BUG  WAS
C                    CORRECTED ON 09/11/2011 IN VERSIONS 2.51B AND 2.49Y
C                    BASED ON VALUES GIVEN IN  MARCUS'  EMAIL,  HOWEVER,
C                    THE PREVIOUS FORCE IS STILL KEPT IN THE CODE  UNDER
C                    THE ACRONYM OF "UDFL".
C=======================================================================
C
      IF (SKYRME.EQ.'UDf1') THEN
C
          T0 =  -2078.32802326D+00
          X0 =     +0.05375692D-01
C
          T1 =   +239.40081204D+00
          X1 =     -5.07723238D+00
C
          T2 =  +1575.11954190D+00
          X2 =     -1.36650561D+00
C
          T3 = +14263.64624708D+00
          X3 =     -0.16249117D+00
C
          B4 =    +38.36807206D+00
          B4P=    +71.31652223D+00
C
          POWER =  +0.27001801D+00
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 3
          IETA_M = 1
C
          HBMSKY = 20.735530000000000000000D+00
          RHOSKY =  0.158706769332587000000D+00
          EFFSKY =  1.0D0/0.992423332283364D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----UDF1----
C         [Kortelainen PRC85, 024304 (2012), Yue's email 10/02/2012)
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.51B AND 2.52I, THE PARAMETER SET
C                    UDF1  WAS  CODED  WITH  THE  INCORRECT   VALUE   OF
C                    X0 = +0.05375692D-01. THIS  BUG  WAS  CORRECTED  ON
C                    10/02/2012 IN VERSION 2.52J, HOWEVER, THE  PREVIOUS
C                    VALUE IS STILL KEPT IN THE CODE UNDER  THE  ACRONYM
C                    OF "UDf1".
C=======================================================================
C
      IF (SKYRME.EQ.'UDF1') THEN
C
          T0 =  -2078.32802326D+00
          X0 =     +0.05375692D+00
C
          T1 =   +239.40081204D+00
          X1 =     -5.07723238D+00
C
          T2 =  +1575.11954190D+00
          X2 =     -1.36650561D+00
C
          T3 = +14263.64624708D+00
          X3 =     -0.16249117D+00
C
          B4 =    +38.36807206D+00
          B4P=    +71.31652223D+00
C
          POWER =  +0.27001801D+00
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 3
          IETA_M = 1
C
          HBMSKY = 20.735530000000000000000D+00
          RHOSKY =  0.158706769332587000000D+00
          EFFSKY =  1.0D0/0.992423332283364D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----UDFS----
C         [SHI PHYSICAL REVIEW C 89, 034309 (2014)]
C=======================================================================
C
      IF (SKYRME.EQ.'UDFS') THEN
C
          T0 =  -2078.32802326D+00
          X0 =     +0.05375692D+00
C
          T1 =   +239.40081204D+00
          X1 =     -5.07723238D+00
C
          T2 =  +1575.11954190D+00
          X2 =     -1.36650561D+00
C
          T3 = +14263.64624708D+00
          X3 =     -0.16249117D+00
C
          B4 =    +96.50800000D+00
          B4P=    -16.91600000D+00
C
          POWER =  +0.27001801D+00
C
          IETA_J = 0
          IETA_W = 1
          IETACM = 3
          IETA_M = 1
C
          HBMSKY = 20.735530000000000000000D+00
          RHOSKY =  0.158706769332587000000D+00
          EFFSKY =  1.0D0/0.992423332283364D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----UDF2----
C         [Kortelainen PRC89, 054314 (2014)
C=======================================================================
C
      IF (SKYRME.EQ.'UDF2') THEN
C
          T0 =  -1735.45685191D+00
          X0 =     +0.17224723D+00
C
          T1 =   +262.81445624D+00
          X1 =     -3.76692685D+00
C
          T2 =  +1183.31263243D+00
          X2 =     -1.38349813D+00
C
          T3 = +12293.24329411D+00
          X3 =     +0.05286427D+00
C
          B4 =    +25.65866773D+00
          B4P=    +77.30038937D+00
C
C          Attention: The te and to parameters given below should not
C                     be used to define the tensor force of some hypo-
C                     thetical UNEDF2 interaction. They are only needed
C                     to convert from/to coupling constants to/from
C                     (t,x) parameters and guarantee that the tensor
C                     terms of the *functional* are the proper ones.
          TE_THO=-240.14059822D+00
          TO_THO=-266.93066232D+00
C
          POWER =  +0.35145513D+00
C
          IETA_J = 1
          IETA_W = 1
          IETACM = 3
          IETA_M = 1
C
          HBMSKY = 20.735530000000000000000D+00
          RHOSKY =  0.156310622197074100000D+00
          EFFSKY =  1.0D0/1.073763804147980D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SAMi----
C         PHYSICAL REVIEW C 86, 031306(R) (2012)
C=======================================================================
C
      IF (SKYRME.EQ.'SAMi') THEN
C
          T0 = -1877.750D+00
          X0 =     0.320D+00
C
          T1 =   475.600D+00
          X1 =    -0.532D+00
C
          T2 =   -85.200D+00
          X2 =    -0.014D+00
C
          T3 = 10219.600D+00
          X3 =     0.688D+00
C
          B4 =   137.000D+00/2
          B4P=    42.000D+00/2
C
          POWER =  0.25614D+00
C
          IETA_J = 1
          IETA_W = 1
          IETACM = 0
          IETA_M = 1
C
          HBMSKY = 20.73621D+00
          RHOSKY =  0.15900D+00
          EFFSKY =  0.67520D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----D1S ----
C         PARAMETERS BELOW DEFINE THE ZERO-RANGE COMPONENTS OF THE
C         GOGNY FORCE
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.44P AND 2.69L, THE PARAMETER SET
C                    D1S (AND ALL OTHER GOGNY SETS) WAS CODED  WITH  THE
C                    INCORRECT VALUE  OF  THE  C-O-M  CORRECTION  SWITCH
C                    IETACM=0 INSTEAD OF THE  FULL  TWO-BODY  CORRECTION
C                    IETACM=2 REQUIRED FOR THE GOGNY FORCE. THIS BUG WAS
C                    CORRECTED ON 21/03/2014 IN VERSION 2.69M.
C=======================================================================
C
      IF (SKYRME.EQ.'D1S ') THEN
C
          T3 = +.1390600D+04*6
          X3 = +.1000000D+01
C
          POWER = 1.0D0/3.0D0
C
          W0 = +.1300000D+03
C
          IETA_M = 1
          IETACM = 2
          HBMSKY = 0.5D0/0.024111868D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----R200----
C         PARAMETERS BELOW DEFINE THE ZERO-RANGE COMPONENTS OF THE
C         REG2c.161026 FORCE, ACCOMPANIED FOR TESTS BY THE SKYRME TERMS
C         AS IN KARIM'S EMAIL OF 2017-03-07
C=======================================================================
C
      IF (SKYRME.EQ.'R200') THEN
C
          T0 = +1000.000000D0
          X0 = +1.000000000D0
C
          T1 =  0.0000000D+00
          X1 =  0.0000000D+00
C
          T2 =  0.0000000D+00
          X2 =  0.0000000D+00
C
          T3 =  0.0000000D+00
          X3 =  0.0000000D+00
C
          POWER = 1.0D0/3.0D0
C
          W0 = +177.076480D0
C
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----R201----
C         PARAMETERS BELOW DEFINE THE ZERO-RANGE COMPONENTS OF THE
C         REG2c.161026 FORCE, ACCOMPANIED FOR TESTS BY THE SKYRME TERMS
C         AS IN KARIM'S EMAIL OF 2017-03-07
C=======================================================================
C
      IF (SKYRME.EQ.'R201') THEN
C
          T0 = +1000.000000D0
          X0 = +0.900000000D0
C
          T1 =  0.0000000D+00
          X1 =  0.0000000D+00
C
          T2 =  0.0000000D+00
          X2 =  0.0000000D+00
C
          T3 =  0.0000000D+00
          X3 =  0.0000000D+00
C
          POWER = 1.0D0/3.0D0
C
          W0 = +177.076480D0
C
          IETAPA = 1
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----Q201----
C         PARAMETERS BELOW DEFINE THE ZERO-RANGE COMPONENTS OF THE
C         REG2c.161026 FORCE, ACCOMPANIED FOR TESTS BY THE SKYRME TERMS
C         AS IN KARIM'S EMAIL OF 2017-04-13
C=======================================================================
C
      IF (SKYRME.EQ.'Q201') THEN
C
          T0 = +1000.000000D0
          X0 = +0.950000000D0
C
          T1 =  0.0000000D+00
          X1 =  0.0000000D+00
C
          T2 =  0.0000000D+00
          X2 =  0.0000000D+00
C
          T3 =  0.0000000D+00
          X3 =  0.0000000D+00
C
          POWER = 1.0D0/3.0D0
C
          W0 = +177.076480D0
C
          IETAPA = 1
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----R210----
C         PARAMETERS BELOW DEFINE THE ZERO-RANGE COMPONENTS OF THE
C         REG2c.161026 FORCE, ACCOMPANIED FOR TESTS BY THE SKYRME TERMS
C         AS IN KARIM'S EMAIL OF 2017-03-07
C=======================================================================
C
      IF (SKYRME.EQ.'R210') THEN
C
          T0 = +1000.000000D0
          X0 = +1.000000000D0
C
          T1 =-20.0000000D+00
          X1 =  0.0000000D+00
C
          T2 =  0.0000000D+00
          X2 =  0.0000000D+00
C
          T3 =  0.0000000D+00
          X3 =  0.0000000D+00
C
          POWER = 1.0D0/3.0D0
C
          W0 = +177.076480D0
C
          IETAPA = 1
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----R211----
C         PARAMETERS BELOW DEFINE THE ZERO-RANGE COMPONENTS OF THE
C         REG2c.161026 FORCE, ACCOMPANIED FOR TESTS BY THE SKYRME TERMS
C         AS IN KARIM'S EMAIL OF 2017-03-07
C=======================================================================
C
      IF (SKYRME.EQ.'R211') THEN
C
          T0 = +1000.000000D0
          X0 = +1.000000000D0
C
          T1 =-20.0000000D+00
          X1 = -0.2000000D+00
C
          T2 =  0.0000000D+00
          X2 =  0.0000000D+00
C
          T3 =  0.0000000D+00
          X3 =  0.0000000D+00
C
          POWER = 1.0D0/3.0D0
C
          W0 = +177.076480D0
C
          IETAPA = 1
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----R220----
C         PARAMETERS BELOW DEFINE THE ZERO-RANGE COMPONENTS OF THE
C         REG2c.161026 FORCE, ACCOMPANIED FOR TESTS BY THE SKYRME TERMS
C         AS IN KARIM'S EMAIL OF 2017-03-07
C=======================================================================
C
      IF (SKYRME.EQ.'R220') THEN
C
          T0 = +1000.000000D0
          X0 = +1.000000000D0
C
          T1 =  0.0000000D+00
          X1 =  0.0000000D+00
C
          T2 =-20.0000000D+00
          X2 =  0.0000000D+00
C
          T3 =  0.0000000D+00
          X3 =  0.0000000D+00
C
          POWER = 1.0D0/3.0D0
C
          W0 = +177.076480D0
C
          IETAPA = 1
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----R221----
C         PARAMETERS BELOW DEFINE THE ZERO-RANGE COMPONENTS OF THE
C         REG2c.161026 FORCE, ACCOMPANIED FOR TESTS BY THE SKYRME TERMS
C         AS IN KARIM'S EMAIL OF 2017-03-07
C=======================================================================
C
      IF (SKYRME.EQ.'R221') THEN
C
          T0 = +1000.000000D0
          X0 = +1.000000000D0
C
          T1 =  0.0000000D+00
          X1 =  0.0000000D+00
C
          T2 =-20.0000000D+00
          X2 =  0.5000000D+00
C
          T3 =  0.0000000D+00
          X3 =  0.0000000D+00
C
          POWER = 1.0D0/3.0D0
C
          W0 = +177.076480D0
C
          IETAPA = 1
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C
      IF (SKYRME.EQ.'D1N ') THEN
C
          T3 = +.1609460D+04*6
          X3 = +.1000000D+01
C
          POWER = 1.0D0/3.0D0
C
          W0 = +.1150000D+03
C
          IETA_M = 1
          IETACM = 2
          HBMSKY = 0.5D0/0.024111868D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C           HERE IS THE D1K PARAMETER SET THAT CORRESPONDS TO
C           A FICTICIOUS DENSITY-DEPENDENT TERM WITH POWER 1
C=======================================================================
C
      IF (SKYRME.EQ.'D1K ') THEN
C
          T3 = +.1000000D+04
          X3 = +.1000000D+01
C
          POWER = 1.0D0
C
          W0 = +.1300000D+03
C
          IETA_M = 1
          HBMSKY=0.5D0/0.024111868D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         THIS IS THE ONE-GAUSSIAN PARAMETER SET AS IN KARIM'S EMAIL OF
C         2015-05-26 09:59
C=======================================================================
C
      IF (SKYRME.EQ.'ONEG') THEN
C
          T3 = +11333.099D0
          X3 = +1.0000000D0
C
          POWER = 1.0D0/3.0D0
C
          W0 = +138.79900D0
C
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         THIS IS THE ONE-GAUSSIAN PARAMETER SET AS IN KARIM'S EMAIL OF
C         2016-09-23 12:03
C=======================================================================
C
      IF (SKYRME.EQ.'1GAU') THEN
C
          T3 = +1.0000000D0
          X3 = +1.0000000D0
C
          POWER = 1.0D0/3.0D0
C
          W0 = +130.00000D0
C
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         THIS IS THE 2BODY DELTA  PARAMETER SET AS IN KARIM'S EMAIL OF
C         2016-08-23 13:51
C=======================================================================
C
      IF (SKYRME.EQ.'2BOD') THEN
C
          T0 = +1.000000000D0
          X0 = +1.000000000D0
C
          POWER = 1.0D0
C
          W0 = +176.456764900D0
C
          IETA_M = 1
          IETACM = 0
          HBMSKY = 20.736209410D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION      ----SD1S----
C         DERIVED FROM THE NV EXPANSION OF THE GOGNY D1S FORCE
C         FOR KF=1.35, SEE CODE LDA18F.F OF 22/01/2010
C=======================================================================
C
      IF (SKYRME.EQ.'SD1S') THEN
C
          T0 = -0.1601642D+04
          X0 = +0.5697973D+00
C
          T1 = +0.5505103D+03
          X1 = +0.9972498D-01
C
          T2 = -0.1660707D+03
          X2 = -0.5517182D+00
C
          T3 = +0.1390600D+04*6
          X3 = +0.1000000D+01
C
          POWER = 1.0D0/3.0D0
C
          W0 = +.1300000D+03
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.734863D0
          RHOSKY =  0.161000D0
          EFFSKY =  0.620000D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION SLyMR0     ----SMR0----
C         PHYS.  SCR. T154, 014013 (2013)
C         SEE KARIM'S EMAIL OF 2015/02/18
C=======================================================================
C
      IF (SKYRME.EQ.'SMR0') THEN
C
          T0 = -1.210093228D+03
          X0 = -0.283818D+00
C
          T1 =  6.32460114D+02
          X1 = -3.8032D-02
C
          T2 = 45.081296D+00
          X2 =  1.849978D+00
C
          W0 =  1.22618466D+02
C
          THREEB =  2.529151191D+03
          FOURBD = -1.4750D+04
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
          IETAPA = 1
C
          HBMSKY = 20.733983D0
          RHOSKY =  0.152000D0
          EFFSKY =  0.470000D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION JyLyP     ----JLP----
C         SEE KARIM'S EMAIL OF 2017/02/09 12:32
C=======================================================================
C
      IF (SKYRME.EQ.'JLP') THEN
C
          T0 =  -1733.931D0
          X0 =      0.548796D0
C
          T1 =    343.055D0
          X1 =     -0.026544D0
C
          T2 =  -683.538D0
          X2 =    -0.996846D0
C
          T3 = 11497.971D0
          X3 =     1.000000D0
C
          POWER = 1.0D0/3.0D0
C
          W0 =   103.337D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
          IETAPA = 1
C
          HBMSKY = 20.735530000000000000000D+00
          RHOSKY =  0.158706769332587000000D+00
          EFFSKY =  1.0D0/0.992423332283364D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION JyLyPx     ----JLPx----
C         SEE KARIM'S EMAIL OF 2017/02/09 12:32
C=======================================================================
C
      IF (SKYRME.EQ.'JLPx') THEN
C
          T0 =  -1796.692D0
          X0 =      0.317200D0
C
          T1 =    289.416D0
          X1 =      0.058873D0
C
          T2 =   -632.065D0
          X2 =     -0.907995D0
C
          T3 =  12842.226D0
          X3 =      0.414362D0
C
          POWER = 1.0D0/3.0D0
C
          W0 =     99.300D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
          IETAPA = 1
C
          HBMSKY = 20.735530000000000000000D+00
          RHOSKY =  0.158706769332587000000D+00
          EFFSKY =  1.0D0/0.992423332283364D+00
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS VERSION SKS4     ----SKS4----
C         SEE KARIM'S EMAIL OF 2017/06/15 13:49 AND
C         Nucl. Phys. A 549 (1992) 125
C=======================================================================
C
      IF (SKYRME.EQ.'SKS4') THEN
C
          T0 = -2011.700D0
          X0 =     0.256D0
C
          T1 =   348.700D0
          X1 =     0.675D0
C
          T2 =  -317.000D0
          X2 =    -0.670D0
C
          T3 = 12781.000D0
          X3 =     0.144D0
C
          POWER = 0.2597D0
C
          W0 =   106.000D0
C
          IETA_J = 1
          IETA_W = 0
          IETA_M = 1
C
          HBMSKY = 20.7361986D0
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCE PARAMETERS THAT ARE INPUT IN THE DATA UNDER
C         KEYWORD "SKYRMEINPU"
C=======================================================================
C
      IF (SKYRME.EQ.'INPU') THEN
C
          T0 = T0_INP
          X0 = X0_INP
C
          T1 = T1_INP
          X1 = X1_INP
C
          T2 = T2_INP
          X2 = X2_INP
C
          T3 = T3_INP
          X3 = X3_INP
C
          POWER = PO_INP
C
          W0 =    WW_INP
C
          ISKYRM=1
C
      END IF
C
C=======================================================================
C         SKYRME FORCES DERIVED FROM THE FIT OF THE SKYRME ENERGY
C         FUNCTIONAL (COLLABORATION ORNL/ARGONNE)
C=======================================================================
C
      IF (IF_EDF.EQ.1) THEN
C
          CALL paramsFunctional(SKYRME,IETA_J,IETA_W,IETA_M,IETACM,
     *                          ISKYRM,HBMSKY,T0_EFF,T1_EFF,T2_EFF,
     *                          T3_EFF,X0_EFF,X1_EFF,X2_EFF,X3_EFF,
     *                          B4_EFF,B4PEFF,TE_EFF,TO_EFF,POWEFF,
     *                                        V0NEFF,V0PEFF,COUSCA)
C
          T0    = T0_EFF
          T1    = T1_EFF
          T2    = T2_EFF
          T3    = T3_EFF
C
          X0    = X0_EFF
          X1    = X1_EFF
          X2    = X2_EFF
          X3    = X3_EFF
C
          B4    = B4_EFF
          B4P   = B4PEFF
C
          TE_THO= TE_EFF
          TO_THO= TO_EFF
C
          POWER = POWEFF
C
          RHOSKY = RHO_NM
          EFFSKY = SMASS_NM
C
C          Setting pairing properties for neutrons and protons
C
          PRHO_N=V0NEFF
          PRHODN=0.00D0
          PRHOSN=0.32D0
          POWERN=1.00D0
C
          CALL RHODEP(2,PRHO_N,PRHODN,PRHOSN,POWERN)
C
          PRHO_P=V0PEFF
          PRHODP=0.00D0
          PRHOSP=0.32D0
          POWERP=1.00D0
C
          CALL RHODEP(2,PRHO_P,PRHODP,PRHOSP,POWERP)
C
      END IF
C
C=======================================================================
C         FOR THE SKYRME FORCE THAT USES THE STANDARD  SPIN-ORBIT  FORCE
C         (IETA_W=0), THE VALUE OF PARAMETER "W0P" IS HERE FORCED TO  BE
C         EQUAL TO "W0", WHILE "W0" MUST BE EXPLICITLY PROVIDED  AS  ONE
C         OF THE SKYRME FORCE PARAMETERS.
C
C         FOR THE SKYRME FORCE THAT USES A NONSTANDARD SPIN-ORBIT  FORCE
C         (IETA_W=1), THE VALUES OF PARAMETERS "W0" AND "W0P"  ARE  HERE
C         CALCULATED FROM THE VALUES OF  "B4"  AND  "B4P"  THAT MUST  BE
C         BOTH EXPLICITLY PROVIDED AS THE SKYRME FORCE PARAMETERS.
C=======================================================================
C
      IF (IETA_W.EQ.0) THEN
          W0P = W0
      ELSE
          W0  = 2.0D0*B4
          W0P = 2.0D0*B4P
      END IF
C
C=======================================================================
C         HERE WE ADD THE TWO-BODY ZERO-RANGE COUPLING CONSTANT  TO  THE
C         STANDARD SKYRME PARAMETER T0. FOR NOW, THE EXCHANGE  PARAMETER
C         X0 IS NOT INCLUDED IN THIS SET UP.
C=======================================================================
C
      IF (ITWOIN.EQ.1) TWOBOD=TWOINP
                       T0=T0+TWOBOD
C
C=======================================================================
C         HERE WE SET THE THREE-BODY AND FOUR BODY COUPLING CONSTANTS TO
C         THE VALUES READ IN THE INPUT  FILE. THEY  THEN  SUPERSEDE  THE
C         VALUES DEFINED FOR THE GIVEN FORCE
C=======================================================================
C
      IF (ITHRIN.EQ.1) THREEB=THRINP
      IF (IFOUIN.EQ.1) FOURBD=FOUINP
C
C=======================================================================
C         HERE WE SET THE VALUES OF THE CHARGE-SYMMETRY-BREAKING
C         COUPLING CONSTANTS
C=======================================================================
C
      IF (I_2CBR.EQ.1) THEN
C
          CR2CBR(0,0,0) = T02CBR*(1.0D0-X02CBR)/2.0D0
          CR2CBR(1,1,0) = T02CBR*(1.0D0-X02CBR)/2.0D0
          CR2CBR(0,1,0) =-T02CBR*(1.0D0-X02CBR)/2.0D0
          CR2CBR(1,0,0) = CR2CBR(0,1,0)
C
          CR2CBR(0,0,1) = 0.0D0
          CR2CBR(1,1,1) = 0.0D0
          CR2CBR(0,1,1) =-T02CBR*(1.0D0-X02CBR)/2.0D0
          CR2CBR(1,0,1) = CR2CBR(0,1,1)
C=======================================================================
          CS2CBR(0,0,0) =-T02CBR*(1.0D0-X02CBR)/2.0D0
          CS2CBR(1,1,0) =-T02CBR*(1.0D0-X02CBR)/2.0D0
          CS2CBR(0,1,0) = T02CBR*(1.0D0-X02CBR)/2.0D0
          CS2CBR(1,0,0) = CS2CBR(0,1,0)
C
          CS2CBR(0,0,1) = 0.0D0
          CS2CBR(1,1,1) = 0.0D0
          CS2CBR(0,1,1) = T02CBR*(1.0D0-X02CBR)/2.0D0
          CS2CBR(1,0,1) = CS2CBR(0,1,1)
C=======================================================================
          CT2CBR(0,0,0) = T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/4.0D0*3.0D0
          CT2CBR(1,1,0) = T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/4.0D0*3.0D0
          CT2CBR(0,1,0) =-T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/4.0D0*3.0D0
          CT2CBR(1,0,0) = CT2CBR(0,1,0)
C
          CT2CBR(0,0,1) = 0.0D0
          CT2CBR(1,1,1) = 0.0D0
          CT2CBR(0,1,1) =-T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/4.0D0*3.0D0
          CT2CBR(1,0,1) = CT2CBR(0,1,1)
C=======================================================================
          CK2CBR(0,0,0) =-T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/4.0D0
          CK2CBR(1,1,0) =-T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/4.0D0
          CK2CBR(0,1,0) = T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/4.0D0
          CK2CBR(1,0,0) = CK2CBR(0,1,0)
C
          CK2CBR(0,0,1) = 0.0D0
          CK2CBR(1,1,1) = 0.0D0
          CK2CBR(0,1,1) = T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/4.0D0
          CK2CBR(1,0,1) = CK2CBR(0,1,1)
C=======================================================================
          CL2CBR(0,0,0) =-T12CBR*(1.0D0-X12CBR)/16.0D0*3.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/16.0D0*3.0D0
          CL2CBR(1,1,0) =-T12CBR*(1.0D0-X12CBR)/16.0D0*3.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/16.0D0*3.0D0
          CL2CBR(0,1,0) = T12CBR*(1.0D0-X12CBR)/16.0D0*3.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/16.0D0*3.0D0
          CL2CBR(1,0,0) = CL2CBR(0,1,0)
C
          CL2CBR(0,0,1) = 0.0D0
          CL2CBR(1,1,1) = 0.0D0
          CL2CBR(0,1,1) = T12CBR*(1.0D0-X12CBR)/16.0D0*3.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/16.0D0*3.0D0
          CL2CBR(1,0,1) = CL2CBR(0,1,1)
C=======================================================================
          CP2CBR(0,0,0) = T12CBR*(1.0D0-X12CBR)/16.0D0*3.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/16.0D0
          CP2CBR(1,1,0) = T12CBR*(1.0D0-X12CBR)/16.0D0*3.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/16.0D0
          CP2CBR(0,1,0) =-T12CBR*(1.0D0-X12CBR)/16.0D0*3.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/16.0D0
          CP2CBR(1,0,0) = CP2CBR(0,1,0)
C
          CP2CBR(0,0,1) = 0.0D0
          CP2CBR(1,1,1) = 0.0D0
          CP2CBR(0,1,1) =-T12CBR*(1.0D0-X12CBR)/16.0D0*3.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/16.0D0
          CP2CBR(1,0,1) = CP2CBR(0,1,1)
C=======================================================================
          CC2CBR(0,0,0) =-T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/4.0D0*3.0D0
          CC2CBR(1,1,0) =-T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/4.0D0*3.0D0
          CC2CBR(0,1,0) =+T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/4.0D0*3.0D0
          CC2CBR(1,0,0) = CC2CBR(0,1,0)
C
          CC2CBR(0,0,1) = 0.0D0
          CC2CBR(1,1,1) = 0.0D0
          CC2CBR(0,1,1) =+T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/4.0D0*3.0D0
          CC2CBR(1,0,1) = CC2CBR(0,1,1)
C=======================================================================
          CJ2CBR(0,0,0) = T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/4.0D0
          CJ2CBR(1,1,0) =+T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   -T22CBR*(1.0D0+X22CBR)/4.0D0
          CJ2CBR(0,1,0) =-T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/4.0D0
          CJ2CBR(1,0,0) = CJ2CBR(0,1,0)
C
          CJ2CBR(0,0,1) = 0.0D0
          CJ2CBR(1,1,1) = 0.0D0
          CJ2CBR(0,1,1) =-T12CBR*(1.0D0-X12CBR)/4.0D0
     *                   +T22CBR*(1.0D0+X22CBR)/4.0D0
          CJ2CBR(1,0,1) = CJ2CBR(0,1,1)
C
C=======================================================================
C     CALCULATING GRADIENTS FOR T0, T1, T2, X2 FOR CLASS II
C=======================================================================
          GR2CBR(0,0,0,0) = (1.0D0-X02CBR)/2.0D0
          GR2CBR(1,1,0,0) = (1.0D0-X02CBR)/2.0D0
          GR2CBR(0,1,0,0) =-(1.0D0-X02CBR)/2.0D0
          GR2CBR(1,0,0,0) = GR2CBR(0,1,0,0)
C
          GR2CBR(0,0,1,0) = 0.0D0
          GR2CBR(1,1,1,0) = 0.0D0
          GR2CBR(0,1,1,0) =-(1.0D0-X02CBR)/2.0D0
          GR2CBR(1,0,1,0) = GR2CBR(0,1,1,0)
C
          GR2CBR(0,0,0,1) = 0.0D0
          GR2CBR(1,1,0,1) = 0.0D0
          GR2CBR(0,1,0,1) = 0.0D0
          GR2CBR(1,0,0,1) = 0.0D0
C
          GR2CBR(0,0,1,1) = 0.0D0
          GR2CBR(1,1,1,1) = 0.0D0
          GR2CBR(0,1,1,1) = 0.0D0
          GR2CBR(1,0,1,1) = 0.0D0
C
          GR2CBR(0,0,0,2) = 0.0D0
          GR2CBR(1,1,0,2) = 0.0D0
          GR2CBR(0,1,0,2) = 0.0D0
          GR2CBR(1,0,0,2) = 0.0D0
C
          GR2CBR(0,0,1,2) = 0.0D0
          GR2CBR(1,1,1,2) = 0.0D0
          GR2CBR(0,1,1,2) = 0.0D0
          GR2CBR(1,0,1,2) = 0.0D0
C=======================================================================
          GS2CBR(0,0,0,0) =-(1.0D0-X02CBR)/2.0D0
          GS2CBR(1,1,0,0) =-(1.0D0-X02CBR)/2.0D0
          GS2CBR(0,1,0,0) = (1.0D0-X02CBR)/2.0D0
          GS2CBR(1,0,0,0) = GS2CBR(0,1,0,0)
C
          GS2CBR(0,0,1,0) = 0.0D0
          GS2CBR(1,1,1,0) = 0.0D0
          GS2CBR(0,1,1,0) = (1.0D0-X02CBR)/2.0D0
          GS2CBR(1,0,1,0) = GS2CBR(0,1,1,0)
C
          GS2CBR(0,0,0,1) = 0.0D0
          GS2CBR(1,1,0,1) = 0.0D0
          GS2CBR(0,1,0,1) = 0.0D0
          GS2CBR(1,0,0,1) = 0.0D0
C
          GS2CBR(0,0,1,1) = 0.0D0
          GS2CBR(1,1,1,1) = 0.0D0
          GS2CBR(0,1,1,1) = 0.0D0
          GS2CBR(1,0,1,1) = 0.0D0
C
          GS2CBR(0,0,0,2) = 0.0D0
          GS2CBR(1,1,0,2) = 0.0D0
          GS2CBR(0,1,0,2) = 0.0D0
          GS2CBR(1,0,0,2) = 0.0D0
C
          GS2CBR(0,0,1,2) = 0.0D0
          GS2CBR(1,1,1,2) = 0.0D0
          GS2CBR(0,1,1,2) = 0.0D0
          GS2CBR(1,0,1,2) = 0.0D0
C=======================================================================
          GT2CBR(0,0,0,0) = 0.0D0
          GT2CBR(1,1,0,0) = 0.0D0
          GT2CBR(0,1,0,0) = 0.0D0
          GT2CBR(1,0,0,0) = 0.0D0
C
          GT2CBR(0,0,1,0) = 0.0D0
          GT2CBR(1,1,1,0) = 0.0D0
          GT2CBR(0,1,1,0) = 0.0D0
          GT2CBR(1,0,1,0) = 0.0D0
C
          GT2CBR(0,0,0,1) = (1.0D0-X12CBR)/4.0D0
          GT2CBR(1,1,0,1) = (1.0D0-X12CBR)/4.0D0
          GT2CBR(0,1,0,1) =-(1.0D0-X12CBR)/4.0D0
          GT2CBR(1,0,0,1) = GT2CBR(0,1,0,1)
C
          GT2CBR(0,0,1,1) = 0.0D0
          GT2CBR(1,1,1,1) = 0.0D0
          GT2CBR(0,1,1,1) =-(1.0D0-X12CBR)/4.0D0
          GT2CBR(1,0,1,1) = GT2CBR(0,1,1,1)
C
          GT2CBR(0,0,0,2) = (1.0D0+X22CBR)/4.0D0*3.0D0
          GT2CBR(1,1,0,2) = (1.0D0+X22CBR)/4.0D0*3.0D0
          GT2CBR(0,1,0,2) =-(1.0D0+X22CBR)/4.0D0*3.0D0
          GT2CBR(1,0,0,2) = GT2CBR(0,1,0,2)
C
          GT2CBR(0,0,1,2) = 0.0D0
          GT2CBR(1,1,1,2) = 0.0D0
          GT2CBR(0,1,1,2) =-(1.0D0+X22CBR)/4.0D0*3.0D0
          GT2CBR(1,0,1,2) = GT2CBR(0,1,1,2)
C=======================================================================
          GK2CBR(0,0,0,0) = 0.0D0
          GK2CBR(1,1,0,0) = 0.0D0
          GK2CBR(0,1,0,0) = 0.0D0
          GK2CBR(1,0,0,0) = 0.0D0
C
          GK2CBR(0,0,1,0) = 0.0D0
          GK2CBR(1,1,1,0) = 0.0D0
          GK2CBR(0,1,1,0) = 0.0D0
          GK2CBR(1,0,1,0) = 0.0D0
C
          GK2CBR(0,0,0,1) =-(1.0D0-X12CBR)/4.0D0
          GK2CBR(1,1,0,1) =-(1.0D0-X12CBR)/4.0D0
          GK2CBR(0,1,0,1) = (1.0D0-X12CBR)/4.0D0
          GK2CBR(1,0,0,1) = GK2CBR(0,1,0,1)
C
          GK2CBR(0,0,1,1) = 0.0D0
          GK2CBR(1,1,1,1) = 0.0D0
          GK2CBR(0,1,1,1) = (1.0D0-X12CBR)/4.0D0
          GK2CBR(1,0,1,1) = GK2CBR(0,1,1,1)
C
          GK2CBR(0,0,0,2) = (1.0D0+X22CBR)/4.0D0
          GK2CBR(1,1,0,2) = (1.0D0+X22CBR)/4.0D0
          GK2CBR(0,1,0,2) =-(1.0D0+X22CBR)/4.0D0
          GK2CBR(1,0,0,2) = GK2CBR(0,1,0,2)
C
          GK2CBR(0,0,1,2) = 0.0D0
          GK2CBR(1,1,1,2) = 0.0D0
          GK2CBR(0,1,1,2) =-(1.0D0+X22CBR)/4.0D0
          GK2CBR(1,0,1,2) = GK2CBR(0,1,1,2)
C=======================================================================
          GL2CBR(0,0,0,0) = 0.0D0
          GL2CBR(1,1,0,0) = 0.0D0
          GL2CBR(0,1,0,0) = 0.0D0
          GL2CBR(1,0,0,0) = 0.0D0
C
          GL2CBR(0,0,1,0) = 0.0D0
          GL2CBR(1,1,1,0) = 0.0D0
          GL2CBR(0,1,1,0) = 0.0D0
          GL2CBR(1,0,1,0) = 0.0D0
C
          GL2CBR(0,0,0,1) =-(1.0D0-X12CBR)/16.0D0*3.0D0
          GL2CBR(1,1,0,1) =-(1.0D0-X12CBR)/16.0D0*3.0D0
          GL2CBR(0,1,0,1) = (1.0D0-X12CBR)/16.0D0*3.0D0
          GL2CBR(1,0,0,1) = GL2CBR(0,1,0,1)
C
          GL2CBR(0,0,1,1) = 0.0D0
          GL2CBR(1,1,1,1) = 0.0D0
          GL2CBR(0,1,1,1) = (1.0D0-X12CBR)/16.0D0*3.0D0
          GL2CBR(1,0,1,1) = GL2CBR(0,1,1,1)
C
          GL2CBR(0,0,0,2) = (1.0D0+X22CBR)/16.0D0*3.0D0
          GL2CBR(1,1,0,2) = (1.0D0+X22CBR)/16.0D0*3.0D0
          GL2CBR(0,1,0,2) =-(1.0D0+X22CBR)/16.0D0*3.0D0
          GL2CBR(1,0,0,2) = GL2CBR(0,1,0,2)
C
          GL2CBR(0,0,1,2) = 0.0D0
          GL2CBR(1,1,1,2) = 0.0D0
          GL2CBR(0,1,1,2) =-(1.0D0+X22CBR)/16.0D0*3.0D0
          GL2CBR(1,0,1,2) = GL2CBR(0,1,1,2)
C=======================================================================
          GP2CBR(0,0,0,0) = 0.0D0
          GP2CBR(1,1,0,0) = 0.0D0
          GP2CBR(0,1,0,0) = 0.0D0
          GP2CBR(1,0,0,0) = 0.0D0
C
          GP2CBR(0,0,1,0) = 0.0D0
          GP2CBR(1,1,1,0) = 0.0D0
          GP2CBR(0,1,1,0) = 0.0D0
          GP2CBR(1,0,1,0) = 0.0D0
C
          GP2CBR(0,0,0,1) = (1.0D0-X12CBR)/16.0D0*3.0D0
          GP2CBR(1,1,0,1) = (1.0D0-X12CBR)/16.0D0*3.0D0
          GP2CBR(0,1,0,1) =-(1.0D0-X12CBR)/16.0D0*3.0D0
          GP2CBR(1,0,0,1) = GP2CBR(0,1,0,1)
C
          GP2CBR(0,0,1,1) = 0.0D0
          GP2CBR(1,1,1,1) = 0.0D0
          GP2CBR(0,1,1,1) =-(1.0D0-X12CBR)/16.0D0*3.0D0
          GP2CBR(1,0,1,1) = GP2CBR(0,1,1,1)
C
          GP2CBR(0,0,0,2) = (1.0D0+X22CBR)/16.0D0
          GP2CBR(1,1,0,2) = (1.0D0+X22CBR)/16.0D0
          GP2CBR(0,1,0,2) =-(1.0D0+X22CBR)/16.0D0
          GP2CBR(1,0,0,2) = GP2CBR(0,1,0,2)
C
          GP2CBR(0,0,1,2) = 0.0D0
          GP2CBR(1,1,1,2) = 0.0D0
          GP2CBR(0,1,1,2) =-(1.0D0+X22CBR)/16.0D0
          GP2CBR(1,0,1,2) = GP2CBR(0,1,1,2)
C=======================================================================
          GC2CBR(0,0,0,0) = 0.0D0
          GC2CBR(1,1,0,0) = 0.0D0
          GC2CBR(0,1,0,0) = 0.0D0
          GC2CBR(1,0,0,0) = 0.0D0
C
          GC2CBR(0,0,1,0) = 0.0D0
          GC2CBR(1,1,1,0) = 0.0D0
          GC2CBR(0,1,1,0) = 0.0D0
          GC2CBR(1,0,1,0) = 0.0D0
C
          GC2CBR(0,0,0,1) =-(1.0D0-X12CBR)/4.0D0
          GC2CBR(1,1,0,1) =-(1.0D0-X12CBR)/4.0D0
          GC2CBR(0,1,0,1) = (1.0D0-X12CBR)/4.0D0
          GC2CBR(1,0,0,1) = GC2CBR(0,1,0,1)
C
          GC2CBR(0,0,1,1) = 0.0D0
          GC2CBR(1,1,1,1) = 0.0D0
          GC2CBR(0,1,1,1) = (1.0D0-X12CBR)/4.0D0
          GC2CBR(1,0,1,1) = GC2CBR(0,1,1,1)
C
          GC2CBR(0,0,0,2) =-(1.0D0+X22CBR)/4.0D0*3.0D0
          GC2CBR(1,1,0,2) =-(1.0D0+X22CBR)/4.0D0*3.0D0
          GC2CBR(0,1,0,2) = (1.0D0+X22CBR)/4.0D0*3.0D0
          GC2CBR(1,0,0,2) = GC2CBR(0,1,0,2)
C
          GC2CBR(0,0,1,2) = 0.0D0
          GC2CBR(1,1,1,2) = 0.0D0
          GC2CBR(0,1,1,2) =+(1.0D0+X22CBR)/4.0D0*3.0D0
          GC2CBR(1,0,1,2) = GC2CBR(0,1,1,2)
C=======================================================================
          GJ2CBR(0,0,0,0) = 0.0D0
          GJ2CBR(1,1,0,0) = 0.0D0
          GJ2CBR(0,1,0,0) = 0.0D0
          GJ2CBR(1,0,0,0) = 0.0D0
C
          GJ2CBR(0,0,1,0) = 0.0D0
          GJ2CBR(1,1,1,0) = 0.0D0
          GJ2CBR(0,1,1,0) = 0.0D0
          GJ2CBR(1,0,1,0) = 0.0D0
C
          GJ2CBR(0,0,0,1) = (1.0D0-X12CBR)/4.0D0
          GJ2CBR(1,1,0,1) = (1.0D0-X12CBR)/4.0D0
          GJ2CBR(0,1,0,1) =-(1.0D0-X12CBR)/4.0D0
          GJ2CBR(1,0,0,1) = GJ2CBR(0,1,0,1)
C
          GJ2CBR(0,0,1,1) = 0.0D0
          GJ2CBR(1,1,1,1) = 0.0D0
          GJ2CBR(0,1,1,1) =-(1.0D0-X12CBR)/4.0D0
          GJ2CBR(1,0,1,1) = GJ2CBR(0,1,1,1)
C
          GJ2CBR(0,0,0,2) =-(1.0D0+X22CBR)/4.0D0
          GJ2CBR(1,1,0,2) =-(1.0D0+X22CBR)/4.0D0
          GJ2CBR(0,1,0,2) =+(1.0D0+X22CBR)/4.0D0
          GJ2CBR(1,0,0,2) = GJ2CBR(0,1,0,2)
C
          GJ2CBR(0,0,1,2) = 0.0D0
          GJ2CBR(1,1,1,2) = 0.0D0
          GJ2CBR(0,1,1,2) = (1.0D0+X22CBR)/4.0D0
          GJ2CBR(1,0,1,2) = GJ2CBR(0,1,1,2)
C
      END IF
C
C=======================================================================
C     CALCULATING COUPLING CONSTANTS FOR CLASS III
C=======================================================================
C
      IF (I_3CBR.EQ.1) THEN
C
          CR3CBR(0,0,0) = T03CBR*(1.0D0-X03CBR)/2.0D0
          CR3CBR(1,1,0) =-T03CBR*(1.0D0-X03CBR)/2.0D0
          CR3CBR(0,1,0) = 0.0D0
          CR3CBR(1,0,0) = CR3CBR(0,1,0)
C
          CR3CBR(0,0,1) = 0.0D0
          CR3CBR(1,1,1) = 0.0D0
          CR3CBR(0,1,1) = 0.0D0
          CR3CBR(1,0,1) = 0.0D0
C=======================================================================
          CS3CBR(0,0,0) =-T03CBR*(1.0D0-X03CBR)/2.0D0
          CS3CBR(1,1,0) = T03CBR*(1.0D0-X03CBR)/2.0D0
          CS3CBR(0,1,0) = 0.0D0
          CS3CBR(1,0,0) = CS3CBR(0,1,0)
C
          CS3CBR(0,0,1) = 0.0D0
          CS3CBR(1,1,1) = 0.0D0
          CS3CBR(0,1,1) = 0.0D0
          CS3CBR(1,0,1) = 0.0D0
C=======================================================================
          CT3CBR(0,0,0) = T13CBR*(1.0D0-X13CBR)/4.0D0
     *                   +T23CBR*(1.0D0+X23CBR)/4.0D0*3.0D0
          CT3CBR(1,1,0) =-T13CBR*(1.0D0-X13CBR)/4.0D0
     *                   -T23CBR*(1.0D0+X23CBR)/4.0D0*3.0D0
          CT3CBR(0,1,0) = 0.0D0
          CT3CBR(1,0,0) = CT3CBR(0,1,0)
C
          CT3CBR(0,0,1) = 0.0D0
          CT3CBR(1,1,1) = 0.0D0
          CT3CBR(0,1,1) = 0.0D0
          CT3CBR(1,0,1) = 0.0D0
C=======================================================================
          CK3CBR(0,0,0) =-T13CBR*(1.0D0-X13CBR)/4.0D0
     *                   +T23CBR*(1.0D0+X23CBR)/4.0D0
          CK3CBR(1,1,0) = T13CBR*(1.0D0-X13CBR)/4.0D0
     *                   -T23CBR*(1.0D0+X23CBR)/4.0D0
          CK3CBR(0,1,0) = 0.0D0
          CK3CBR(1,0,0) = CK3CBR(0,1,0)
C
          CK3CBR(0,0,1) = 0.0D0
          CK3CBR(1,1,1) = 0.0D0
          CK3CBR(0,1,1) = 0.0D0
          CK3CBR(1,0,1) = 0.0D0
C=======================================================================
          CL3CBR(0,0,0) =-T13CBR*(1.0D0-X13CBR)/16.0D0*3.0D0
     *                   +T23CBR*(1.0D0+X23CBR)/16.0D0*3.0D0
          CL3CBR(1,1,0) = T13CBR*(1.0D0-X13CBR)/16.0D0*3.0D0
     *                   -T23CBR*(1.0D0+X23CBR)/16.0D0*3.0D0
          CL3CBR(0,1,0) = 0.0D0
          CL3CBR(1,0,0) = CL3CBR(0,1,0)
C
          CL3CBR(0,0,1) = 0.0D0
          CL3CBR(1,1,1) = 0.0D0
          CL3CBR(0,1,1) = 0.0D0
          CL3CBR(1,0,1) = 0.0D0
C=======================================================================
          CP3CBR(0,0,0) = T13CBR*(1.0D0-X13CBR)/16.0D0*3.0D0
     *                   +T23CBR*(1.0D0+X23CBR)/16.0D0
          CP3CBR(1,1,0) =-T13CBR*(1.0D0-X13CBR)/16.0D0*3.0D0
     *                   -T23CBR*(1.0D0+X23CBR)/16.0D0
          CP3CBR(0,1,0) = 0.0D0
          CP3CBR(1,0,0) = CP3CBR(0,1,0)
C
          CP3CBR(0,0,1) = 0.0D0
          CP3CBR(1,1,1) = 0.0D0
          CP3CBR(0,1,1) = 0.0D0
          CP3CBR(1,0,1) = 0.0D0
C=======================================================================
          CC3CBR(0,0,0) =-T13CBR*(1.0D0-X13CBR)/4.0D0
     *                   -T23CBR*(1.0D0+X23CBR)/4.0D0*3.0D0
          CC3CBR(1,1,0) =+T13CBR*(1.0D0-X13CBR)/4.0D0
     *                   +T23CBR*(1.0D0+X23CBR)/4.0D0*3.0D0
          CC3CBR(0,1,0) = 0.0D0
          CC3CBR(1,0,0) = CC3CBR(0,1,0)
C
          CC3CBR(0,0,1) = 0.0D0
          CC3CBR(1,1,1) = 0.0D0
          CC3CBR(0,1,1) = 0.0D0
          CC3CBR(1,0,1) = 0.0D0
C=======================================================================
          CJ3CBR(0,0,0) =+T13CBR*(1.0D0-X13CBR)/4.0D0
     *                   -T23CBR*(1.0D0+X23CBR)/4.0D0
          CJ3CBR(1,1,0) =-T13CBR*(1.0D0-X13CBR)/4.0D0
     *                   +T23CBR*(1.0D0+X23CBR)/4.0D0
          CJ3CBR(0,1,0) = 0.0D0
          CJ3CBR(1,0,0) = CJ3CBR(0,1,0)
C
          CJ3CBR(0,0,1) = 0.0D0
          CJ3CBR(1,1,1) = 0.0D0
          CJ3CBR(0,1,1) = 0.0D0
          CJ3CBR(1,0,1) = 0.0D0
C
C=======================================================================
C     CALCULATING GRADIENTS FOR T0, T1, T2 FOR CLASS III
C=======================================================================
          GR3CBR(0,0,0,0) = (1.0D0-X03CBR)/2.0D0
          GR3CBR(1,1,0,0) =-(1.0D0-X03CBR)/2.0D0
          GR3CBR(0,1,0,0) = 0.0D0
          GR3CBR(1,0,0,0) = GR3CBR(0,1,0,0)
C
          GR3CBR(0,0,0,1) = 0.0D0
          GR3CBR(1,1,0,1) = 0.0D0
          GR3CBR(0,1,0,1) = 0.0D0
          GR3CBR(1,0,0,1) = 0.0D0
C
          GR3CBR(0,0,0,2) = 0.0D0
          GR3CBR(1,1,0,2) = 0.0D0
          GR3CBR(0,1,0,2) = 0.0D0
          GR3CBR(1,0,0,2) = 0.0D0
C
          DO IGR=0,2
             GR3CBR(0,0,1,IGR) = 0.0D0
             GR3CBR(1,1,1,IGR) = 0.0D0
             GR3CBR(0,1,1,IGR) = 0.0D0
             GR3CBR(1,0,1,IGR) = 0.0D0
          END DO
C=======================================================================
          GS3CBR(0,0,0,0) =-(1.0D0-X03CBR)/2.0D0
          GS3CBR(1,1,0,0) = (1.0D0-X03CBR)/2.0D0
          GS3CBR(0,1,0,0) = 0.0D0
          GS3CBR(1,0,0,0) = GS3CBR(0,1,0,0)
C
          GS3CBR(0,0,0,1) = 0.0D0
          GS3CBR(1,1,0,1) = 0.0D0
          GS3CBR(0,1,0,1) = 0.0D0
          GS3CBR(1,0,0,1) = 0.0D0
C
          GS3CBR(0,0,0,2) = 0.0D0
          GS3CBR(1,1,0,2) = 0.0D0
          GS3CBR(0,1,0,2) = 0.0D0
          GS3CBR(1,0,0,2) = 0.0D0
C
          DO IGR=0,2
             GS3CBR(0,0,1,IGR) = 0.0D0
             GS3CBR(1,1,1,IGR) = 0.0D0
             GS3CBR(0,1,1,IGR) = 0.0D0
             GS3CBR(1,0,1,IGR) = 0.0D0
          END DO
C=======================================================================
          GT3CBR(0,0,0,0) = 0.0D0
          GT3CBR(1,1,0,0) = 0.0D0
          GT3CBR(0,1,0,0) = 0.0D0
          GT3CBR(1,0,0,0) = 0.0D0
C
          GT3CBR(0,0,0,1) = (1.0D0-X13CBR)/4.0D0
          GT3CBR(1,1,0,1) =-(1.0D0-X13CBR)/4.0D0
          GT3CBR(0,1,0,1) = 0.0D0
          GT3CBR(1,0,0,1) = GT3CBR(0,1,0,1)
C
          GT3CBR(0,0,0,2) = (1.0D0+X23CBR)/4.0D0*3.0D0
          GT3CBR(1,1,0,2) =-(1.0D0+X23CBR)/4.0D0*3.0D0
          GT3CBR(0,1,0,2) = 0.0D0
          GT3CBR(1,0,0,2) = GT3CBR(0,1,0,2)
C
          DO IGR=0,2
             GT3CBR(0,0,1,IGR) = 0.0D0
             GT3CBR(1,1,1,IGR) = 0.0D0
             GT3CBR(0,1,1,IGR) = 0.0D0
             GT3CBR(1,0,1,IGR) = 0.0D0
          END DO
C=======================================================================
          GK3CBR(0,0,0,0) = 0.0D0
          GK3CBR(1,1,0,0) = 0.0D0
          GK3CBR(0,1,0,0) = 0.0D0
          GK3CBR(1,0,0,0) = 0.0D0
C
          GK3CBR(0,0,0,1) =-(1.0D0-X13CBR)/4.0D0
          GK3CBR(1,1,0,1) = (1.0D0-X13CBR)/4.0D0
          GK3CBR(0,1,0,1) = 0.0D0
          GK3CBR(1,0,0,1) = GK3CBR(0,1,0,1)
C
          GK3CBR(0,0,0,2) = (1.0D0+X23CBR)/4.0D0
          GK3CBR(1,1,0,2) =-(1.0D0+X23CBR)/4.0D0
          GK3CBR(0,1,0,2) = 0.0D0
          GK3CBR(1,0,0,2) = GK3CBR(0,1,0,2)
C
          DO IGR=0,2
             GK3CBR(0,0,1,IGR) = 0.0D0
             GK3CBR(1,1,1,IGR) = 0.0D0
             GK3CBR(0,1,1,IGR) = 0.0D0
             GK3CBR(1,0,1,IGR) = 0.0D0
          END DO
C=======================================================================
          GL3CBR(0,0,0,0) = 0.0D0
          GL3CBR(1,1,0,0) = 0.0D0
          GL3CBR(0,1,0,0) = 0.0D0
          GL3CBR(1,0,0,0) = 0.0D0
C
          GL3CBR(0,0,0,1) =-(1.0D0-X13CBR)/16.0D0*3.0D0
          GL3CBR(1,1,0,1) = (1.0D0-X13CBR)/16.0D0*3.0D0
          GL3CBR(0,1,0,1) = 0.0D0
          GL3CBR(1,0,0,1) = GL3CBR(0,1,0,1)
C
          GL3CBR(0,0,0,2) = (1.0D0+X23CBR)/16.0D0*3.0D0
          GL3CBR(1,1,0,2) =-(1.0D0+X23CBR)/16.0D0*3.0D0
          GL3CBR(0,1,0,2) = 0.0D0
          GL3CBR(1,0,0,2) = GL3CBR(0,1,0,2)
C
          DO IGR=0,2
             GL3CBR(0,0,1,IGR) = 0.0D0
             GL3CBR(1,1,1,IGR) = 0.0D0
             GL3CBR(0,1,1,IGR) = 0.0D0
             GL3CBR(1,0,1,IGR) = 0.0D0
          END DO
C=======================================================================
          GP3CBR(0,0,0,0) = 0.0D0
          GP3CBR(1,1,0,0) = 0.0D0
          GP3CBR(0,1,0,0) = 0.0D0
          GP3CBR(1,0,0,0) = 0.0D0
C
          GP3CBR(0,0,0,1) = (1.0D0-X13CBR)/16.0D0*3.0D0
          GP3CBR(1,1,0,1) =-(1.0D0-X13CBR)/16.0D0*3.0D0
          GP3CBR(0,1,0,1) = 0.0D0
          GP3CBR(1,0,0,1) = GP3CBR(0,1,0,1)
C
          GP3CBR(0,0,0,2) = (1.0D0+X23CBR)/16.0D0
          GP3CBR(1,1,0,2) =-(1.0D0+X23CBR)/16.0D0
          GP3CBR(0,1,0,2) = 0.0D0
          GP3CBR(1,0,0,2) = GP3CBR(0,1,0,2)
C
          DO IGR=0,2
             GP3CBR(0,0,1,IGR) = 0.0D0
             GP3CBR(1,1,1,IGR) = 0.0D0
             GP3CBR(0,1,1,IGR) = 0.0D0
             GP3CBR(1,0,1,IGR) = 0.0D0
          END DO
C=======================================================================
          GC3CBR(0,0,0,0) = 0.0D0
          GC3CBR(1,1,0,0) = 0.0D0
          GC3CBR(0,1,0,0) = 0.0D0
          GC3CBR(1,0,0,0) = 0.0D0
C
          GC3CBR(0,0,0,1) =-(1.0D0-X13CBR)/4.0D0
          GC3CBR(1,1,0,1) = (1.0D0-X13CBR)/4.0D0
          GC3CBR(0,1,0,1) = 0.0D0
          GC3CBR(1,0,0,1) = GC3CBR(0,1,0,1)
C
          GC3CBR(0,0,0,2) =-(1.0D0+X23CBR)/4.0D0*3.0D0
          GC3CBR(1,1,0,2) = (1.0D0+X23CBR)/4.0D0*3.0D0
          GC3CBR(0,1,0,2) = 0.0D0
          GC3CBR(1,0,0,2) = GC3CBR(0,1,0,2)
C
          DO IGR=0,2
             GC3CBR(0,0,1,IGR) = 0.0D0
             GC3CBR(1,1,1,IGR) = 0.0D0
             GC3CBR(0,1,1,IGR) = 0.0D0
             GC3CBR(1,0,1,IGR) = 0.0D0
          END DO
C=======================================================================
          GJ3CBR(0,0,0,0) = 0.0D0
          GJ3CBR(1,1,0,0) = 0.0D0
          GJ3CBR(0,1,0,0) = 0.0D0
          GJ3CBR(1,0,0,0) = 0.0D0
C
          GJ3CBR(0,0,0,1) = (1.0D0-X13CBR)/4.0D0
          GJ3CBR(1,1,0,1) =-(1.0D0-X13CBR)/4.0D0
          GJ3CBR(0,1,0,1) = 0.0D0
          GJ3CBR(1,0,0,1) = GJ3CBR(0,1,0,1)
C
          GJ3CBR(0,0,0,2) =-(1.0D0+X23CBR)/4.0D0
          GJ3CBR(1,1,0,2) = (1.0D0+X23CBR)/4.0D0
          GJ3CBR(0,1,0,2) = 0.0D0
          GJ3CBR(1,0,0,2) = GJ3CBR(0,1,0,2)
C
          DO IGR=0,2
             GJ3CBR(0,0,1,IGR) = 0.0D0
             GJ3CBR(1,1,1,IGR) = 0.0D0
             GJ3CBR(0,1,1,IGR) = 0.0D0
             GJ3CBR(1,0,1,IGR) = 0.0D0
          END DO
C
      END IF
C
C=======================================================================
C         SECURITY CHECK OF VALUES OF SWITCHES
C=======================================================================
C
      IF ((IETA_J.NE.0.AND.IETA_J.NE.1).OR.
     *    (IETA_W.NE.0.AND.IETA_W.NE.1).OR.
     *    (IETACM.NE.0.AND.IETACM.NE.1.AND.
     *     IETACM.NE.2.AND.IETACM.NE.3).OR.
     *    (IETA_M.NE.0.AND.IETA_M.NE.1.AND.IETA_M.NE.2).OR.
     *    (IETA_P.NE.1.AND.IETA_P.NE.2).OR.
     *    (IETA_T.NE.0.AND.IETA_T.NE.1.AND.IETA_T.NE.2).OR.
     *    (IETAPA.NE.0.AND.IETAPA.NE.1.AND.IETAPA.NE.2)) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),''  INCORRECT SWITCHES IN PARAMS'',
     *                                                 7X,20(1H/),/,
     *                 1X,20(1H/),''  IETA_J ='',I2,
     *                            ''  IETA_W ='',I2,
     *                            ''  IETACM ='',I2,   1X,20(1H/),/,
     *                 1X,20(1H/),''  IETA_M ='',I2,
     *                            ''  IETA_P ='',I2,
     *                            ''  IETA_T ='',I2,   1X,20(1H/),/,
     *                 1X,20(1H/),''  IETAPA ='',I2,
     *                            ''          '',2X,
     *                            ''          '',2X,   1X,20(1H/),/)')
     *
     *    IETA_J,IETA_W,IETACM,IETA_M,IETA_P,IETA_T,IETAPA
C
          STOP 'INCORRECT SWITCHES IN PARAMS'
C
      END IF
C
C=======================================================================
C      Sanity check: if UNEDF functionals are requested, the flag
C      IF_EDF must be set to 1
C=======================================================================
C
      IF ((SKYRME.EQ.'UNE0'.OR.SKYRME.EQ.'UNE1'.OR.SKYRME.EQ.'UNE2')
     *                    .AND.IF_EDF.EQ.0) THEN
C
          WRITE(NFIPRI,'(/,1X,9(''/''),60X,9(''/''),/,
     *             1X,9(''/''),''    ACRONYMS UNE0, UNE1, UNE2 '',
     *             ''ARE USED TO ENFORCE STRICT    '',9(''/''),/,
     *             1X,9(''/''),''    COMPLIANCE  WITH THE  UNEDF'',
     *             ''  PARAMETRIZATIONS OF THE    '',9(''/''),/,
     *             1X,9(''/''),''    SKYRME  EDF BY FIXING THE '',
     *             ''PAIRING STRENGTHS TO THEIR    '',9(''/''),/,
     *             1X,9(''/''),''    UNEDF VALUES.'',43X,9(''/''),/,
     *             1X,9(''/''),60X,9(''/''),/,
     *             1X,9(''/''),''    USE  UDF0,  UDF1 OR  UDF2 '',
     *             ''IF YOU NEED FLEXIBILITY TO    '',9(''/''),/,
     *             1X,9(''/''),''    TUNE THE PAIRING STRENGTH '',
     *             ''WITH UNEDF FUNCTIONALS.       '',9(''/''),/,
     *             1X,9(''/''),60X,9(''/''))')
C
          STOP 'IF_EDF=0 AND UNEDF FUNCTIONALS IN PARAMS'
C
      END IF
C
C=======================================================================
C         CHECKING IF THE FORCE PARAMETERS HAVE BEN SET
C=======================================================================
C
      IF (ISKYRM.NE.1) THEN
C
          WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),'' UNDEFINED FORCE PARAMETERS'',
     *                                                10X,20(1H/),/,
     *                 1X,20(1H/),'' FORCE ACRONYM '',A4,'' IS NOT'',
     *                            '' SUPPORTED'',
     *                                                 1X,20(1H/),/)')
     *    SKYRME
C
          STOP 'UNDEFINED FORCE PARAMETERS IN PARAMS'
C
      END IF
C
C=======================================================================
C         PRINTING THE SKYRME FORCE PARAMETERS
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,      1H*,77X,1H*,/,
     *      1H*,27X,''SKYRME FORCE DEFINITION'',
     *                                   27X,1H*,/,
     *                               1H*,77X,1H*,/,
     *          79(1H*),/,           1H*,77X,1H*,/,
     *      1H*,1X,''PARAMETER SET '',A4,'':'',
     *      ''  T0='',F9.2,''  T1='',F9.2,
     *      ''  T2='',F9.2,''  T3='',F9.2,1X,1H*,/,
     *                               1H*,77X,1H*,/,
     *      1H*,1X,''POWER='',F13.11,
     *      ''  X0='',F9.5,''  X1='',F9.5,
     *      ''  X2='',F9.5,''  X3='',F9.5,1X,1H*)')
     *
     *      SKYRME,T0,T1,T2,T3,
     *      POWER, X0,X1,X2,X3
C
      IF (IETA_T.GE.1) THEN
C
          WRITE(NFIPRI,'(            1H*,77X,1H*,/,
     *      1H*,1X,''TENSOR INTERACTION:'',
     *      ''  TE='',F9.5,''  TO='',F9.5,15X,1H*)')
     *
     *      TETENS,TOTENS
C
      END IF
C
      IF (IETA_W.EQ.0) THEN
C
          WRITE(NFIPRI,'(            1H*,77X,1H*,/,
     *      1H*,1X,''IETA:'',
     *             '' J='',I1,1X,'' W='',I1,1X,
     *             ''CM='',I1,1X,'' M='',I1,1X,
     *             '' P='',I1,1X,'' T='',I1,1X,''PA='',I1,1X,
     *             ''HBM='',F8.5,1X,
     *             ''W ='', F7.3,2X,
     *             ''SKYRME S-O'',1X,1H*,/,
     *                                 1H*,77X,1H*,/,
     *                                      79(1H*),/)')
     *
     *      IETA_J,IETA_W,IETACM,IETA_M,IETA_P,IETA_T,IETAPA,
     *      HBMSKY,W0
C
      ELSE
C
          WRITE(NFIPRI,'(            1H*,77X,1H*,/,
     *      1H*,1X,''IETA:'',
     *             '' J='',I1,1X,'' W='',I1,1X,
     *             ''CM='',I1,1X,'' M='',I1,1X,
     *             '' P='',I1,1X,'' T='',I1,1X,''PA='',I1,1X,
     *             ''HBM='',F8.5,1X,
     *             ''W0='', F7.2,1X,
     *             ''W0P='',F7.2,1X,1H*,/,
     *                              1H*,77X,1H*,/,
     *                                   79(1H*),/)')
     *
     *      IETA_J,IETA_W,IETACM,IETA_M,IETA_P,IETA_T,IETAPA,
     *      HBMSKY,W0,W0P
C
      END IF
C
C=======================================================================
C         DEFINING THE STANDARD OR NON-STANDARD USE OF THE SKYRME FORCE
C         PARAMETERS
C=======================================================================
C
      IF (ISTAND.EQ.1) THEN
          JETA_W=IETA_W
          JETA_J=IETA_J
          JETACM=IETACM
          JETA_M=IETA_M
          JETA_P=IETA_P
          JETA_T=IETA_T
          JETAPA=IETAPA
      ELSE
          JETA_W=KETA_W
          JETA_J=KETA_J
          JETACM=KETACM
          JETA_M=KETA_M
          JETA_P=KETA_P
          JETA_T=KETA_T
          JETAPA=KETAPA
      END IF
C
C=======================================================================
C     DEFINING THE TREATMENT OF THE SKYRME TENSOR INTERACTION
C=======================================================================
C
      IF (JETA_T.EQ.0) THEN
C
          TETENS=0.0
          TOTENS=0.0
C
      END IF
C
      IF (JETA_T.EQ.2) THEN
C
          TETENS=TEINPU
          TOTENS=TOINPU
C
      END IF
C
C=======================================================================
C           DEFINING THE SKYRME-FUNCTIONAL COUPLING CONSTANTS
C=======================================================================
C
C        THE EFFECTIVE COUPLING CONSTANTS ARE CODED AS:
C                      'C'//'XXX'//'N'//'TYP'
C
C        WHERE THE SYMBOLS:  'C', 'XXX', 'N', AND 'TYP'
C        ARE EXPLAINED IN THE SUBROUTINE "ESKYRM"
C
C=======================================================================
C
      CRHO_T = ( + 1.00D0 * T0  +  0.50D0 * T0 * X0 ) /  2.0D0
      CRHO_S = ( - 0.50D0 * T0  -  1.00D0 * T0 * X0 ) /  2.0D0
C
      NRHO_N = 'RHO_'
C
C=======================================================================
C
      CSPI_T = (                +  0.50D0 * T0 * X0 ) /  2.0D0
      CSPI_S = ( - 0.50D0 * T0                      ) /  2.0D0
C
      NSPI_N = 'SPI_'
C
C=======================================================================
C
      CLPR_T = ( - 3.00D0 * T1  -  1.50D0 * T1 * X1 ) / 16.0D0
     *       + ( + 1.00D0 * T2  +  0.50D0 * T2 * X2 ) / 16.0D0
      CLPR_S = ( + 3.00D0 * T1  +  6.00D0 * T1 * X1 ) / 32.0D0
     *       + ( + 1.00D0 * T2  +  2.00D0 * T2 * X2 ) / 32.0D0
C
      NLPR_N = 'LPR_'
C
C=======================================================================
C
      CTAU_T = ( + 1.00D0 * T1  +  0.50D0 * T1 * X1 ) /  4.0D0
     *       + ( + 1.00D0 * T2  +  0.50D0 * T2 * X2 ) /  4.0D0
      CTAU_S = ( - 1.00D0 * T1  -  2.00D0 * T1 * X1 ) /  8.0D0
     *       + ( + 1.00D0 * T2  +  2.00D0 * T2 * X2 ) /  8.0D0
C
      NTAU_N = 'TAU_'
C
C=======================================================================
C
      CCUR_T = - CTAU_T
      CCUR_S = - CTAU_S
C
      NCUR_N = 'CUR_'
C
C=======================================================================
C
      CLPS_T = (                -  3.00D0 * T1 * X1 ) / 32.0D0
     *       + (                +  1.00D0 * T2 * X2 ) / 32.0D0
     *       + ( + 2.00D0 * (3*TETENS-TOTENS)       ) / 32.0D0
      CLPS_S = ( + 3.00D0 * T1                      ) / 32.0D0
     *       + ( + 1.00D0 * T2                      ) / 32.0D0
     *       + ( - 2.00D0 * (3*TETENS+TOTENS)       ) / 32.0D0
C
      TLPSET = ( + 2.00D0 * (3*TETENS       )       ) / 32.0D0
      TLPSES = ( - 2.00D0 * (3*TETENS       )       ) / 32.0D0
C
      TLPSOT = ( + 2.00D0 * (        -TOTENS)       ) / 32.0D0
      TLPSOS = ( - 2.00D0 * (        +TOTENS)       ) / 32.0D0
C
      NLPS_N = 'LPS_'
C
C=======================================================================
C
      CKIS_T = (                +  1.00D0 * T1 * X1 ) /  8.0D0
     *       + (                +  1.00D0 * T2 * X2 ) /  8.0D0
     *       + ( - 5.00D0 * (TE_THO+TO_THO)         ) /  8.0D0
     *       + ( - 2.00D0 * (TETENS+TOTENS)         ) /  8.0D0
      CKIS_S = ( - 1.00D0 * T1                      ) /  8.0D0
     *       + ( + 1.00D0 * T2                      ) /  8.0D0
     *       + ( + 5.00D0 * (TE_THO-TO_THO)         ) /  8.0D0
     *       + ( + 2.00D0 * (TETENS-TOTENS)         ) /  8.0D0
C
      TKISET = ( - 2.00D0 * (TETENS       )         ) /  8.0D0
      TKISES = ( + 2.00D0 * (TETENS       )         ) /  8.0D0
C
      TKISOT = ( - 2.00D0 * (      +TOTENS)         ) /  8.0D0
      TKISOS = ( + 2.00D0 * (      -TOTENS)         ) /  8.0D0
C
      NKIS_N = 'KIS_'
C
C=======================================================================
C
      CSCU_T = - CKIS_T
      CSCU_S = - CKIS_S
C
      TSCUET = - TKISET
      TSCUES = - TKISES
C
      TSCUOT = - TKISOT
      TSCUOS = - TKISOS
C
      NSCU_N = 'SCU_'
C
C=======================================================================
C
      CKIT_T = ( + 6.00D0 * (TETENS+TOTENS)         ) /  8.0D0
      CKIT_S = ( - 6.00D0 * (TETENS-TOTENS)         ) /  8.0D0
C
      TKITET = ( + 6.00D0 * (TETENS       )         ) /  8.0D0
      TKITES = ( - 6.00D0 * (TETENS       )         ) /  8.0D0
C
      TKITOT = ( + 6.00D0 * (      +TOTENS)         ) /  8.0D0
      TKITOS = ( - 6.00D0 * (      -TOTENS)         ) /  8.0D0
C
      NKIT_N = 'KIT_'
C
C=======================================================================
C
      CSCT_T = - CKIT_T
      CSCT_S = - CKIT_S
C
      TSCTET = - TKITET
      TSCTES = - TKITES
C
      TSCTOT = - TKITOT
      TSCTOS = - TKITOS
C
      NSCT_N = 'SCT_'
C
C=======================================================================
C
      CSPT_T = ( + 3.00D0 * (3*TETENS-TOTENS)       ) / 16.0D0
      CSPT_S = ( - 3.00D0 * (3*TETENS+TOTENS)       ) / 16.0D0
C
      TSPTET = ( + 3.00D0 * (3*TETENS       )       ) / 16.0D0
      TSPTES = ( - 3.00D0 * (3*TETENS       )       ) / 16.0D0
C
      TSPTOT = ( + 3.00D0 * (        -TOTENS)       ) / 16.0D0
      TSPTOS = ( - 3.00D0 * (        +TOTENS)       ) / 16.0D0
C
      NSPT_N = 'SPT_'
C
C=======================================================================
C
      CRHODT = ( + 1.00D0 * T3  +  0.50D0 * T3 * X3 ) / 12.0D0
      CRHODS = ( - 0.50D0 * T3  -  1.00D0 * T3 * X3 ) / 12.0D0
C
      NRHODN = 'RHOD'
C
C=======================================================================
C
      CSPIDT = (                +  0.50D0 * T3 * X3 ) / 12.0D0
      CSPIDS = ( - 0.50D0 * T3                      ) / 12.0D0
C
      NSPIDN = 'SPID'
C
C=======================================================================
C
      CDIV_T = - 0.50D0 * W0
      CDIV_S = - 0.50D0 * W0P
C
      NDIV_N = 'DIV_'
C
C=======================================================================
C
      CROT_T = CDIV_T
      CROT_S = CDIV_S
C
      NROT_N = 'ROT_'
C
C=======================================================================
C       DEFINING THE SKYRME-FUNCTIONAL COUPLING CONSTANTS FOR PAIRING
C=======================================================================
C
      IF (JETAPA.GE.1) THEN
C
          PRHO_0 = ( + 1.00D0 * T0  -  1.00D0 * T0 * X0 ) /  4.0D0
          PRHOD0 = ( + 1.00D0 * T3  -  1.00D0 * T3 * X3 ) / 24.0D0
C
          PLPR_0 = ( - 1.00D0 * T1  +  1.00D0 * T1 * X1 ) / 16.0D0
C
          PTAU_1 = ( + 1.00D0 * T1  -  1.00D0 * T1 * X1 ) /  8.0D0
          PTAU_2 = ( + 1.00D0 * T1  -  1.00D0 * T1 * X1 ) /  8.0D0
C
          PSCU_1 = ( + 1.00D0 * T2  +  1.00D0 * T2 * X2 ) / 4.0D0
C
          IF (JETAPA.EQ.1) THEN
C
              PSCU_2 = + 0.50D0 * W0
              PSCU_3 = - 0.50D0 * W0
          ELSE
              PSCU_2 = 0.0D0
              PSCU_3 = 0.0D0
C
          END IF
C
      ELSE
C
          PRHO_0 = 0.0D0
          PRHOD0 = 0.0D0
C
          PLPR_0 = 0.0D0
C
          PTAU_1 = 0.0D0
          PTAU_2 = 0.0D0
C
          PSCU_1 = 0.0D0
          PSCU_2 = 0.0D0
          PSCU_3 = 0.0D0
C
      END IF
C
C=======================================================================
C
      IF (ISTAND.EQ.0.AND.
     *    (KETA_J.NE.IETA_J.OR.
     *     KETA_W.NE.IETA_W.OR.
     *     KETACM.NE.IETACM.OR.
     *     KETA_M.NE.IETA_M.OR.
     *     KETA_P.NE.IETA_P.OR.
     *     KETA_T.NE.IETA_T.OR.
     *     KETAPA.NE.IETAPA)) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,      1H*,77X,1H*,/,
     *          1H*,1X,''NONSTANDARD USE OF '',
     *                 ''SKYRME FORCE, JETA:'',
     *                 ''  J='',I1,''  W='',I1,
     *                 '' CM='',I1,''  M='',I1,
     *                 ''  P='',I1,''  T='',I1,'' PA='',I1,
     *                                        3X,1H*,/,
     *                                   1H*,77X,1H*,/,
     *          1H*,1X,''THIS INCLUDES:'',   62X,1H*)')
     *
     *          JETA_J,JETA_W,JETACM,JETA_M,JETA_P,JETA_T,JETAPA
C
      END IF
C
C=======================================================================
C     DEFINING THE TREATMENT OF THE "J^2" TERMS
C=======================================================================
C
      IF (ISTAND.EQ.0.AND.KETA_J.NE.IETA_J) THEN
C
          IF (KETA_J.EQ.0) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE TENSOR TERMS: '',
     *                     ''THESE TERMS HAVE BEEN '',
     *                     ''NEGLECTED'',         1X,1H*)')
C
          ELSE
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE TENSOR TERMS:  '',
     *                     ''THESE TERMS HAVE BEEN '',
     *                     ''INCLUDED'',          1X,1H*)')
          END IF
C
          CKIS_T = CKIS_T * KETA_J
          CKIS_S = CKIS_S * KETA_J
C
          CSCU_T = CSCU_T * KETA_J
          CSCU_S = CSCU_S * KETA_J
C
      ELSE
C
          CKIS_T = CKIS_T * IETA_J
          CKIS_S = CKIS_S * IETA_J
C
          CSCU_T = CSCU_T * IETA_J
          CSCU_S = CSCU_S * IETA_J
C
      END IF
C
C=======================================================================
C     DEFINING THE TREATMENT OF THE SPIN-ORBIT TERMS
C=======================================================================
C
      IF (ISTAND.EQ.0.AND.KETA_W.NE.IETA_W) THEN
C
          IF (KETA_W.EQ.0) THEN
C
              W0P=W0
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE SPIN-ORBIT TERMS: '', 28X,1H*,/,
     *              1H*,1X,''TRADITIONAL SPIN-ORBIT HAS BEEN '',
     *                     ''USED FOR VALUES: '',
     *                     ''W0='',F9.4,'' W0P='',F9.4, 1X,1H*)')
     *          W0,W0P
C
          END IF
C
          IF (KETA_W.EQ.1) THEN
C
              WRITE(NFIPRI,'(                      1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE SPIN-ORBIT TERMS: '', 28X,1H*,/,
     *              1H*,1X,''GENERALIZED SPIN-ORBIT HAS BEEN '',
     *                     ''USED FOR VALUES: '',
     *                     ''W0='',F9.4,'' W0P='',F9.4, 1X,1H*)')
     *          W0,W0P
C
          END IF
C
          IF (KETA_W.EQ.2) THEN
C
              W0 =W0_INP
              W0P=W0PINP
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE SPIN-ORBIT TERMS: '', 28X,1H*,/,
     *              1H*,1X,''USER-DEFINED GENERALIZED SPIN-ORBIT '',
     *                     ''USED FOR:    '',
     *                     ''W0='',F9.4,'' W0P='',F9.4, 1X,1H*)')
     *          W0,W0P
C
          END IF
C
      END IF
C
C=======================================================================
C
      CDIV_T = - 0.50D0 * W0
      CDIV_S = - 0.50D0 * W0P
C
      CROT_T = CDIV_T
      CROT_S = CDIV_S
C
C=======================================================================
C     DEFINING THE TREATMENT OF THE CENTER-OF-MASS CORRECTION
C=======================================================================
C
      IF (ISTAND.EQ.0.AND.KETACM.NE.IETACM) THEN
C
          IF (KETACM.EQ.0) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE CENTER-OF-MASS CORRECTION '',
     *                     ''FOR THIS FORCE:'',
     *                                            5X,1H*,/,
     *              1H*,1X,''STANDARD METHOD BASED ON '',
     *                     ''THE ONE-BODY APPROXIMATION BEFORE '',
     *                     ''VARIATION USED'',    3X,1H*)')
C
          END IF
C
          IF (KETACM.EQ.1) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE CENTER-OF-MASS CORRECTION '',
     *                     ''FOR THIS FORCE:'',
     *                                            5X,1H*,/,
     *              1H*,1X,''METHOD BASED ON THE TWO-BODY '',
     *                     ''OPERATOR EVALUATED AFTER VARIATION '',
     *                     ''IS NOW USED'',       1X,1H*)')
C
          END IF
C
          IF (KETACM.EQ.2) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE CENTER-OF-MASS CORRECTION '',
     *                     ''FOR THIS FORCE:'',
     *                                            5X,1H*,/,
     *              1H*,1X,''METHOD BASED ON THE TWO-BODY '',
     *                     ''OPERATOR INCLUDED BEFORE VARIATION '',
     *                     ''IS NOW USED'',       1X,1H*)')
C
          END IF
C
          IF (KETACM.EQ.3) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE CENTER-OF-MASS CORRECTION '',
     *                     ''FOR THIS FORCE:'',
     *                                            5X,1H*,/,
     *              1H*,1X,''THE CENTER-OF-MASS CORRECTION '',
     *                     ''HAS BEEN NEGLECTED, AND SHOULD '',
     *                     ''BE ADDED LATER'',    1X,1H*)')
C
          END IF
C
      END IF
C
C=======================================================================
C     DEFINING THE TREATMENT OF THE HBAR^2/2M PARAMETER
C=======================================================================
C
      IF (JETA_M.EQ.0) HBMASS=20.73620941D0
      IF (JETA_M.EQ.1) HBMASS=HBMSKY
      IF (JETA_M.EQ.2) HBMASS=HBMINP
C
      IF (ISTAND.EQ.0.AND.KETA_M.NE.IETA_M) THEN
C
          IF (KETA_M.EQ.0) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE HBAR^2/2M PARAMETER:'',
     *                                           26X,1H*,/,
     *              1H*,1X,''VALUE FROM THE PREVIOUS '',
     *                     ''VERSION (v1.75r) HAS BEEN USED: '',
     *                     ''HBMASS='',F12.8,     1X,1H*)')
     *          HBMASS
C
          END IF
C
          IF (KETA_M.EQ.2) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE HBAR^2/2M PARAMETER:'',
     *                                           26X,1H*,/,
     *              1H*,1X,''VALUE SUPPLIED BY THE USER '',
     *                     ''IN THE DATA HAS BEEN USED:   '',
     *                     ''HBMASS='',F12.8,     1X,1H*)')
     *          HBMASS
C
          END IF
C
      END IF
C
C=======================================================================
C     DEFINING THE TREATMENT OF THE POWER PARAMETER
C=======================================================================
C
      IF (JETA_P.EQ.2) POWER=POWERD
C
      IF (ISTAND.EQ.0.AND.KETA_P.NE.IETA_P) THEN
C
          IF (KETA_P.EQ.2) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE DENSITY-POWER PARAMETER:'',
     *                                           22X,1H*,/,
     *              1H*,1X,''VALUE SUPPLIED BY THE USER '',
     *                     ''IN THE DATA HAS BEEN USED:   '',
     *                     ''POWER='',F13.11,     1X,1H*)')
     *          POWER
C
          END IF
C
      END IF
C
C=======================================================================
C     DEFINING THE TREATMENT OF THE SKYRME TENSOR INTERACTION
C=======================================================================
C
      IF (ISTAND.EQ.0.AND.KETA_T.NE.IETA_T) THEN
C
          IF (KETA_T.EQ.0) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE SKYRME TENSOR INTERACTION:'',
     *                                           20X,1H*,/,
     *              1H*,1X,''THIS INTRERACTION HAS BEEN '',
     *                     ''NEGLECTED                    '',
     *                                           20X,1H*)')
C
          END IF
C
          IF (KETA_T.EQ.2) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE SKYRME TENSOR INTERACTION:'',
     *                                           20X,1H*,/,
     *              1H*,1X,''VALUES SUPPLIED IN THE DATA '',
     *                     ''HAVE BEEN USED: '',
     *                     ''TE='',F12.6,         1X,
     *                     ''TO='',F12.6,         1X,1H*)')
     *          TEINPU,TOINPU
C
          END IF
C
      END IF
C
C=======================================================================
C     DEFINING THE TREATMENT OF THE SKYRME PAIRING INTERACTION
C=======================================================================
C
      IF (ISTAND.EQ.0.AND.KETAPA.NE.IETAPA) THEN
C
          IF (KETAPA.EQ.0) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE SKYRME PAIRING INTERACTION:'',
     *                                           19X,1H*,/,
     *              1H*,1X,''THIS INTRERACTION HAS BEEN '',
     *                     ''NEGLECTED                    '',
     *                                           20X,1H*)')
C
          END IF
C
          IF (KETAPA.EQ.1) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE SKYRME PAIRING INTERACTION:'',
     *                                           19X,1H*,/,
     *              1H*,1X,''THIS INTRERACTION HAS BEEN '',
     *                     ''TAKEN INTO ACCOUNT           '',
     *                                           20X,1H*)')
C
          END IF
C
          IF (KETAPA.EQ.2) THEN
C
              WRITE(NFIPRI,'(                1H*,77X,1H*,/,
     *              1H*,1X,''NON-STANDARD TREATMENT OF '',
     *                     ''THE SKYRME PAIRING INTERACTION:'',
     *                                           19X,1H*,/,
     *              1H*,1X,''THE SPIN-ORBIT IN THE PAIRING '',
     *                     ''CHANNEL HAS NOT BEEN INCLUDED'',
     *                                           17X,1H*)')
C
          END IF
C
      END IF
C
C=======================================================================
C
      IF (ISTAND.EQ.0.AND.
     *    (KETA_J.NE.IETA_J.OR.
     *     KETA_W.NE.IETA_W.OR.
     *     KETACM.NE.IETACM.OR.
     *     KETA_M.NE.IETA_M.OR.
     *     KETA_P.NE.IETA_P.OR.
     *     KETA_T.NE.IETA_T.OR.
     *     KETAPA.NE.IETAPA)) WRITE(NFIPRI,'(1H*,77X,1H*,/,79(1H*),/)')
C
C=======================================================================
C
      IF (JETAPA.EQ.1.AND.JETA_W.GE.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                    1H*,77X,1H*,/,
     *          1H*,1X,''WARNING: ONLY THE "W0" SPIN-ORBIT PARAMETER '',
     *                 ''USED TO DEFINE THE CONTRIBUTION'', 1X,1H*,/,
     *          1H*,1X,''         OF THIS INTERACTION TO THE PAIRING '',
     *                 ''CHANNEL                        '',1X,1H*,/,
     *          1H*,77X,1H*,/,                              79(1H*),/)')
C
      END IF
C
C=======================================================================
C         REDEFINING SIX TIME-ODD SKYRME-FORCE PARAMETERS BASED
C         ON THE FOUR LANDAU PARAMETERS G0, G0', G1, AND G1', AND
C         ON THE TWO FINITE-SYSTEM PARAMETERS X0 AND X1
C=======================================================================
C
      IF (LANODD.NE.0) THEN
C
          HBMLAN=HBMASS
          RHOLAN=-1.0
          EFFLAN=-1.0
C
          IF (RHOSKY.GT.0.0) RHOLAN=RHOSKY
          IF (EFFSKY.GT.0.0) EFFLAN=EFFSKY
C
          IF (HBMSAT.GT.0.0) HBMLAN=HBMSAT
          IF (RHOSAT.GT.0.0) RHOLAN=RHOSAT
          IF (EFFSAT.GT.0.0) EFFLAN=EFFSAT
C
C=======================================================================
C         WHEN USING THE LANDAU PARAMETERS ONE NEEDS THREE  DATA
C         VALUES  HBMLAN, RHOLAN, AND EFFLAN  THAT CORRESPOND TO
C         THE GIVEN SKYRME FORCE, AND ARE EQUAL RESPECTIVELY  TO
C         THE HBAR^2/2M, SATURATION DENSITY, AND EFFECTIVE MASS.
C         THESE VALUES SHOULD BE GIVEN EXPLICITLY FOR EACH FORCE
C         PARAMETERIZATION. HOWEVER, VALUES READ FROM THE  INPUT
C         TAKE PRECEDENCE OVER THOSE CODED FOR THE GIVEN  FORCE.
C         IF NEITHER ARE SET, THE CODE STOPS HERE.
C=======================================================================
C
          IF (HBMLAN.LE.0.0.OR.
     *        RHOLAN.LE.0.0.OR.
     *        EFFLAN.LE.0.0) THEN
C
              WRITE(NFIPRI,'(/,
     *                 1X,20(1H/),''  INCORRECT SATURATION LANDAU'',
     *                            '' DATA'',       3X,20(1H/),/,
     *                 1X,20(1H/),''  LANODD ='',I3,5X,
     *                            ''  HBMLAN ='',F8.5,   1X,20(1H/),/,
     *                 1X,20(1H/),''  RHOLAN ='',F8.5,
     *                            ''  EFFLAN ='',F8.5,   1X,20(1H/),/)')
     *
     *        LANODD,HBMLAN,RHOLAN,EFFLAN
C
              WRITE(NFIPRI,'(/,
     *                     1X,20(1H/),''  SET THESE VALUES BY USING'',
     *                                '' THE'',          6X,20(1H/),/,
     *                     1X,20(1H/),''  INPUT-KEYWORD LANDAU-SAT'',
     *                                                  11X,20(1H/),/)')
C
              STOP ' INCORRECT SATURATION LANDAU DATA IN PARAMS'
C
          END IF
C
C=======================================================================
C         CALLING THE SUBROUTINE LANDAU FOR ORIGINAL COUPLING CONSTANTS
C=======================================================================
C
          IF (LANSCA.NE.1)
     *
     *        CALL LANDAU(LANODD,LANSCA,HBMLAN,RHOLAN,EFFLAN,
     *                    CSPI_T,CSPI_S,CSPIDT,CSPIDS,CKIS_T,CKIS_S)
C
      END IF
C
C=======================================================================
C         DEFINING THE NAMES OF THE SYMMETRY-VIOLATING TERMS
C=======================================================================
C
      NSCR_N = 'SCR_'
      NDIS_N = 'DIS_'
      NDSR_N = 'DSR_'
      NSCS_N = 'SCS_'
      NSCJ_N = 'SCJ_'
      NCUS_N = 'CUS_'
      NROS_N = 'ROS_'
      NDES_N = 'DES_'
      NRHSXN = 'RHSX'
      NRHSYN = 'RHSY'
      NRHSZN = 'RHSZ'
      NRHCXN = 'RHCX'
      NRHCYN = 'RHCY'
      NRHCZN = 'RHCZ'
C
C=======================================================================
C
C         THE CODE USES THE  >>>  T-S  <<<   REPRESENTATION OF THE
C         SKYRME FUNCTIONAL.
C
C         IN THE   T-S   REPRESENTATION THE FUNCTIONAL IS COMPOSED
C         OF THE FOLLOWING TERMS:
C
C         C_T * (N1+P1) * (N2+P2) + C_S * (N1*N2 + P1*P2)
C
C         WHERE: C_T = T-TYPE COUPLING CONSTANT
C                C_S = S-TYPE COUPLING CONSTANT
C
C                N1  = NEUTRON DENSITY OF TYPE 1
C                N2  = NEUTRON DENSITY OF TYPE 2
C                P1  =  PROTON DENSITY OF TYPE 1
C                P2  =  PROTON DENSITY OF TYPE 2
C
C         IN SOME PLACES WE USE THE  >>>  P-M  <<<  REPRESENTATION
C         OF THE SKYRME FUNCTIONAL.
C
C         IN THE   P-M   REPRESENTATION THE FUNCTIONAL IS COMPOSED
C         OF THE FOLLOWING TERMS:
C
C         C_P * (N1+P1) * (N2+P2) + C_M * (N1-P1) * (N2-P2)
C
C         WHERE: C_P = P-TYPE COUPLING CONSTANT
C                C_M = M-TYPE COUPLING CONSTANT
C
C=======================================================================
C         SCALING OF COUPLING CONSTANTS IN THE T-S REPRESENTATION.
C=======================================================================
C
      DO NUCOUT=1,NDCOUT
         CCPALL(NUCOUT)=CCPALL(NUCOUT)*STSALL(NUCOUT)+ATSALL(NUCOUT)
      END DO
C
C=======================================================================
C         SCALING OF COUPLING CONSTANTS IN THE P-M REPRESENTATION.
C=======================================================================
C
C=======================================================================
C
C     ATTENTION:  IN THE PREVIOUS VERSIONS OF THE CODE, THE  SCALING  OF
C                 THE COUPLING CONSTANTS IN THE  P-M  REPRESENTATION WAS
C                 CODED INCORRECTLY.
C
C                 THIS CONCERNS VERSION 1.75L AND ALL OLDER VERSIONS, AS
C                 WELL AS VERSIONS SINCE 1.76 TILL 1.79.
C
C                 STARTING FROM VERSION 1.80, AND ALSO IN ALL THE BIFUR-
C                 CATED VERSIONS 1.75M,N,O,..., AND THE LATER ONES, THIS
C                 BUG HAS BEEN CORRECTED.
C
C=======================================================================
C
      DO NUCOUT=1,NDCOUT,2
C
         CCPTOT = CCPALL(NUCOUT  ) *  SPMALL(NUCOUT  )
     *          + CCPALL(NUCOUT+1) * (SPMALL(NUCOUT  )
     *                             -  SPMALL(NUCOUT+1))/2
C
         CCPSUM = CCPALL(NUCOUT+1) *  SPMALL(NUCOUT+1)
C
         CCPALL(NUCOUT  )=CCPTOT+  APMALL(NUCOUT  )-APMALL(NUCOUT+1)
         CCPALL(NUCOUT+1)=CCPSUM+2*APMALL(NUCOUT+1)
C
      END DO
C
C=======================================================================
C         CALLING THE SUBROUTINE LANDAU FOR SCALED COUPLING CONSTANTS
C=======================================================================
C
      IF (LANODD.NE.0.AND.LANSCA.EQ.1)
     *
     *    CALL LANDAU(LANODD,LANSCA,HBMLAN,RHOLAN,EFFLAN,
     *                CSPI_T,CSPI_S,CSPIDT,CSPIDS,CKIS_T,CKIS_S)
C
C=======================================================================
C         PRINTING THE SCALING FACTORS OF TERMS  IN  THE  FUNCTIONAL
C         (ONLY IN CASE WHEN AT LEAST ONE OF THEM IS NOT EQUAL TO 1)
C=======================================================================
C
      IPRSCA=0
C
      DO NUCOUP=1,NDCOUT
C
         IF (ABS(STSALL(NUCOUP)-1.0D0).GT.1.D-10.OR.
     *       ABS(SPMALL(NUCOUP)-1.0D0).GT.1.D-10)    IPRSCA=1
C
      END DO
C
      IF (IPRSCA.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *             1H*,14X,''SCALING FACTORS OF TERMS '',
     *                     ''IN THE SKYRME FUNCTIONAL '',13X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''      TOTAL(T)'',
     *                     ''        SUM(S)'',4X,
     *                     ''  ISOSCALAR(P)'',
     *                     ''  ISOVECTOR(M)'',4X,            1H*,/,
     *             1H*,13X,''      --------'',
     *                     ''        ------'',4X,
     *                     ''  ------------'',
     *                     ''  ------------'',4X,            1H*,/,
     *           6(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*,/,
     *           6(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('S',NCPALL(I),STSALL(2*I-1),STSALL(2*I),
     *                        SPMALL(2*I-1),SPMALL(2*I),I=1,NDCOUP/2)
C
          IF (JETA_T.GE.1)
     *
     *        WRITE(NFIPRI,'(
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('S',NCPALL(I),STSALL(2*I-1),STSALL(2*I),
     *                        SPMALL(2*I-1),SPMALL(2*I),
     *                                         I=NDCOUP/2+1,NDCOUP/2+3)
C
          WRITE(NFIPRI,'(79(1H*),/)')
C
      END IF
C
C=======================================================================
C         PRINTING THE ADDITIVE CONSTANTS OF TERMS  IN  THE  FUNCTIONAL
C         (ONLY IN CASE WHEN AT LEAST ONE OF THEM IS NOT EQUAL TO 0)
C=======================================================================
C
      IPRSCA=0
C
      DO NUCOUT=1,NDCOUT
C
         IF (ABS(ATSALL(NUCOUT)).GT.1.E-10.OR.
     *       ABS(APMALL(NUCOUT)).GT.1.E-10)    IPRSCA=1
C
      END DO
C
      IF (IPRSCA.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(1H*),/,                  1H*,77X,1H*,/,
     *             1H*, 9X,''ADDED VALUES TO COUPLING CONSTANTS '',
     *                     ''IN THE SKYRME FUNCTIONAL'',  9X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''      TOTAL(T)'',
     *                     ''        SUM(S)'',4X,
     *                     ''  ISOSCALAR(P)'',
     *                     ''  ISOVECTOR(M)'',4X,            1H*,/,
     *             1H*,13X,''      --------'',
     *                     ''        ------'',4X,
     *                     ''  ------------'',
     *                     ''  ------------'',4X,            1H*,/,
     *           6(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*,/,
     *           6(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('A',NCPALL(I),ATSALL(2*I-1),ATSALL(2*I),
     *                        APMALL(2*I-1),APMALL(2*I),I=1,NDCOUP/2)
C
          IF (JETA_T.GE.1)
     *
     *        WRITE(NFIPRI,'(
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('A',NCPALL(I),ATSALL(2*I-1),ATSALL(2*I),
     *                        APMALL(2*I-1),APMALL(2*I),
     *                                         I=NDCOUP/2+1,NDCOUP/2+3)
C
          WRITE(NFIPRI,'(79(1H*),/)')
C
      END IF
C
C=======================================================================
C         PRINTING THE COUPLING CONSTANTS OF TERMS IN THE FUNCTIONAL
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                      1H*,77X,1H*,/,
     *             1H*,14X,''COUPLING CONSTANTS DEFINING '',
     *                     ''THE SKYRME FUNCTIONAL '',   13X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*,/,
     *             1H*,13X,''      TOTAL(T)'',
     *                     ''        SUM(S)'',4X,
     *                     ''  ISOSCALAR(P)'',
     *                     ''  ISOVECTOR(M)'',4X,            1H*,/,
     *             1H*,13X,''      --------'',
     *                     ''        ------'',4X,
     *                     ''  ------------'',
     *                     ''  ------------'',4X,            1H*,/,
     *           6(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*,/,
     *           6(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('C',NCPALL(I),CCPALL(2*I-1),CCPALL(2*I),
     *                        CCPALL(2*I-1)+CCPALL(2*I)/2,
     *                                      CCPALL(2*I)/2,I=1,NDCOUP/2)
C
      IF (JETA_T.GE.1)
     *
     *    WRITE(NFIPRI,'(
     *           3(1H*,4X,A1,A4,'' = '',1X,2(2F14.6,4X),     1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *         ('C',NCPALL(I),CCPALL(2*I-1),CCPALL(2*I),
     *                        CCPALL(2*I-1)+CCPALL(2*I)/2,
     *                                      CCPALL(2*I)/2,
     *                                         I=NDCOUP/2+1,NDCOUP/2+3)
C
      WRITE(NFIPRI,'(79(1H*),/)')
C
C=======================================================================
C         PRINTING THE 2-BODY COUPLING CONSTANT
C=======================================================================
C
      IF (TWOBOD.NE.0.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *             1H*,4X, ''COUPLING CONSTANT ADDED TO THE ZERO-'',
     *                     ''RANGE TWO-BODY TERM T0:'',F10.3,4X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *    TWOBOD
C
C=======================================================================
C         PRINTING THE 3-BODY COUPLING CONSTANT
C=======================================================================
C
      IF (THREEB.NE.0.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *             1H*,4X, ''COUPLING CONSTANT DEFINING THE ZERO-'',
     *                     ''RANGE THREE-BODY FORCE:'',F10.3,4X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *    THREEB
C
C=======================================================================
C         PRINTING THE 3-BODY GRADIENT COUPLING CONSTANT
C=======================================================================
C
      IF (IGRAIN.EQ.1)
     *    WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *             1H*,4X,''COUPLING CONSTANTS DEFINING THE ZERO-'',
     *                    ''RANGE THREE-BODY GRADIENT FORCE:'',4X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/,
     *                                                  1H*,77X,1H*,/,
     *             1H*,1X,''  U1 ='',F9.3,''  Y11='',F9.6,
     *                    ''  U2 ='',F9.3,''  Y21='',F9.6,
     *                                    ''  Y22='',F9.6,   1X,1H*,/,
     *             1H*,1X,'' CC10='',F9.3,'' CC11='',F9.3,
     *                    '' CC20='',F9.3,'' CC21='',F9.3,
     *                                    '' CC22='',F9.3,   1X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *
     *    TGRA10,       TGRA11,TGRA20,       TGRA21,       TGRA22,
     *    TGRA10,TGRA10*TGRA11,TGRA20,TGRA20*TGRA21,TGRA20*TGRA22
C
C=======================================================================
C         PRINTING THE 4-BODY COUPLING CONSTANT
C=======================================================================
C
      IF (FOURBD.NE.0.0)
     *    WRITE(NFIPRI,'(79(1H*),/,                     1H*,77X,1H*,/,
     *             1H*,4X, ''COUPLING CONSTANT DEFINING THE ZERO-'',
     *                     ''RANGE  FOUR-BODY FORCE:'',F10.3,4X,1H*,/,
     *                                                  1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *    FOURBD
C
C=======================================================================
C         PRINTING THE CHARGE-SYMMETRY-BREAKING COUPLING CONSTANTS
C=======================================================================
C
      IF (I_2CBR.EQ.1 .OR. I_3CBR.EQ.1) THEN
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,1H*,14X,
     *                        ''COUPLING CONSTANTS DEFINING '',
     *                        ''THE CSB INTERACTION'',   16X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *                                                   79(1H*),/,
     *                                               1H*,77X,1H*)')
          IF (I_2CBR.EQ.1) THEN
              WRITE(NFIPRI,'(
     *             1H*,5X,''CLASS II'',10X,
     *                ''t0II= '',F7.3,5X,''x0II= '',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t1II= '',F7.3,5X,''x1II= '',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t2II= '',F7.3,5X,''x2II= '',F7.3,23X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *             1H*,5X,''P A R T I C L E   D E N S I T Y'',
     *                 5X,''S P I N   D E N S I T Y        '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''K I N E T I C   D E N S I T Y  '',
     *                 5X,''VECTOR   KINETIC   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''LAPLACIAN   PARTICLE   DENSITY '',
     *                 5X,''LAPLACIAN   SPIN   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''C U R R E N T   D E N S I T Y  '',
     *                 5X,''SPIN   CURRENT   DENSITY       '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*)')
     *             T02CBR,X02CBR,
     *             T12CBR,X12CBR,
     *             T22CBR,X22CBR,
     *             (((CR2CBR(I,J,K),I=0,1),K=0,1),
     *                  ((CS2CBR(I,J,K),I=0,1),K=0,1),J=0,1),
     *             (((CT2CBR(I,J,K),I=0,1),K=0,1),
     *                  ((CK2CBR(I,J,K),I=0,1),K=0,1),J=0,1),
     *             (((CL2CBR(I,J,K),I=0,1),K=0,1),
     *                  ((CP2CBR(I,J,K),I=0,1),K=0,1),J=0,1),
     *             (((CC2CBR(I,J,K),I=0,1),K=0,1),
     *                  ((CJ2CBR(I,J,K),I=0,1),K=0,1),J=0,1)
          END IF
C
C
          IF (I_2CBR.EQ.1) THEN
              WRITE(NFIPRI,'(
     *             1H*,5X,''GRAD0 II'',10X,
     *                ''t0II= '',F7.3,5X,''x0II= '',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t1II= '',F7.3,5X,''x1II= '',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t2II= '',F7.3,5X,''x2II= '',F7.3,23X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *             1H*,5X,''P A R T I C L E   D E N S I T Y'',
     *                 5X,''S P I N   D E N S I T Y        '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''K I N E T I C   D E N S I T Y  '',
     *                 5X,''VECTOR   KINETIC   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''LAPLACIAN   PARTICLE   DENSITY '',
     *                 5X,''LAPLACIAN   SPIN   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''C U R R E N T   D E N S I T Y  '',
     *                 5X,''SPIN   CURRENT   DENSITY       '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*)')
     *             T02CBR,X02CBR,
     *             T12CBR,X12CBR,
     *             T22CBR,X22CBR,
     *             (((GR2CBR(I,J,K,0),I=0,1),K=0,1),
     *                  ((GS2CBR(I,J,K,0),I=0,1),K=0,1),J=0,1),
     *             (((GT2CBR(I,J,K,0),I=0,1),K=0,1),
     *                  ((GK2CBR(I,J,K,0),I=0,1),K=0,1),J=0,1),
     *             (((GL2CBR(I,J,K,0),I=0,1),K=0,1),
     *                  ((GP2CBR(I,J,K,0),I=0,1),K=0,1),J=0,1),
     *             (((GC2CBR(I,J,K,0),I=0,1),K=0,1),
     *                  ((GJ2CBR(I,J,K,0),I=0,1),K=0,1),J=0,1)
          END IF
C
C
          IF (I_2CBR.EQ.1) THEN
              WRITE(NFIPRI,'(
     *             1H*,5X,''GRAD1 II'',10X,
     *                ''t0II= '',F7.3,5X,''x0II= '',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t1II= '',F7.3,5X,''x1II= '',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t2II= '',F7.3,5X,''x2II= '',F7.3,23X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *             1H*,5X,''P A R T I C L E   D E N S I T Y'',
     *                 5X,''S P I N   D E N S I T Y        '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''K I N E T I C   D E N S I T Y  '',
     *                 5X,''VECTOR   KINETIC   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''LAPLACIAN   PARTICLE   DENSITY '',
     *                 5X,''LAPLACIAN   SPIN   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''C U R R E N T   D E N S I T Y  '',
     *                 5X,''SPIN   CURRENT   DENSITY       '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*)')
     *             T02CBR,X02CBR,
     *             T12CBR,X12CBR,
     *             T22CBR,X22CBR,
     *             (((GR2CBR(I,J,K,1),I=0,1),K=0,1),
     *                  ((GS2CBR(I,J,K,1),I=0,1),K=0,1),J=0,1),
     *             (((GT2CBR(I,J,K,1),I=0,1),K=0,1),
     *                  ((GK2CBR(I,J,K,1),I=0,1),K=0,1),J=0,1),
     *             (((GL2CBR(I,J,K,1),I=0,1),K=0,1),
     *                  ((GP2CBR(I,J,K,1),I=0,1),K=0,1),J=0,1),
     *             (((GC2CBR(I,J,K,1),I=0,1),K=0,1),
     *                  ((GJ2CBR(I,J,K,1),I=0,1),K=0,1),J=0,1)
          END IF
C
C
          IF (I_2CBR.EQ.1) THEN
              WRITE(NFIPRI,'(
     *             1H*,5X,''GRAD2 II'',10X,
     *                ''t0II= '',F7.3,5X,''x0II= '',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t1II= '',F7.3,5X,''x1II= '',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t2II= '',F7.3,5X,''x2II= '',F7.3,23X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *             1H*,5X,''P A R T I C L E   D E N S I T Y'',
     *                 5X,''S P I N   D E N S I T Y        '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''K I N E T I C   D E N S I T Y  '',
     *                 5X,''VECTOR   KINETIC   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''LAPLACIAN   PARTICLE   DENSITY '',
     *                 5X,''LAPLACIAN   SPIN   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''C U R R E N T   D E N S I T Y  '',
     *                 5X,''SPIN   CURRENT   DENSITY       '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*)')
     *             T02CBR,X02CBR,
     *             T12CBR,X12CBR,
     *             T22CBR,X22CBR,
     *             (((GR2CBR(I,J,K,2),I=0,1),K=0,1),
     *                  ((GS2CBR(I,J,K,2),I=0,1),K=0,1),J=0,1),
     *             (((GT2CBR(I,J,K,2),I=0,1),K=0,1),
     *                  ((GK2CBR(I,J,K,2),I=0,1),K=0,1),J=0,1),
     *             (((GL2CBR(I,J,K,2),I=0,1),K=0,1),
     *                  ((GP2CBR(I,J,K,2),I=0,1),K=0,1),J=0,1),
     *             (((GC2CBR(I,J,K,2),I=0,1),K=0,1),
     *                  ((GJ2CBR(I,J,K,2),I=0,1),K=0,1),J=0,1)
          END IF
C
C
          IF (I_3CBR.EQ.1) THEN
              WRITE(NFIPRI,'(
     *             1H*,5X,''CLASS III'',9X,
     *                ''t0III='',F7.3,5X,''x0III='',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t1III='',F7.3,5X,''x1III='',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t2III='',F7.3,5X,''x2III='',F7.3,23X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *             1H*,5X,''P A R T I C L E   D E N S I T Y'',
     *                 5X,''S P I N   D E N S I T Y        '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''K I N E T I C   D E N S I T Y  '',
     *                 5X,''VECTOR   KINETIC   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''LAPLACIAN   PARTICLE   DENSITY '',
     *                 5X,''LAPLACIAN   SPIN   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''C U R R E N T   D E N S I T Y  '',
     *                 5X,''SPIN   CURRENT   DENSITY       '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*)')
     *             T03CBR,X03CBR,
     *             T13CBR,X13CBR,
     *             T23CBR,X23CBR,
     *             (((CR3CBR(I,J,K),I=0,1),K=0,1),
     *                  ((CS3CBR(I,J,K),I=0,1),K=0,1),J=0,1),
     *             (((CT3CBR(I,J,K),I=0,1),K=0,1),
     *                  ((CK3CBR(I,J,K),I=0,1),K=0,1),J=0,1),
     *             (((CL3CBR(I,J,K),I=0,1),K=0,1),
     *                  ((CP3CBR(I,J,K),I=0,1),K=0,1),J=0,1),
     *             (((CC3CBR(I,J,K),I=0,1),K=0,1),
     *                  ((CJ3CBR(I,J,K),I=0,1),K=0,1),J=0,1)
          END IF
C
C
          IF (I_3CBR.EQ.1) THEN
              WRITE(NFIPRI,'(
     *             1H*,5X,''GRAD0 III'',9X,
     *                ''t0III='',F7.3,5X,''x0III='',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t1III='',F7.3,5X,''x1III='',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t2III='',F7.3,5X,''x2III='',F7.3,23X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *             1H*,5X,''P A R T I C L E   D E N S I T Y'',
     *                 5X,''S P I N   D E N S I T Y        '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''K I N E T I C   D E N S I T Y  '',
     *                 5X,''VECTOR   KINETIC   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''LAPLACIAN   PARTICLE   DENSITY '',
     *                 5X,''LAPLACIAN   SPIN   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''C U R R E N T   D E N S I T Y  '',
     *                 5X,''SPIN   CURRENT   DENSITY       '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*)')
     *             T03CBR,X03CBR,
     *             T13CBR,X13CBR,
     *             T23CBR,X23CBR,
     *             (((GR3CBR(I,J,K,0),I=0,1),K=0,1),
     *                  ((GS3CBR(I,J,K,0),I=0,1),K=0,1),J=0,1),
     *             (((GT3CBR(I,J,K,0),I=0,1),K=0,1),
     *                  ((GK3CBR(I,J,K,0),I=0,1),K=0,1),J=0,1),
     *             (((GL3CBR(I,J,K,0),I=0,1),K=0,1),
     *                  ((GP3CBR(I,J,K,0),I=0,1),K=0,1),J=0,1),
     *             (((GC3CBR(I,J,K,0),I=0,1),K=0,1),
     *                  ((GJ3CBR(I,J,K,0),I=0,1),K=0,1),J=0,1)
          END IF
C
C
          IF (I_3CBR.EQ.1) THEN
              WRITE(NFIPRI,'(
     *             1H*,5X,''GRAD1 III'',9X,
     *                ''t0III='',F7.3,5X,''x0III='',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t1III='',F7.3,5X,''x1III='',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t2III='',F7.3,5X,''x2III='',F7.3,23X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *             1H*,5X,''P A R T I C L E   D E N S I T Y'',
     *                 5X,''S P I N   D E N S I T Y        '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''K I N E T I C   D E N S I T Y  '',
     *                 5X,''VECTOR   KINETIC   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''LAPLACIAN   PARTICLE   DENSITY '',
     *                 5X,''LAPLACIAN   SPIN   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''C U R R E N T   D E N S I T Y  '',
     *                 5X,''SPIN   CURRENT   DENSITY       '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*)')
     *             T03CBR,X03CBR,
     *             T13CBR,X13CBR,
     *             T23CBR,X23CBR,
     *             (((GR3CBR(I,J,K,1),I=0,1),K=0,1),
     *                  ((GS3CBR(I,J,K,1),I=0,1),K=0,1),J=0,1),
     *             (((GT3CBR(I,J,K,1),I=0,1),K=0,1),
     *                  ((GK3CBR(I,J,K,1),I=0,1),K=0,1),J=0,1),
     *             (((GL3CBR(I,J,K,1),I=0,1),K=0,1),
     *                  ((GP3CBR(I,J,K,1),I=0,1),K=0,1),J=0,1),
     *             (((GC3CBR(I,J,K,1),I=0,1),K=0,1),
     *                  ((GJ3CBR(I,J,K,1),I=0,1),K=0,1),J=0,1)
          END IF
C
C
          IF (I_3CBR.EQ.1) THEN
              WRITE(NFIPRI,'(
     *             1H*,5X,''GRAD2 III'',9X,
     *                ''t0III='',F7.3,5X,''x0III='',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t1III='',F7.3,5X,''x1III='',F7.3,23X,1H*,/,
     *             1H*,23X,
     *                ''t2III='',F7.3,5X,''x2III='',F7.3,23X,1H*,/,
     *                                               1H*,77X,1H*,/,
     *             1H*,5X,''P A R T I C L E   D E N S I T Y'',
     *                 5X,''S P I N   D E N S I T Y        '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''K I N E T I C   D E N S I T Y  '',
     *                 5X,''VECTOR   KINETIC   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''LAPLACIAN   PARTICLE   DENSITY '',
     *                 5X,''LAPLACIAN   SPIN   DENSITY     '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*,/,
     *             1H*,5X,''C U R R E N T   D E N S I T Y  '',
     *                 5X,''SPIN   CURRENT   DENSITY       '',5X,1H*,/,
     *              2(1H*,5X,2(F7.3,1X,F7.3,3X,F7.3,1X,F7.3,3X),1H*,/),
     *                                                   1H*,77X,1H*)')
     *             T03CBR,X03CBR,
     *             T13CBR,X13CBR,
     *             T23CBR,X23CBR,
     *             (((GR3CBR(I,J,K,2),I=0,1),K=0,1),
     *                  ((GS3CBR(I,J,K,2),I=0,1),K=0,1),J=0,1),
     *             (((GT3CBR(I,J,K,2),I=0,1),K=0,1),
     *                  ((GK3CBR(I,J,K,2),I=0,1),K=0,1),J=0,1),
     *             (((GL3CBR(I,J,K,2),I=0,1),K=0,1),
     *                  ((GP3CBR(I,J,K,2),I=0,1),K=0,1),J=0,1),
     *             (((GC3CBR(I,J,K,2),I=0,1),K=0,1),
     *                  ((GJ3CBR(I,J,K,2),I=0,1),K=0,1),J=0,1)
          END IF
C
C
          WRITE(NFIPRI,'(79(1H*),/)')
      END IF
C
C=======================================================================
C
      IF (IF_EDF.EQ.1) THEN
C
          WRITE(NFIPRI,'(79(''*''),/,''*'',77X,''*'',/,
     *             ''*'',26X,''NUCLEAR MATTER PROPERTIES'',
     *                   26X,''*'',/,''*'',77X,''*'',/,
     *                   79(''*''),/,''*'',77X,''*'',/,
     *             ''*     E = '',F8.4,''  rho0 = '',F9.5,
     *             ''   K = '',F9.4,''   Ms = '',F9.4,9X,''*'',/,
     *             ''*                   asym = '',F9.5,
     *             ''   L = '',F9.4,''   Mv = '',F9.4,9X,''*'',/,
     *             ''*'',77X,''*'',/,79(''*''),/)')
     *                  E_NM,RHO_NM,K_NM,1.0/SMASS_NM,
     *                  ASS_NM,LASS_NM,VMASS_NM
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LANDAU(LANODD,LANSCA,HBMLAN,RHOLAN,EFFLAN,
     *                  CSPI_T,CSPI_S,CSPIDT,CSPIDS,CKIS_T,CKIS_S)
C
      CHARACTER
     *          LANPRI*3
C
      COMMON
     *       /INTSKY/ T0,X0,T1,X1,T2,X2,T3,X3,W0,POWER
      COMMON
     *       /LAND_G/ X0_LAN,X1_LAN,G0_LAN,G0PLAN,G1_LAN,G1PLAN
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS ROUTINE CALCULATES SIX TIME-ODD COUPLING CONSTANTS FROM
C         THE LANDAU PARAMETERS, DEPENDING ON THE  VALUES  OF  LANODD:
C
C         IF THE RIGHT  DIGIT OF LANODD=1  ==>  CKIS_ IS RECALCULATED
C         IF THE RIGHT  DIGIT OF LANODD=0  ==>  CKIS_ IS UNCHANGED
C
C         IF THE MIDDLE DIGIT OF LANODD=1  ==>  CSPIS IS RECALCULATED
C         IF THE MIDDLE DIGIT OF LANODD=0  ==>  CSPIS IS UNCHANGED
C
C         IF THE LEFT   DIGIT OF LANODD=1  ==>  CSPI0 IS RECALCULATED
C         IF THE LEFT   DIGIT OF LANODD=0  ==>  CSPI0 IS UNCHANGED
C
C         HERE "CSPIS" DENOTES THE SATURATION-DENSITY VALUES OF "CSPI"
C         AND  "CSPI0" DENOTES THE      VACUUM        VALUES OF "CSPI"
C
C         HENCE:  CSPI_ = CSPI0  AND  CSPID*RHO**POWER = CSPIS - CSPI0
C
C=======================================================================
C         BASED ON FORMULAS (15) IN THE GT BENDER ET AL. 2002 PRC PAPER
C=======================================================================
C
      PI=4.0D0*ATAN(1.00D0)
C
      AKFLAN=(3.0D0*PI**2*RHOLAN/2)**(1.0D0/3.0D0)
      ANOLAN=2.0D0/(PI**2*HBMLAN/AKFLAN/EFFLAN)
C
      IF (MOD(LANODD,10).EQ.1) THEN
C
C=======================================================================
C         FOR THE RIGHT DIGIT OF LANODD EQUAL 1:
C         RECALCULATE CONSTANTS CKIS_ FROM THE LANDAU PARAMETERS
C         G1 AND G1'
C=======================================================================
C
          CKIS_P=-G1_LAN/(ANOLAN*AKFLAN**2)
          CKIS_M=-G1PLAN/(ANOLAN*AKFLAN**2)
C
      ELSE
C
C=======================================================================
C         FOR THE LAST DIGIT OF LANODD EQUAL 0:
C         KEEP THE PREVIUOS VALUES OF CONSTANTS CKIS_ UNCHANGED
C=======================================================================
C
          CKIS_P=CKIS_T+CKIS_S/2
          CKIS_M=CKIS_S/2
C
      END IF
C
      IF (MOD(LANODD/10,10).EQ.1) THEN
C
C=======================================================================
C         FOR THE MIDDLE DIGIT OF LANODD EQUAL 1:
C         RECALCULATE THE SPIN COUPLING CONSTANTS AT SATURATION DENSITY
C         "CSPIS" FROM THE LANDAU PARAMETERS  G0 AND G0',  BY USING THE
C         KNOWN CONSTANTS CKIS_
C=======================================================================
C
          CSPISP=G0_LAN/ANOLAN-CKIS_P*AKFLAN**2
          CSPISM=G0PLAN/ANOLAN-CKIS_M*AKFLAN**2
C
      ELSE
C
C=======================================================================
C         FOR THE MIDDLE DIGIT OF LANODD EQUAL 0:
C         KEEP THE PREVIUOS VALUES OF CONSTANTS CSPIS UNCHANGED
C=======================================================================
C
          CSPISP=CSPI_T+CSPI_S/2 +(CSPIDT+CSPIDS/2)*RHOLAN**POWER
          CSPISM=CSPI_S/2        +(CSPIDS/2       )*RHOLAN**POWER
C
      END IF
C
      IF (MOD(LANODD/100,10).EQ.1) THEN
C
C=======================================================================
C         FOR THE FIRST DIGIT OF LANODD EQUAL 1:
C         RECALCULATE THE SPIN  COUPLING  CONSTANTS  AT  ZERO  DENSITY
C         "CSPI_" BY MULTIPLYING THE CORRESPONDING COUPLING  CONSTANTS
C         AT SATURATION DENSITY "CSPIS" WITH FACTORS X0_LAN AND X1_LAN
C=======================================================================
C
          CSPI0P=CSPISP * X0_LAN
          CSPI0M=CSPISM * X1_LAN
C
      ELSE
C
C=======================================================================
C         FOR THE FIRST DIGIT OF LANODD EQUAL 0:
C         KEEP THE PREVIUOS VALUES OF CONSTANTS CSPI_ UNCHANGED
C=======================================================================
C
          CSPI0P=CSPI_T+CSPI_S/2
          CSPI0M=CSPI_S/2
C
      END IF
C
C=======================================================================
C         COME BACK TO THE TOTAL-SUM CONSTANTS
C=======================================================================
C
      CSPI0T=  CSPI0P-CSPI0M
      CSPI0S=2*CSPI0M
C
      CSPIST=  CSPISP-CSPISM
      CSPISS=2*CSPISM
C
      CKIS_T=  CKIS_P-CKIS_M
      CKIS_S=2*CKIS_M
C
C=======================================================================
C         CALCULATE THE DENSITY-DEPENDENT COUPLING CONSTANTS FROM
C         THE CORRESPONDING SATURATION-DENSITY VALUES
C=======================================================================
C
      CSPI_T=  CSPI0T
      CSPI_S=  CSPI0S
C
      CSPIDT= (CSPIST-CSPI0T)/RHOLAN**POWER
      CSPIDS= (CSPISS-CSPI0S)/RHOLAN**POWER
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,       1H*,77X,1H*,/,
     *      1H*,1X,''TIME-ODD COUPLING CONSTANTS THAT '',
     *             ''ARE DEFINED BASED ON THE '',
     *             ''LANDAU PARAMETERS'',  1X,1H*)')
C
      IF (LANSCA.NE.1) THEN
C
          WRITE(NFIPRI,'(
     *          1H*,1X,''AND ORIGINAL SKYRME COUPLING CONSTANTS'',
     *                                        38X,1H*,/,
     *                                    1H*,77X,1H*)')
C
      ELSE
C
          WRITE(NFIPRI,'(
     *          1H*,1X,''AND SCALED SKYRME COUPLING CONSTANTS'',
     *                                        40X,1H*,/,
     *                                    1H*,77X,1H*)')
C
      END IF
C
      IF (MOD(LANODD,10).EQ.1)
     *
     *    WRITE(NFIPRI,'(
     *          1H*,1X,''G1 ='',F6.3,3X,
     *                 ''G1P='',F6.3,3X,''==>'',3X,
     *                 ''CKIS_P ='',F12.6,3X,
     *                 ''CKIS_M ='',F12.6,     1X,1H*)')
     *
     *          G1_LAN,G1PLAN,CKIS_P,CKIS_M
C
      IF (MOD(LANODD/10,10).EQ.1)
     *
     *    WRITE(NFIPRI,'(
     *          1H*,1X,''G0 ='',F6.3,3X,
     *                 ''G0P='',F6.3,3X,''==>'',3X,
     *                 ''CSPISP ='',F12.6,3X,
     *                 ''CSPISM ='',F12.6,     1X,1H*)')
     *
     *          G0_LAN,G0PLAN,CSPISP,CSPISM
C
      IF (MOD(LANODD/100,10).EQ.1)
     *
     *    WRITE(NFIPRI,'(
     *          1H*,1X,''X0 ='',F6.3,3X,
     *                 ''X1 ='',F6.3,3X,''==>'',3X,
     *                 ''CSPI0P ='',F12.6,3X,
     *                 ''CSPI0M ='',F12.6,     1X,1H*)')
     *
     *          X0_LAN,X1_LAN,CSPI0P,CSPI0M
C
      WRITE(LANPRI,'(I3)') LANODD
      IF (LANPRI(1:1).EQ.' ') LANPRI(1:1)='0'
      IF (LANPRI(2:2).EQ.' ') LANPRI(2:2)='0'
C
      WRITE(NFIPRI,'(                 1H*,77X,1H*,/,
     *      1H*,1X,''PARAMETERS:  '',
     *             ''LANODD='', A3,  3X,
     *             ''HBMLAN ='',F9.5,2X,
     *             ''RHOLAN ='',F6.3,2X,
     *             ''EFFLAN ='',F6.3,     1X,1H*,/,
     *                                1H*,77X,1H*,/,
     *                                    79(1H*),/)')
     *
     *      LANPRI,HBMLAN,RHOLAN,EFFLAN
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABDEF(LAMMAX)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          ELEMNT*16
C
      DIMENSION
     *          ELEMNT(0:NDLAMB)
C
      COMPLEX
     *          ALPHAC(0:NDLAMB,-NDLAMB:+NDLAMB)
C
      COMMON
     *       /DEFORM/ ALPHAC,IREALA
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *            1H*,''  DEFORMED WOODS-SAXON RESULTS HAVE BEEN READ'',
     *                                                        32X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                          79(1H*),/,1H*,77X,1H*)')
C
      LAMMAC=MAX(2,LAMMAX)
C
      IF (IREALA.EQ.1) THEN
C
          DO LAMBDA=1,LAMMAC
C
             DO L=1,NDLAMB
                WRITE(ELEMNT(L),2)
   2            FORMAT(1X,13(1H.),2X)
             END DO
C
             DO MIU=0,LAMBDA
                WRITE(ELEMNT(MIU),3) LAMBDA,MIU,REAL(ALPHAC(LAMBDA,MIU))
   3            FORMAT(' AL(',I1,',',I1,')=',F5.3,2X)
             END DO
C
             WRITE(NFIPRI,'(1H*,1X,5A15,1X,1H*,/,
     *                    1H*,   77X,    1H*)') (ELEMNT(MIU),MIU=0,4)
C
          END DO
C
      ELSE
C
          DO LAMBDA=1,LAMMAC
C
             DO L=1,NDLAMB
                WRITE(ELEMNT(L),2)
             END DO
C
             DO MIU=0,LAMBDA
                WRITE(ELEMNT(MIU),5) LAMBDA,MIU,REAL(ALPHAC(LAMBDA,MIU))
   5            FORMAT(' RA(',I1,',',I2,')=',F6.3,1X)
             END DO
C
             WRITE(NFIPRI,'(1H*,1X,5A15,1X,1H*,/,
     *                      1H*,   77X,    1H*)') (ELEMNT(MIU),MIU=0,4)
C
             DO L=1,NDLAMB
                WRITE(ELEMNT(L),2)
             END DO
C
             DO MIU=0,LAMBDA
                WRITE(ELEMNT(MIU),6)LAMBDA,MIU,AIMAG(ALPHAC(LAMBDA,MIU))
   6            FORMAT(' IA(',I1,',',I2,')=',F6.3,1X)
             END DO
C
             WRITE(NFIPRI,'(1H*,1X,5A15,1X,1H*,/,
     *                      1H*,   77X,    1H*)') (ELEMNT(MIU),MIU=0,4)
C
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PUTREA(IPLUMI,H_REAL,H_CMPL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          H_CMPL(1:NDBASE,1:NDBASE)
      DIMENSION
     *          H_REAL(1:NDBASE,1:NDBASE)
      COMMON
     *         /DIMENS/ LDBASE
      DATA
     *          ZERO / 0.0D0 /
C
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            H_CMPL(IBRA,IKET)=H_CMPL(IBRA,IKET)
     *
     *                       + IPLUMI * CMPLX(H_REAL(IBRA,IKET),ZERO)
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PUTIMA(IPLUMI,H_IMAG,H_CMPL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          H_CMPL(1:NDBASE,1:NDBASE)
      DIMENSION
     *          H_IMAG(1:NDBASE,1:NDBASE)
      COMMON
     *         /DIMENS/ LDBASE
      DATA
     *          ZERO / 0.0D0 /
C
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            H_CMPL(IBRA,IKET)=H_CMPL(IBRA,IKET)
     *
     *                       + IPLUMI * CMPLX(ZERO,H_IMAG(IBRA,IKET))
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PUTCOM(IPLUMI,H_INPU,H_CMPL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          H_CMPL(1:NDBASE,1:NDBASE)
      COMPLEX
     *          H_INPU(1:NDBASE,1:NDBASE)
      COMMON
     *         /DIMENS/ LDBASE
C
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            H_CMPL(IBRA,IKET)=H_CMPL(IBRA,IKET)
     *
     *                       + IPLUMI * H_INPU(IBRA,IKET)
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE PUTCOI(IPLUMI,H_INPU,H_CMPL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          H_CMPL(1:NDBASE,1:NDBASE)
      COMPLEX
     *          H_INPU(1:NDBASE,1:NDBASE)
      COMPLEX
     *          UNIT_I
C
      COMMON
     *         /DIMENS/ LDBASE
C
C=======================================================================
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            H_CMPL(IBRA,IKET)=H_CMPL(IBRA,IKET)
     *
     *                       + IPLUMI * H_INPU(IBRA,IKET) * UNIT_I
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *                  ISIGNY,ISIMPY,ISIQTY,IPAHFB,MREVER,ICHARG,
     *                                       MIN_QP,IPNMIX,ITPNMX,
     *                         ITIREP,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *                  ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,IKERNE,
     *                                              ITWCEN,LTWCEN)
C
C=======================================================================
      USE hfodd_fission_rotated_qp
      USE HE_DEN
      USE PD_DEN
      USE PP_DEN
      USE HETDEN
      USE PDTDEN
      USE WAVSQU
      USE SAVRIG
      USE WAVR_L
      USE ALLWAV
      USE PNMWAV
      USE ALLQUA
      USE ALLQUZ
      USE FRAGFL
      USE BLOSAV
      USE TWCWAV
      USE TWCQUZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
#if(USE_OPENMP==1)
      USE omp_lib
#endif
      LOGICAL
     *          PRINIT,DOSYMM,DOSYME,do_symmetrize
      CHARACTER
     *          NAMEPN*8
C
      COMPLEX
     *          DENALL(NDXHRM,NDYHRM,NDZHRM,NDALLD)
C
      COMPLEX, DIMENSION(:,:,:,:), ALLOCATABLE ::
     *                             HRIGHE,HRIGDH,HRIGDD,
     *                             HLEFHE,HLEFDH,HLEFDD
      COMPLEX
     *          ARHEHE(0:NDXMAX,1:4*NDSTAT,0:NDSPIN),
     *          ARHEDH(0:NDXMAX,1:4*NDSTAT,0:NDSPIN),
     *          ARDHHE(0:NDXMAX,1:4*NDSTAT,0:NDSPIN),
     *          ARHEDD(0:NDXMAX,1:4*NDSTAT,0:NDSPIN),
     *          ARDDHE(0:NDXMAX,1:4*NDSTAT,0:NDSPIN)
      COMPLEX
     *          ALHEHE(0:NDXMAX,1:4*NDSTAT,0:NDSPIN),
     *          ALHEDH(0:NDXMAX,1:4*NDSTAT,0:NDSPIN),
     *          ALDHHE(0:NDXMAX,1:4*NDSTAT,0:NDSPIN),
     *          ALHEDD(0:NDXMAX,1:4*NDSTAT,0:NDSPIN),
     *          ALDDHE(0:NDXMAX,1:4*NDSTAT,0:NDSPIN)
      COMPLEX
     *          DEUPUP(-1:NDKART,-1:NDKART),
     *          DEDWDW(-1:NDKART,-1:NDKART),
     *          DEUPDW(-1:NDKART,-1:NDKART),
     *          DEDWUP(-1:NDKART,-1:NDKART)
      COMPLEX
     *          DLUPUP,DLDWDW,DLUPDW,DLDWUP
      COMPLEX
     *          DENAUX(-1:NDKART,-1:NDKART)
      COMPLEX
     *          DENAUY(-1:NDKART,-1:NDKART,-1:NDKART)
      COMPLEX
     *          PAUPUP(-1:NDKART,-1:NDKART),
     *          PADWDW(-1:NDKART,-1:NDKART),
     *          PAUPDW(-1:NDKART,-1:NDKART),
     *          PADWUP(-1:NDKART,-1:NDKART),
     *          PCUPUP(-1:NDKART,-1:NDKART),
     *          PCDWDW(-1:NDKART,-1:NDKART),
     *          PCUPDW(-1:NDKART,-1:NDKART),
     *          PCDWUP(-1:NDKART,-1:NDKART)
      COMPLEX
     *          PLUPUP,PLDWDW,PLUPDW,PLDWUP,
     *          CLUPUP,CLDWDW,CLUPDW,CLDWUP
      COMPLEX
     *          P(-1:NDKART,1:4*NDSTAT,0:NDSPIN),
     *          Q(-1:NDKART,1:4*NDSTAT,0:NDSPIN)
      COMPLEX
     *                  PLA(1:4*NDSTAT,0:NDSPIN),
     *                  QLA(1:4*NDSTAT,0:NDSPIN)
      COMPLEX
     *          ONEWAV,PHASPI
      COMPLEX
     *          C_ZERO,C_UNIT,UNIT_I
      COMPLEX
     *          CERMTS,CHRMTS,CDHRMT
      COMPLEX
     *          ZDOTU
      COMPLEX
     *          RMTS
      COMPLEX
     *          CHELE2,CDHLE2,CDDLE2,CHERI2,CDHRI2,CDDRI2,
     *          CHELE4,CDHLE4,CDDLE4,CHERI4,CDHRI4,CDDRI4
C
      DIMENSION
     *          MUSYME(0:NDKART)
      DIMENSION
     *          V1OCCU(1:2*NDSTAT)
C
C     -- USED IN ATDHF CALCULATION --
      COMMON
     *       /PRSING/ V_SING(1:4*NDSTAT)
      COMMON
     *       /SWSING/ I_SING
C     -- USED IN ATDHF CALCULATION --
      COMMON
     *       /FRASYM/ DOSYMM,do_symmetrize
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /T_FLAG/ IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /MIOCCU/ VMOCCU(1:4*NDSTAT)
      COMMON
     *       /CORPAR/ V_CORR(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /LIMOCC/ NOTOCC(1:2*NDSTAT,0:NDREVE),
     *       /OCCISO/ NOCISO(1:2*NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /HERCOM/ CERMTS(0:ND2MAX,1:NDGAUS,1:NDKART),
     *                CHRMTS(0:ND2MAX,1:NDGAUS,1:NDKART),
     *                CDHRMT(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /IANGLE/ ALPINI,BETINI,GAMINI
      COMMON
     *       /RANGLE/ ALPROT,BETROT,GAMROT
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /HALFBO/ IHABOX,IHABOY,IHABOZ
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
      COMMON
     *       /CTWCHE/ CHELE2(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWBL),
     *                CDHLE2(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWBL),
     *                CDDLE2(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWBL),
     *                CHERI2(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWBL),
     *                CDHRI2(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWBL),
     *                CDDRI2(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWBL),
     *                CHELE4(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWDD),
     *                CDHLE4(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWDD),
     *                CDDLE4(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWDD),
     *                CHERI4(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWDD),
     *                CDHRI4(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWDD),
     *                CDDRI4(0:ND2MAX,1:NDGAUS,1:NDKART,1:NDTWDD)
C
C=======================================================================
C
      CALL CPUTIM('DENSHF',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      IF (.NOT.ALLOCATED(SQUWAV).AND.IDEVAR.EQ.1) THEN
          ALLOCATE (SQUWAV(1:NDSTAT,NDXHRM,NDYHRM,NDZHRM),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SQUWAV','DENSHF')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(WARIGH).AND.IKERNE.EQ.0) THEN
          ALLOCATE (WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WARIGH','DENSHF')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(SARIGH).AND.ISAWAV.EQ.1) THEN
          ALLOCATE (SARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN,0:NDISOS,
     *                                                  1:NDTWCE),
     *              STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('SARIGH','DENSHF')
      END IF
C=======================================================================
C
C=======================================================================
C
C        THIS SUBROUTINE CALCULATES THE  SKYRME-FUNCTIONAL  DENSITIES
C        DEFINED AS IN THE PAPER BY ENGEL ET AL.
C                                        NUCL.PHYS. A249 (1975) 215
C
C        AND FOR IPAHFB=1 AND 2,
C        THIS SUBROUTINE CALCULATES IN ADDITION THE PAIRING DENSITIES
C        DEFINED AS IN THE PAPER BY DOBACZEWSKI ET AL.
C                                        NUCL.PHYS. A422 (1984) 103
C
C=======================================================================
C
C        CODE NAMES OF DENSITIES ARE AS FOLLOWS:
C
C                      SCALAR DENSITIES
C
C        DE_RHO = PARTICLE DENSITY ......................  ENGEL  (3.7)
C        DE_TAU = KINETIC DENSITY .......................  ENGEL  (3.8)
C        DE_LPR = LAPLACIAN OF PARTICLE DENSITY .........
C        DE_DIV = DIVERGENCE OF SPIN CURRENT TENSOR .....  ENGEL (A.17)
C        DE_DIJ = DIVERGENCE OF CURRENT .................  AS IN SADOUDI
C
C        PD_RHO = PAIR DENSITY ..........................  AS IN DE_RHO
C        PD_TAU = PAIR KINETIC DENSITY ..................  AS IN DE_RHO
C        PD_LPR = LAPLACIAN OF PAIR DENSITY .............  AS IN DE_RHO
C
C        PP_RHO = PAIR DENSITY PRIME ....................  AS IN DE_RHO
C        PP_TAU = PAIR KINETIC DENSITY PRIME ............  AS IN DE_RHO
C        PP_LPR = LAPLACIAN OF PAIR DENSITY PRIME .......  AS IN DE_RHO
C
C                      VECTOR DENSITIES
C
C        DE_SPI = SPIN DENSITY ..........................  ENGEL  (3.9)
C        DE_KIS = VECTOR KINETIC DENSITY ................  ENGEL (3.12)
C        DE_GRR = GRADIENT OF PARTICLE DENSITY ..........
C        DE_LPS = LAPLACIAN OF SPIN DENSITY .............
C        DE_ROS = ROTATION (CURL) OF SPIN DENSITY .......
C        DE_ROC = ROTATION (CURL) OF CURRENT DENSITY ....
C        DE_CUR = CURRENT DENSITY .......................  ENGEL (3.10)
C        DE_KIF = TENSOR KINETIC DENSITY ................  PERLINS (24)
C        DE_DIS = DIVERGENCE OF SPIN CURRENT ............  AS IN SADOUDI
C
C        PD_GRR = GRADIENT OF PAIR DENSITY ..............  AS IN DE_RHO
C        PD_DIS = DIVERGENCE OF PAIR SPIN CURRENT .......  AS IN SADOUDI
C
C        PP_GRR = GRADIENT OF PAIR DENSITY PRIME ........  AS IN DE_RHO
C        PP_DIS = DIVERGENCE OF PAIR SPIN CURRENT PRIME .  AS IN SADOUDI
C
C                       TENSOR DENSITIES
C
C        DE_SCU = SPIN CURRENT DENSITY...................  ENGEL (3.11)
C        DE_DES = TENSOR DERIVATIVE OF THE SPIN DENSITY..
C
C        PD_SCU = PAIR SPIN CURRENT DENSITY .............  AS IN DE_RHO
C        PP_SCU = PAIR SPIN CURRENT DENSITY PRIME .......  AS IN DE_RHO
C
C=======================================================================
C        ATTENTION: ON 12/09/2020, STARTING WITH VERSION NUMBER (2.99T),
C                   DEFINITIONS OF PAIRING "PRIME" TRANSITION  DENSITIES
C                   "PP_XXX" HAVE CHANGED. NOW THEY CORRESPOND TO  THOSE
C                   CALCULATED FOR LEFT AND RIGHT STATES EXCHANGED  WITH
C                   RESPECT  TO  THE  STANDARD  PAIRING   DENSITIES   IN
C                   "PD_XXX", AND NOT TO THE COMPLEX CONJUGATES THEREOF.
C                   THEREFORE, NOW THE COMPLEX  CONJUGATES  MUST  APPEAR
C                   EXPLICITLY WHEREVER THESE DENSITIES ARE USED,  WHICH
C                   CONFORMS TO THE STANDARDS OF PERLINSKA EQ. (41B).
C=======================================================================
C
C        ATTENTION:  FOR TIME-REVERSAL AND SIMPLEX CONSERVED,  THIS
C                    SUBROUTINE IS CALLED WITH MREVER=0. THEN, ONLY
C                    THE STATES IN THE TIME-UP BLOCK ARE CONSIDERED
C                    AND ONLY THESE STATES ARE USED TO SUM  UP  THE
C                    THE DENSITIES. AS A RESULT, THE TIME-ODD "P-H"
C                    DENSITIES ARE NON-ZERO (THE CONTRIBUTIONS FROM
C                    THE TIME-DOWN BLOCK HAVE AN OPPOSITE SIGN, AND
C                    WOULD HAVE CANCELLED THOSE OBTAINED  FROM  THE
C                    TIME-UP BLOCK). HOWEVER, THIS SUBROUTINE GIVES
C                    NON-ZERO (UNCANCELLED) VALUES AND THE USER  IS
C                    RESPONSIBLE FOR PUTTING ZEROS IN THE  TIME-ODD
C                    "P-H" DENSITIES OUTSIDE THIS ROUTINE. THIS  IS
C                    DONE IN THE  "DBLING"  SUBROUTINE, WHICH  ALSO
C                    PERFORMS THE DOUBLING OF THE  TIME-EVEN  "P-H"
C                    DENSITIES. IT ALSO PUTS ZEROS IN THE IMAGINARY
C                    PARTS OF THE "P-P" DENSITIES.
C
C=======================================================================
C
C        ATTENTION:  THIS ROUTINE CAN BE CALLED ONLY WITH ICHARG= 0 OR 1
C
C                    IN THE CASE OF IPNMIX=0, ICHARG DENOTES THE NEUTRON
C                                             AND PROTON WAVE FUNCTIONS.
C                                             NUMBERS OF WAVE  FUNCTIONS
C                                             ARE  EQUAL  LDSTAT(ICHARG)
C                    IN THE CASE OF IPNMIX=1, ICHARG DENOTES THE NEUTRON
C                                             AND PROTON  COMPONENTS  OF
C                                             WAVE  FUNCTIONS.
C                                             NUMBERS OF WAVE  FUNCTIONS
C                                             ARE IN THIS CASE STORED IN
C                                             LDSTAT(0)=LDSTAT(1)
C
C=======================================================================
C
      IF (ICHARG.NE.0.AND.ICHARG.NE.1) STOP ' WRONG ICHARG IN DENSHF'
C
C=======================================================================
C
C        ATTENTION:  THIS ROUTINE CAN BE CALLED ONLY WITH ITPNMX = 0---3
C
C                    ITPNMX = 0 DENOTES  THE  NEUTRON-NEUTRON  DENSITIES
C                    ITPNMX = 1 DENOTES  THE   PROTON-PROTON   DENSITIES
C                    ITPNMX = 2 DENOTES  THE  NEUTRON-PROTON   DENSITIES
C                    ITPNMX = 3 DENOTES  THE   PROTON-NEUTRON  DENSITIES
C
C                    ITPNMX DENOTES THE LOCATION IN WHICH THE CALCULATED
C                    DENSITIES WILL BE STORED.
C
C=======================================================================
C
      IF (ITPNMX.LT.0.OR.ITPNMX.GT.3) STOP ' WRONG ITPNMX IN DENSHF'
C
C=======================================================================
C
C        ATTENTION:  AS A SECURITY MEASURE, FOR IPNMIX=0 AND IKERNE=0
C                    THIS ROUTINE CAN ONLY BE CALLED WITH ICHARG=ITPNMX.
C
C=======================================================================
C
      IF (IPNMIX.NE.1.AND.IKERNE.EQ.0.AND.ICHARG.NE.ITPNMX)
     *    STOP ' ICHARG<>ITPNMX IN DENSHF'
C
C=======================================================================
C
C        ATTENTION:  BY DEFINITION, "ICHARG"  PERTAINS  TO  THE  ISOSPIN
C                    COMPONENT OF  THE  LEFT  WAVE  FUNCTION,  WHICH  IS
C                    DELIVERED IN ARRAY "WALEFT". DEPENDING ON THE BLOCK
C                    REQUESTED BY THE VALUE OF "ITPNMX", HERE WE  DEFINE
C                    THE VALUE OF THE ISOSPIN COMPONENT "ICHARR" OF  THE
C                    RIGHT WAVE FUNCTION.
C
C=======================================================================
C
      IF ((ITPNMX.EQ.0.OR.ITPNMX.EQ.2).AND.ICHARG.NE.0)
     *                STOP 'ICHARG=0 INCONSISTENT WITH ITPNMX IN DENSHF'
      IF ((ITPNMX.EQ.1.OR.ITPNMX.EQ.3).AND.ICHARG.NE.1)
     *                STOP 'ICHARG=1 INCONSISTENT WITH ITPNMX IN DENSHF'
C
      IF (ITPNMX.EQ.0.OR.ITPNMX.EQ.3) ICHARR=0
      IF (ITPNMX.EQ.1.OR.ITPNMX.EQ.2) ICHARR=1
C
      IF (ICHARR.NE.0.AND.ICHARR.NE.1) STOP ' WRONG ICHARR IN DENSHF'
C
C=======================================================================
C
C        AUXILIARY DENSITIES ARE CALCULATED AS FOUR-TENSOR DENSITIES:
C
C        DEUPUP = SPIN   UP-UP   COMPONENT
C        DEDWDW = SPIN DOWN-DOWN COMPONENT
C        DEUPDW = SPIN   UP-DOWN COMPONENT
C        DEDWUP = SPIN DOWN-UP   COMPONENT
C
C        PAUPUP = SPIN   UP-UP   COMPONENT
C        PADWDW = SPIN DOWN-DOWN COMPONENT
C        PAUPDW = SPIN   UP-DOWN COMPONENT
C        PADWUP = SPIN DOWN-UP   COMPONENT
C
C=======================================================================
C
C        VECTORIZATION COMMENT:
C        TO AVOID THE FIRST INDICES OF ARRAYS P, Q, DEXXYY, AND  PAXXYY,
C        (XX/YY = DW OR UP) SPANNING  4  VALUES, WHICH  WOULD  INTERFERE
C        WITH THE VECTOR-MEMORY BANK-ACCESS SYSTEM,  THESE  ARRAYS  HAVE
C        BEEN DIMENSIONED AS -1:NDKART. THEIR VALUES AT   -1   ARE DUMMY
C        AND NEVER USED.
C
C=======================================================================
C
      DO MU=0,NDKART
C
         IF (IKERNE.EQ.1) THEN
C
             MUSYME(MU)=NDKART
         ELSE
             MUSYME(MU)=MU
C
         END IF
C
      END DO
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      LREVER=1
C
C=======================================================================
C     FOR IKERNE=1 THE WAVE FUNCTIONS ARE SUPPOSED TO BE PRESENT IN THE
C     ARRAYS WARIGH AND WALEFT, AND ARE NOT CALCULATED
C=======================================================================
C
      IF (IKERNE.NE.1) THEN
C
C=======================================================================
C     COMPONENTS OF THE SINGLE-PARTICLE (FOR IPAHFB=0) OR  QUASIPARTICLE
C     (FOR IPAHFB>0) WAVE FUNCTIONS  ARE  COLLECTED  IN  THE  SPACE-SPIN
C     REPRESENTATION IN THE "WARIGH" ARRAY. ALL THESE COMPONETS HAVE THE
C     FIRST INDEX SPANNING THE HO BASIS (1:LDBASE) AND THE  THIRD  INDEX
C     SPANNING THE TWO SPIN VALUES (1:NDSPIN). DIFFERENT  COMPONETS  ARE
C     STORED CONSECUTIVELY IN THE SECOND INDEX, WHICH  SPANS  VALUES  OF
C     (1:N*NDSTAT) WITH VALUES OF "N" ADJUSTED TO THE  CURRENT  SYMMETRY
C     CONDITIONS, AND GIVEN BY:
C     N=M   (FOR IPNMIX=0) AND
C     N=2*M (FOR IPNMIX=1), WITH INTEGERS M LISTED BELOW.
C=======================================================================
C     DENOTING THE COMPONENTS BY:
C
C                   TU=TIME-UP   (SIMPLEX=+i,IREVER=0)
C                   TD=TIME-DOWN (SIMPLEX=-i,IREVER=1)
C                   QU=UPPER HFB COMPONENT  (B-ARRAYS)
C                   QD=LOWER HFB COMPONENT  (A-ARRAYS),  WE HAVE:
C
C     FOR IPAHFB=0, ISIMPY=1, MREVER=0: M=1,(TU)
C     FOR IPAHFB=0, ISIMPY=1, MREVER=1: M=2,(TU,TD)
C     FOR IPAHFB=0, ISIMPY=0, MREVER=1: M=2,(TU,TD)
C
C     FOR IPAHFB=1, ISIMPY=1, MREVER=0: M=2,(QU&TU,QD&TD)
C     FOR IPAHFB=1, ISIMPY=1, MREVER=1: M=4,(QU&TU,QU&TD,QD&TD,QD&TU)
C     FOR IPAHFB=1, ISIMPY=0, MREVER=1: M=4,(QU&TU,QU&TD,QD&TU,QD&TD)
C
      IF (ISIMPY.EQ.0.AND.MREVER.EQ.0)STOP 'ISIMPY=0,MREVER=0 IN DENSHF'
      IF (IKERNE.EQ.1.AND.MREVER.EQ.0)STOP 'IKERNE=1,MREVER=0 IN DENSHF'
C
C=======================================================================
C     ATTENTION FUTURE DEVELOPERS: WHENEVER ARRAY WARIGH IS LATER  USED,
C                                  COMMENTS  RELATED  TO  ITS  STRUCTURE
C                                  MUST BE COPIED AND TAKEN INTO ACCOUNT
C=======================================================================
C     ATTENTION: FOR LREVER=1, WHICH IS THE STANDARD DESCRIBED ABOVE,
C                              THE LOWER HFB COMPONENTS ARE STORED IN
C                              THE ORDER OF INVERSED SIMPLEXES (TIMES):
C                              - FIRST COMES SIMPLEX (TIME) DOWN
C                              - NEXT  COMES SIMPLEX (TIME) UP
C                FOR LREVER=0, WHICH IS ONLY AVAILABLE FOR MREVER=1,
C                              THE LOWER HFB COMPONENTS ARE STORED IN
C                              THE ORDER OF ORDINARY SIMPLEXES (TIMES):
C                              - FIRST COMES SIMPLEX (TIME) UP
C                              - NEXT  COMES SIMPLEX (TIME) DOWN
C=======================================================================
C        THE REST OF THE CODE  R E Q U I R E S    A N D    E X P E C T S
C            THAT  LREVER=1    M U S T  B E  H E R E   H A R D W I R E D
C=======================================================================
C     SINCE THE HFB PAIRING DENSITY CAN BE CALCULATED BY USING THE LOWER
C     HFB COMPONENT IN EITHER OF THE BLOCKS, ONE  CAN  PERFORM  ALL  THE
C     CALCULATIONS BY PUTTING IN POSITION  "3"  THE  QUASIPARTICLE  WAVE
C     FUNCTIONS IN EITHER OF THE BLOCKS, I.E.,
C
C     FOR LREVER=1
C                 3. LOWER HFB COMPONENTS IN THE     TIME-REVERSED BLOCK
C     FOR LREVER=0
C                 3. LOWER HFB COMPONENTS IN THE NON-TIME-REVERSED BLOCK
C
C     LREVER IS AN INTERNAL VARIABLE IN THIS  SUBROUTINE.  IT SHOULD NOT
C     BE CHANGED, APART FROM TEST RUNS.
C
C     ATTENTION: FOR CALCULATIONS WITH UNBROKEN TIME-REVERSAL (MREVER=0)
C                THE LOWER HFB COMPONENTS IN THE NON-TIME-REVERSED BLOCK
C                AND UPPER HFB COMPONENTS IN THE     TIME-REVERSED BLOCK
C                ARE NOT CALCULATED. THEREFORE,  FOR MREVER=0 ONE HAS TO
C                USE LREVER=1.
C=======================================================================
C     THE "WARIGH" ARRAY CORRESPONDS TO  THE "RIGHT" STATE  OF  THE  GCM
C     KERNEL, AND IS CALCULATED FROM  WAVE  FUNCTIONS  OBTAINED  IN  THE
C     CURRENT RUN OF THE CODE, WHILE THE "WALEFT" ARRAY IS AN  ANALOGOUS
C     ARRAY CALCULATED IN A PREVIOUS RUN.
C=======================================================================
C     THIS ROUTINE PERFORMS ALL OPERATIONS  OBLIVIOUS  TO  THE  FACT  OF
C     WHETHER:
C     1. FOR IPNMIX=0 THE NEUTRON OR PROTON WAVE FUNCTIONS
C     2. FOR IPNMIX=1 THE NEUTRON OR PROTON COMPONENTS OF THE WAVE FNCTS
C     ARE DELIVERED IN WAVOCC, AWAQUA, BWAQUA, AWAQUZ, AND BWAQUZ.
C=======================================================================
C     COMPARED TO THE STANDARD HFB NOTATION:
C                THE ARRAY BWAQUA CONTAINS THE HFB "B*" AMPLITUDE
C                THE ARRAY AWAQUA CONTAINS THE HFB "A*" AMPLITUDE
C     WHERE "*" DENOTES THE COMPLEX CONJUGATION. THESE MATRICES ARE JUST
C     COLUMNS OF THE EIGENVECTORS OF THE HFB MATRIX CORRESPONDING TO THE
C     OCCUPIED QUASIPARTICLE STATES  (NEGATIVE QUASIPARTICLLE ENERGIES).
C=======================================================================
C     ISPIN=1 CORRESPONDS TO THE SPIN UP
C     ISPIN=0 CORRESPONDS TO THE SPIN DOWN
C=======================================================================
C     LTOTST  -  COUNTS THE TOTAL NUMBER OF STATES
C                                              PUT INTO THE WARIGH ARRAY
C                (FOR MREVER=0 EQUALS LSTATE)
C     LSTATE  -  COUNTS THE TOTAL NUMBER OF STATES PUT INTO
C                BLOCKS 1. 2. AND 3. (SEE ABOVE) OF THE WARIGH ARRAY
C     LUPPER  -  COUNTS THE TOTAL NUMBER OF UPPER HFB COMPONENTS
C                                              PUT INTO THE WARIGH ARRAY
C                (FOR IPAHFB=0 IT EQUALS TO LSTATE, BUT MUST BE DEFINED)
C     LTIMUP  -  COUNTS THE TOTAL NUMBER OF TIME-UP STATES IN THE  UPPER
C                                HFB COMPONENT PUT INTO THE WARIGH ARRAY
C                (FOR MREVER=0 IT EQUALS TO LUPPER, BUT MUST BE DEFINED)
C=======================================================================
C
      LTOTST=0
      LSTATE=0
      LUPPER=0
      LTIMUP=0
C
C=======================================================================
C     DEFINING WAVE FUNCTIONS FOR THE TWO CENTER BASIS
C=======================================================================
C
      INDTWC=IND4HK(LTWCEN)-1
C
      IF (.NOT.ALLOCATED(WAVOCC)) THEN
          ALLOCATE (WAVOCC(1:NDBASE,1:2*NDSTAT,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WAVOCC','DENSHF')
      END IF
C
      IF (ITWCEN.EQ.2) THEN
C
          IF (IPAHFB.EQ.0) THEN
C
              DO IREVER=0,MREVER
                 DO IALLST=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
                    DO IBASE=1,LDBATW(IND4HK(LTWCEN))
                     WAVOCC(IBASE,IALLST,IREVER)=
     *               TWCOCC(IBASE+INDTWC*LDBATW(1),IALLST,IREVER,ICHARG)
                    END DO
                 END DO
              END DO
C
          ELSEIF (IPAHFB.GT.0) THEN
C
              IALLOC=0
              IF (.NOT.ALLOCATED(AWAQUZ)) THEN
                  ALLOCATE (AWAQUZ(1:NDBASE,1:2*NDSTAT,0:NDREVE)
     *                                             ,STAT=IALLOC)
                  IF (IALLOC.NE.0) CALL NOALLO('AWAQUZ','DENSHF')
              END IF
              IF (.NOT.ALLOCATED(BWAQUZ)) THEN
                  ALLOCATE (BWAQUZ(1:NDBASE,1:2*NDSTAT,0:NDREVE)
     *                                             ,STAT=IALLOC)
                  IF (IALLOC.NE.0) CALL NOALLO('BWAQUZ','DENSHF')
              END IF
C
              DO IBASE=1,LDBATW(IND4HK(LTWCEN))
C
                 BWAQUZ(IBASE,:,:)=BWATWC(IBASE+INDTWC*LDBATW(1),:,:)
C
                 AWAQUZ(IBASE,:,:)=AWATWC(IBASE+INDTWC*LDBATW(1),:,:)
C
              END DO
C
          END IF
C
      END IF
C
C=======================================================================
C
      WARIGH=C_ZERO
C
      IF (IPAHFB.LT.1) THEN
C
C=======================================================================
C              DEFINING THE WARIGH ARRAY FOR THE "NOT HFB" CASE
C              THIS INCLUDES THE CASE OF HFB SOLVED IN THE CANONICAL
C              BASIS
C=======================================================================
C
          IF (IPNMIX.NE.1) THEN
C
C=======================================================================
C              DEFINING THE WARIGH ARRAY FOR THE "NO PN-MIXING" CASE
C=======================================================================
C
              DO IREVER=0,MREVER
                 DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
                    IF (V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG)).GT.0.0
     *          .OR.IDEVAR.EQ.1.OR.IFTEMP.EQ.1) THEN
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
                        LTOTST=LTOTST+1
                        LSTATE=LSTATE+1
                        LUPPER=LUPPER+1
C
                        IF (IREVER.EQ.0) LTIMUP=LTIMUP+1
C
                        IF (LSTATE.GT.(MREVER+1)*NDSTAT)
     *
     *                      STOP ' (1) LSTATE > N*NDSTAT IN DENSHF'
C
                        IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C                       DEFINING THE WARIGH ARRAY FOR THE CONSERVED
C                       SIMPLEX
C=======================================================================
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LSTATE,ISPIN)=
     *                            WAVOCC(IBASE,
     *                            ISTATE+IREVER*NUMBSP(0,ICHARG),IREVER)
     *                           *PHASPI(IBASE,IREVER,ISPIN,1)
C
                               END DO
                            END DO
C
                        ELSE
C
C=======================================================================
C                       DEFINING THE WARIGH ARRAY FOR THE NON-CONSERVED
C                       SIMPLEX
C=======================================================================
C
                            DO IBASE=1,LDBATW(IND4HK(LTWCEN))
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LSTATE,ISPIN)=
     *                            WAVOCC(IBASE,
     *                            ISTATE+IREVER*NUMBSP(0,ICHARG),0)
     *                           *PHASPI(IBASE,0,ISPIN,IND4HK(LTWCEN))
     *
     *                           +WAVOCC(IBASE,
     *                            ISTATE+IREVER*NUMBSP(0,ICHARG),1)
     *                           *PHASPI(IBASE,1,ISPIN,IND4HK(LTWCEN))
C
                               END DO
                            END DO
C
                        END IF
C
C=======================================================================
C                       MULTIPLYING THE WAVEFUNCTIONS BY THE  OCCUPATION
C                       PROBABILTIES IN CASE THE PAIRING MATRIX ELEMENTS
C                       WILL NOT HAVE BEEN REQUESTED
C=======================================================================
C            ATTENTION: IN VERSIONS FROM (2.50R) TILL (2.56F), THE  "IF"
C                       BLOCK BELOW HAS BEEN INADVERTENTLY REMOVED. AS A
C                       RESULT, ALL THE BCS CALCULATIONS WERE CORRUPTED.
C                       THIS BUG WAS CORRECTED ON  14/12/12  IN  VERSION
C                       (2.56G).
C=======================================================================
C
                        IF (IDEVAR.NE.1) THEN
C
                            DO IBASE=1,LDBATW(IND4HK(LTWCEN))
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LSTATE,ISPIN)=
     *                            WARIGH(IBASE,LSTATE,ISPIN)
     *                           *V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))
C
                               END DO
                            END DO
C
                        ELSE
C
C=======================================================================
C                       SAVING THE OCCUPATION PROBABILTIES; LATER THE
C                       WAVE FUNCTIONS MUST BE MULTIPLIED BY THEM
C=======================================================================
C
                            V1OCCU(LSTATE)=
     *                      V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))
C
                        END IF
C
                    END IF
C
                 END DO
              END DO
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
              IF (IFTEMP.EQ.1) THEN
C
                  DO IREVER=0,MREVER
                     DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                        U1OCCU=SQRT(1.0D0
     *                 -V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))**2)
C
                        LTOTST=LTOTST+1
                        LSTATE=LSTATE+1
                        LUPPER=LUPPER+1
C
                        IF (IREVER.EQ.0) LTIMUP=LTIMUP+1
C
                        IF (LSTATE.GT.(MREVER+1)*NDSTAT)
     *
     *                      STOP ' (2) LSTATE > N*NDSTAT IN DENSHF'
C
                        IF (ISIMPY.EQ.1) THEN
C
C                            DEFINING THE WARIGH ARRAY FOR THE CONSERVED
C                            SIMPLEX
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LSTATE,ISPIN)=
     *                            WAVOCC(IBASE,
     *                            ISTATE+IREVER*NUMBSP(0,ICHARG),IREVER)
     *                                  *PHASPI(IBASE,IREVER,ISPIN,1)
C
                               END DO
                            END DO
C
                        ELSE
C
C                            DEFINING THE WARIGH ARRAY FOR THE NON-CONSERVED
C                            SIMPLEX
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LSTATE,ISPIN)=
     *
     *                            WAVOCC(IBASE,
     *                            ISTATE+IREVER*NUMBSP(0,ICHARG),0)
     *                           *PHASPI(IBASE,0,ISPIN,1)
     *
     *                           +WAVOCC(IBASE,
     *                            ISTATE+IREVER*NUMBSP(0,ICHARG),1)
     *                           *PHASPI(IBASE,1,ISPIN,1)
C
                               END DO
                            END DO
C
                        END IF
C
C                       MULTIPLYING THE WAVEFUNCTIONS BY THE  OCCUPATION
C                       PROBABILTIES IN CASE THE PAIRING MATRIX ELEMENTS
C                       WILL NOT HAVE BEEN REQUESTED
C
                        IF (IDEVAR.NE.1) THEN
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                      WARIGH(IBASE,LSTATE,ISPIN)=
     *                                WARIGH(IBASE,LSTATE,ISPIN)
     *                               *U1OCCU
C
                               END DO
                            END DO
C
                        ELSE
C
                            V1OCCU(LSTATE)=
     *                      V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))
C
                        END IF
C
                    END DO
                 END DO
C
              END IF
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
          ELSE  ! IPNMIX.EQ.1
C
C=======================================================================
C              DEFINING THE WARIGH ARRAY FOR THE "PN-MIXING" CASE
C=======================================================================
C              ATTENTION:  THE "WARIGH" ARRAY IS PRESENTLY DEFINED UP TO
C                          THE  DIMENSION  OF  4*NDSTAT,  TO  ACCOMODATE
C                          BOTH LOWER AND UPPER  HFB  MATRICES  IN  BOTH
C                          SIMPLEXES. THE SAME DIMENSION IS REQUIRED FOR
C                          THE UNPAIRED WAVE FUNCTIONS IN THE  PN-MIXING
C                          CASE. HOWEVER, ANY FUTURE  IMPLEMENTATION  OF
C                          THE HFB IN THE PN-MIXING  CASE  WILL  REQUIRE
C                          DIMENSION OF 8*NDSTAT
C=======================================================================
C
              DO IREVER=0,MREVER
                 DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
                    IF (VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                  .GT.0.0.OR.IDEVAR.EQ.1.OR.IFTEMP.EQ.1) THEN
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
                        LTOTST=LTOTST+1
                        LSTATE=LSTATE+1
                        LUPPER=LUPPER+1
C
                        IF (IREVER.EQ.0) LTIMUP=LTIMUP+1
C
                        IF (LSTATE.GT.2*(MREVER+1)*NDSTAT)
     *
     *                      STOP ' (3) LSTATE > N*NDSTAT IN DENSHF'
C
C=======================================================================
C        ATTENTION:  BETWEEN VERSIONS (2.50R) AND (2.93L),  IN  "DENSHF"
C                    ARRAY "PNMOCC" WAS USED WITH THE INCORRECT SHIFT OF
C                    THE BASIS DEFINED BY "ITPNMX" AND NOT BY  "ICHARR".
C                    THIS BUG WAS  CORRECTED ON  05/03/2020  IN  VERSION
C                    (2.93M). THE BUG WAS NOT  PRODUCING  ANY  INCORRECT
C                    RESULTS, BECAUSE THIS PART OF THE CODE  WAS  CALLED
C                    ONLY FOR IKERNE=0 AND ITPNMX=0 OR 1.
C=======================================================================
C
                        IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C                       DEFINING THE WARIGH ARRAY FOR THE CONSERVED
C                       SIMPLEX
C=======================================================================
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LSTATE,ISPIN)=
     *                            PNMOCC(IBASE+ICHARR*LDBASE,
     *                   ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),IREVER)
     *                               *PHASPI(IBASE,IREVER,ISPIN,1)
C
                               END DO
                            END DO
C
                        ELSE
C
C=======================================================================
C                       DEFINING THE WARIGH ARRAY FOR THE NON-CONSERVED
C                       SIMPLEX
C=======================================================================
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LSTATE,ISPIN)=
     *
     *                            PNMOCC(IBASE+ICHARR*LDBASE,
     *                        ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),0)
     *                               *PHASPI(IBASE,0,ISPIN,1)
     *
     *                           +PNMOCC(IBASE+ICHARR*LDBASE,
     *                        ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)),1)
     *                               *PHASPI(IBASE,1,ISPIN,1)
C
                               END DO
                            END DO
C
                        END IF
C
                    END IF ! VMOCCU(etc)
C
                 END DO    ! ISTATE
              END DO       ! IREVER
C
          END IF           ! IPNMIX.NE.1
C
      ELSE  ! IPAHFB.EQ.1
C
          IF (IPNMIX.NE.1) THEN
C
C=======================================================================
C              DEFINING THE WARIGH ARRAY FOR THE HFB CASE
C=======================================================================
C              LOOPS FOR THE UPPER COMPONENTS
C=======================================================================
C
              IF(IPRODD.EQ.1) CALL INIADD
C
              DO IREVER=0,MREVER
                 DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
                    IF (NOTOCC(ISTATE,IREVER).NE.1) THEN
C
                        LTOTST=LTOTST+1
                        LUPPER=LUPPER+1
C
                        IF (IREVER.EQ.0) LTIMUP=LTIMUP+1
C
                        IF (IPRODD.EQ.1) THEN
C
                            DO NUBLOC=1,NDBLOC
C
                               IF (IREVER.EQ.BLOLAB(ICHARG,NUBLOC)%IR
     *                        .AND.ISTATE.EQ.BLOLAB(ICHARG,NUBLOC)%N)
     *                             WLABBR(ICHARG,NUBLOC)=LTOTST
C
                            END DO
C
                        END IF
C
                        IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C                       DEFINING THE WARIGH ARRAY FOR THE CONSERVED
C                       SIMPLEX
C=======================================================================
C
                            IF (LTOTST.GT.(MREVER+1)*NDSTAT)
     *
     *                          STOP ' (4) LTOTST > N*NDSTAT IN DENSHF'
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LTOTST,ISPIN)=
     *
     *                                   BWAQUA(IBASE,ISTATE,IREVER)
     *                                  *PHASPI(IBASE,IREVER,ISPIN,1)
     *                                  *F_FLAG(ISTATE,IREVER,ICHARG)
     *                                  *V_CORR(ISTATE,IREVER)
C
                               END DO
                            END DO
C
                        ELSE
C
C=======================================================================
C                       DEFINING THE WARIGH ARRAY FOR THE NON-CONSERVED
C                       SIMPLEX
C=======================================================================
C
                            IF (LTOTST.GT.(MREVER+1)*NDSTAT)
     *
     *                          STOP ' (5) LTOTST > N*NDSTAT IN DENSHF'
C
                            DO IBASE=1,LDBATW(IND4HK(LTWCEN))
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LTOTST,ISPIN)=
     *
     *                           (BWAQUZ(IBASE,ISTATE
     *                                  +IREVER*NUMBQP(0,ICHARG),0)
     *                        *PHASPI(IBASE,0,ISPIN,IND4HK(LTWCEN))
     *
     *                           +BWAQUZ(IBASE,ISTATE
     *                                  +IREVER*NUMBQP(0,ICHARG),1)
     *                       *PHASPI(IBASE,1,ISPIN,IND4HK(LTWCEN)))
     *
     *                           *V_CORR(ISTATE,IREVER)
C
                               END DO
                            END DO
C
                        END IF
C
                    END IF
C
                 END DO             ! ISTATE
              END DO                ! IREVER
C
C=======================================================================
C              LOOPS FOR THE LOWER COMPONENT
C=======================================================================
C
              IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C             DEFINING THE WARIGH ARRAY FOR THE CONSERVED SIMPLEX
C=======================================================================
C             ATTENTION:   BELOW WE USE "1-LREVER" IN ALL  PLACES  WHICH
C                          PERTAIN TO THE QUASIPARTICLE INDICES. INDEED,
C                          THE "AWAQUA" ARRAYS HAVE  THE  BASIS  (FIRST)
C                          INDEX IN THE "LREVER" SECTOR AND  THE  QUASI-
C                          PARTICLE (SECOND)  INDEX  IN  THE  "1-LREVER"
C                          SECTOR.
C=======================================================================
C
                 IF (LREVER.EQ.0.AND.MREVER.EQ.0)
     *             STOP ' LREVER INCOMPATIBLE WITH MREVER IN DENSHF (1)'
C
                 DO IREVER=0,MREVER
C
                    JREVER=LREVER
                    IF(IREVER.EQ.1) JREVER=1-LREVER
C
                    DO ISTATE=1,NUMBQP(1-JREVER,ICHARG)
C
                       IF (NOTOCC(ISTATE,1-JREVER).NE.1) THEN
C
                          LTOTST=LTOTST+1
C
                          IF (LTOTST.GT.2*(MREVER+1)*NDSTAT)
     *
     *                         STOP ' (6) LTOTST > N*NDSTAT IN DENSHF'
C
C=======================================================================
C              TO CALCULATE THE ABNORMAL DENSITY (THE ONE IN THE RUSSIAN
C              CONVENTION = TILDED DENSITY IN EQ. (2.1B) OF THE 1984 DFT
C              PAPER), THE SPINOR OF THE SPIN BASIS  IS  TIME  REVERSED,
C              THAT IS, IT IS FLIPPED IN SPIN, COMPLEX  CONJUGATED,  AND
C              ITS  PHASE IS CHANGED (SEE NOTES IN 7-41E). DUE  TO  THIS
C              TRICK, THE FORMULAE FOR THE LOCAL DENSITIES  IN  THE  P-H
C              AND P-P CHANNELS ARE IDENTICAL  ONE  TO  ANOTHER,  EXCEPT
C              THAT THOSE  IN  THE  P-P  CHANNEL  CAN  LEAD  TO  COMPLEX
C              DENSITIES WHEN THE  TIME  REVERSAL  SYMMETRY  IS  BROKEN.
C              SINCE  THE  HO  WAVE  FUNCTIONS  ARE  REAL,  THE  COMPLEX
C              CONJUGATION ONLY AFFECTS THE PHASE FACTORS THAT TRANSFORM
C              SPINORS FROM THE SIMPLEX BASIS TO THE SPIN BASIS.
C=======================================================================
C              ATTENTION: SIGN OF THE SECOND HFB COMPONENT WAS INCORRECT
C                         UP TO THE VERSION (2.16N). AT THE  SAME  TIME,
C                         INCORRECT SIGNS HAVE BEEN CODED FOR THE MATRIX
C                         ELEMENTS OF THE PAIRING FIELDS  (SEE  COMMENTS
C                         IN "INTEGD"), AND HENCE NONE  OF  THE  RESULTS
C                         WERE  AFFECTED.  THIS  BUG  WAS  CORRECTED  ON
C                         07/04/05 IN VERSION (2.17).
C=======================================================================
C
                         DO IBASE=1,LDBASE
C
                            DO ISPIN=0,NDSPIN
                                WARIGH(IBASE,LTOTST,ISPIN)=
     *                          AWAQUA(IBASE,ISTATE,JREVER)*(2*ISPIN-1)
     *                          *CONJG(PHASPI(IBASE,JREVER,1-ISPIN,1))
     *                               *F_FLAG(ISTATE,JREVER,ICHARG)
C
                            END DO
                         END DO
C
                       END IF       ! NOTOCC(ISTATE,JREVER).NE.1
C
                    END DO          ! ISTATE
C
                    IF (IREVER.EQ.0) LSTATE=LTOTST
C
                 END DO             ! IREVER
C
              ELSE                  ! ISIMPY.EQ.1
C
C=======================================================================
C             DEFINING THE WARIGH ARRAY FOR THE NON-CONSERVED SIMPLEX
C=======================================================================
C
                  DO IREVER=0,MREVER
                     DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
                        IF (NOTOCC(ISTATE,IREVER).NE.1) THEN
C
                            LTOTST=LTOTST+1
C
                            IF (LTOTST.GT.2*(MREVER+1)*NDSTAT)
     *
     *                          STOP ' (7) LTOTST > N*NDSTAT IN DENSHF'
C
                            IF (IPRODD.EQ.1) THEN
C
                                DO NUBLOC=1,NDBLOC
C
                                  IF (IREVER.EQ.BLOLAB(ICHARG,NUBLOC)%IR
     *                           .AND.ISTATE.EQ.BLOLAB(ICHARG,NUBLOC)%N)
     *                                WLABAR(ICHARG,NUBLOC)=LTOTST
C
                                END DO
C
                            END IF
C
                            DO IBASE=1,LDBATW(IND4HK(LTWCEN))
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LTOTST,ISPIN)=
     *
     *                           (AWAQUZ(IBASE,ISTATE
     *                           +IREVER*NUMBQP(0,ICHARG),0)*(2*ISPIN-1)
     *                    *CONJG(PHASPI(IBASE,0,1-ISPIN,IND4HK(LTWCEN)))
     *
     *                           +AWAQUZ(IBASE,ISTATE
     *                           +IREVER*NUMBQP(0,ICHARG),1)*(2*ISPIN-1)
     *                   *CONJG(PHASPI(IBASE,1,1-ISPIN,IND4HK(LTWCEN))))
C
                               END DO
                            END DO
C
                        END IF
C
                     END DO         ! ISTATE
C
                     IF (IREVER.EQ.0) LSTATE=LTOTST
C
                  END DO            ! IREVER
C
C                  LSTATE=LTOTST
C
              END IF               ! ISIMPY.EQ.1
C
          ELSE                 ! IPNMIX.EQ.1
C
C=======================================================================
C              DEFINING THE WARIGH ARRAY FOR THE HFB CASE WITH
C              PROTON-NEUTRON MIXING
C=======================================================================
C              LOOPS FOR THE UPPER COMPONENTS
C=======================================================================
C
              IF(IPRODD.EQ.1) CALL INIADD
C
C=======================================================================
C             ATTENTION: FOR THE HFB CASE  WITH  PROTON-NEUTRON  MIXING,
C                        NUMBERS  OF  QUASIPARTICLES  ARE  DELIVERED IN
C                        ARRAY "NUBMQP" AT ICHARG=0.
C=======================================================================
C
              DO IREVER=0,MREVER
                 DO ISTATE=1,NUMBQP(IREVER,0)
C
                    IF (NOCISO(ISTATE,IREVER,0).NE.1) THEN
C
                        LTOTST=LTOTST+1
                        LUPPER=LUPPER+1
C
                        IF (IREVER.EQ.0) LTIMUP=LTIMUP+1
C
                        IF (IPRODD.EQ.1) THEN
C
                            DO NUBLOC=1,NDBLOC
C
                               IF (IREVER.EQ.BLOLAB(ICHARG,NUBLOC)%IR
     *                        .AND.ISTATE.EQ.BLOLAB(ICHARG,NUBLOC)%N)
     *                             WLABBR(ICHARG,NUBLOC)=LTOTST
C
                            END DO
C
                        END IF
C
                        IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C                       DEFINING THE WARIGH ARRAY FOR THE HFB CONSERVED
C                       SIMPLEX WITH PROTON-NEUTRON MIXING
C=======================================================================
C
         STOP ' ISIMPY=1 NOT YET IMPLEMENTED FOR IPNMIX=1 IN DENSHF (1)'
C
                            IF (LTOTST.GT.2*NDSTAT)
     *
     *                          STOP ' (8) LTOTST > 2*NDSTAT IN DENSHF'
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LTOTST,ISPIN)=
     *
     *                                   BWAQUA(IBASE,ISTATE,IREVER)
     *                                  *PHASPI(IBASE,IREVER,ISPIN,1)
     *                                  *F_FLAG(ISTATE,IREVER,ICHARG)
     *                                  *V_CORR(ISTATE,IREVER)
C
                               END DO
                            END DO
C
                        ELSE
C
C=======================================================================
C                       DEFINING THE WARIGH ARRAY FOR THE HFB
C                       NON-CONSERVED SIMPLEX WITH PROTON-NEUTRON MIXING
C=======================================================================
C
                            IF (LTOTST.GT.4*NDSTAT)
     *
     *                          STOP ' (9) LTOTST > 4*NDSTAT IN DENSHF'
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LTOTST,ISPIN)=
     *
     *                           (BWAQUZ(IBASE+ICHARR*LDBASE,ISTATE
     *                                  +IREVER*NUMBQP(0,ICHARG),0)
     *                                  *PHASPI(IBASE,0,ISPIN,1)
     *
     *                           +BWAQUZ(IBASE+ICHARR*LDBASE,ISTATE
     *                                  +IREVER*NUMBQP(0,ICHARG),1)
     *                                  *PHASPI(IBASE,1,ISPIN,1))
     *
     *                           *V_CORR(ISTATE,IREVER)
C
                               END DO
                            END DO
C
                        END IF
C
                    END IF
C
                 END DO             ! ISTATE
              END DO                ! IREVER
C
C=======================================================================
C              LOOPS FOR THE LOWER COMPONENT
C=======================================================================
C
              IF (ISIMPY.EQ.1) THEN
C
C=======================================================================
C             DEFINING THE WARIGH ARRAY FOR THE HFB CONSERVED SIMPLEX
C             WITH PROTON-NEUTRON MIXING
C=======================================================================
C             ATTENTION:   BELOW WE USE "1-LREVER" IN ALL  PLACES  WHICH
C                          PERTAIN TO THE QUASIPARTICLE INDICES. INDEED,
C                          THE "AWAQUA" ARRAYS HAVE  THE  BASIS  (FIRST)
C                          INDEX IN THE "LREVER" SECTOR AND  THE  QUASI-
C                          PARTICLE (SECOND)  INDEX  IN  THE  "1-LREVER"
C                          SECTOR.
C=======================================================================
C
         STOP ' ISIMPY=1 NOT YET IMPLEMENTED FOR IPNMIX=1 IN DENSHF (2)'
C
                 IF (LREVER.EQ.0.AND.MREVER.EQ.0)
     *             STOP ' LREVER INCOMPATIBLE WITH MREVER IN DENSHF (2)'
C
                 DO IREVER=0,MREVER
C
                    JREVER=LREVER
                    IF(IREVER.EQ.1) JREVER=1-LREVER
C
C=======================================================================
C             ATTENTION: FOR THE HFB CASE  WITH  PROTON-NEUTRON  MIXING,
C                        NUMBERS  OF  QUASIPARTICLES  ARE  DELIVERED IN
C                        ARRAY "NUBMQP" AT ICHARG=0.
C=======================================================================
C
                    DO ISTATE=1,NUMBQP(1-JREVER,0)
C
                       IF (NOCISO(ISTATE,1-JREVER,0).NE.1) THEN
C
                           LTOTST=LTOTST+1
C
                           IF (LTOTST.GT.4*NDSTAT)
     *
     *                         STOP ' (10) LTOTST > 4*NDSTAT IN DENSHF'
C
C=======================================================================
C              TO CALCULATE THE ABNORMAL DENSITY (THE ONE IN  THE  BREVE
C              REPRESENTATION, SEE EQ. (2B)  OF  THE  PERLINSKA  PAPER),
C              FOR PROTON-NEUTRON MIXING THE SPINOR OF THE  SPIN-ISOSPIN
C              BASIS IS TIME-  AND  ISOSPIN-REVERSED,  THAT  IS,  IT  IS
C              FLIPPED IN SPIN AND IN ISOSPIN AND ITS PHASE IS  CHANGED,
C              SEE COMMENTS RELATED TO THE NO P-N MIXING CASE ABOVE.
C=======================================================================
C
                           DO IBASE=1,LDBASE
                              DO ISPIN=0,NDSPIN
                                  WARIGH(IBASE,LTOTST,ISPIN)=
     *                            AWAQUA(IBASE+(1-ICHARR)*LDBASE,
     *                                   ISTATE,JREVER)*(2*ISPIN-1)
     *                                                 *(2*ICHARR-1)
     *                        *CONJG(PHASPI(IBASE,JREVER,1-ISPIN,1))
     *                                 *F_FLAG(ISTATE,JREVER,ICHARR)
C
                              END DO
                           END DO
C
                       END IF
C
                    END DO          ! ISTATE
C
                    IF (IREVER.EQ.0) LSTATE=LTOTST
C
                 END DO             ! IREVER
C
              ELSE                  ! ISIMPY.NE.1
C
C=======================================================================
C             DEFINING THE WARIGH ARRAY FOR THE HFB NON-CONSERVED
C             SIMPLEX WITH PROTON-NEUTRON MIXING
C=======================================================================
C             ATTENTION: FOR THE HFB CASE  WITH  PROTON-NEUTRON  MIXING,
C                        NUMBERS  OF  QUASIPARTICLES  ARE  DELIVERED IN
C                        ARRAY "NUBMQP" AT ICHARG=0.
C=======================================================================
C
                  DO IREVER=0,MREVER
                     DO ISTATE=1,NUMBQP(IREVER,0)
C
                        IF (NOCISO(ISTATE,IREVER,0).NE.1) THEN
C
                            LTOTST=LTOTST+1
C
                            IF (LTOTST.GT.4*NDSTAT)
     *
     *                          STOP ' (11) LTOTST > 4*NDSTAT IN DENSHF'
C
                            IF (IPRODD.EQ.1) THEN
C
                                DO NUBLOC=1,NDBLOC
C
                                  IF (IREVER.EQ.BLOLAB(ICHARG,NUBLOC)%IR
     *                           .AND.ISTATE.EQ.BLOLAB(ICHARG,NUBLOC)%N)
     *                                WLABAR(ICHARG,NUBLOC)=LTOTST
C
                                END DO
C
                            END IF
C
                            DO IBASE=1,LDBASE
                               DO ISPIN=0,NDSPIN
C
                                  WARIGH(IBASE,LTOTST,ISPIN)=
     *
     *                           (AWAQUZ(IBASE+(1-ICHARR)*LDBASE,ISTATE
     *                           +IREVER*NUMBQP(0,ICHARG),0)
     *                                        *(2*ISPIN-1)*(2*ICHARR-1)
     *                                *CONJG(PHASPI(IBASE,0,1-ISPIN,1))
     *
     *                           +AWAQUZ(IBASE+(1-ICHARR)*LDBASE,ISTATE
     *                           +IREVER*NUMBQP(0,ICHARG),1)
     *                                         *(2*ISPIN-1)*(2*ICHARR-1)
     *                                *CONJG(PHASPI(IBASE,1,1-ISPIN,1)))
C
                               END DO
                            END DO
C
                        END IF
C
                     END DO         ! ISTATE
C
                     IF (IREVER.EQ.0) LSTATE=LTOTST
C
                  END DO            ! IREVER
C
C                  LSTATE=LTOTST
C
              END IF               ! ISIMPY.EQ.1
C
          END IF               ! IPNMIX.NE.1
C
      END IF               ! IPAHFB.NE.1
C
C=======================================================================
C          SAVING THE NUMBERS OF STATES STORED.
C=======================================================================
C
      LDTOTS(ICHARR)=LTOTST
      LDSTAT(ICHARR)=LSTATE
      LDUPPE(ICHARR)=LUPPER
      LDTIMU(ICHARR)=LTIMUP
C
C=======================================================================
C          HERE WE SAVE THE WAVE FUNCTIONS FOR FUTURE ANGULAR MOMENTUM
C          PROJECTION.
C          ATTENTION: FOR IDEVAR=1, INCORRECT WAVE FUNCTIONS WOULD  BE
C                     SAVED
C=======================================================================
C
      IF (ISAWAV.EQ.1) THEN
C
          SARIGH(:,:,:,ICHARR,IND4HK(LTWCEN))=WARIGH(:,:,:)
C
      END IF
C
C=======================================================================
C         ATTENTION: IN THE VERSIONS OF THE CODE EARLIER  THAN  2.31F,
C                    VALUES OF PARAMETERS INIINV, INIKAR,  AND  INIROT
C                    WERE NOT  CHECKED  AGAINST  CONSERVED  SYMMETRIES
C                    SO AS TO ENSURE THAT A  GIVEN  D2H-TRANSFORMATION
C                    OR ROTATION IS PERFORMED ONLY WHEN IT  IS  BROKEN
C                    (SEE THE RELEVANT TESTS PERFORMED NOW IN TESDAT).
C                    ALTHOUGH THIS WAS NOT REALLY A BUG, THE CODE  WAS
C                    ALLOWED TO RUN IN CONDITIONS WHERE  THE  SPECIFIC
C                    TRANSFORMATIONS COULD NOT BE PROPERLY  PERFORMED.
C                    THE REQUIRED TESTS WERE ADDED  IN  VERSION  2.31F
C                    ON 10/09/2007
C=======================================================================
C          HERE WE D2H-TRANSFORM THE "RIGHT" WAVE FUNCTIONS:
C=======================================================================
C
      IF ((INIINV.GE.1.OR.INIKAR.GE.1).AND.ITERUN.EQ.1) THEN
C
          CALL INVWAV(LSTATE,INIINV,INIKAR,WARIGH)
C
      END IF
C
C=======================================================================
C          HERE WE ROTATE THE "RIGHT" WAVE FUNCTIONS:
C=======================================================================
C
      IF (INIROT.EQ.1.AND.ITERUN.EQ.1) THEN
C
          ALPROT=ALPINI
          BETROT=BETINI
          GAMROT=GAMINI
C
          CALL ROTWAV(LSTATE,WARIGH)
C
      END IF
C
C=======================================================================
C     HERE WE ARRIVE WITH THE WAVE FUNCTIONS THAT ARE ALREADY PRESENT IN
C     THE WARIGH AND WALEFT MATRICES
C=======================================================================
C
      END IF ! end if IKERNE.NE.1
C
      LTOTST=LDTOTS(ICHARG)
      LSTATE=LDSTAT(ICHARG)
      LUPPER=LDUPPE(ICHARG)
      LTIMUP=LDTIMU(ICHARG)

C
C=======================================================================
C          BEGINNING THE CALCULATION OF SINGLE-PARTICLE (FOR IPAHFB=0,2)
C                                    OR QUASIPARTICLE   (FOR IPAHFB=1)
C          WAVE FUNCTIONS IN THE SPACE REPRESENTATION
C=======================================================================
C          SYMMETRIZATION OF DENSITIES IS PERFORMED ONLY FOR THE MOST
C          STANDARD SKYRME CALCULATIONS
C=======================================================================
C
      DOSYME=IPNMIX.NE.1.AND.IKERNE.NE.1.AND.
     * .NOT.(ISYMDE.EQ.1.AND.PRINIT).AND.DOSYMM.AND.do_symmetrize
C
C=======================================================================
C          ONLY HALF OF THE BOX IN Z DIRECTION TAKEN FOR ISIMTZ=1 OR
C          ISIGNY=1 OR ISIQTY=1
C=======================================================================
C
                                                         IHABOZ=2
      IF ((ISIMTZ.NE.1.AND.ISIGNY.NE.1.AND.ISIQTY.NE.1)
     *                                .OR.(.NOT.DOSYME)) IHABOZ=1
C
C=======================================================================
C        ONLY HALF OF THE BOX IN Y DIRECTION TAKEN FOR ISIMPY=1
C                                               OR FOR JSIMTY=1
C=======================================================================
C
                                                         IHABOY=2
      IF ((ISIMPY.NE.1.AND.JSIMTY.NE.1)
     *                                .OR.(.NOT.DOSYME)) IHABOY=1
C
C=======================================================================
C           ONLY HALF OF THE BOX IN X DIRECTION TAKEN FOR ISIMTX=1
C=======================================================================
C
                                                         IHABOX=2
      IF (ISIMTX.NE.1
     *                                .OR.(.NOT.DOSYME)) IHABOX=1
C
C=======================================================================
C          LOOP OVER GAUSS-HERMITE POINTS OF Z-INTEGRATION
C=======================================================================
C
      PLA(:,:)=C_ZERO
      QLA(:,:)=C_ZERO
      P(:,:,:)=C_ZERO
      Q(:,:,:)=C_ZERO
C
C=======================================================================
C     COMMENT ABOUT MULTI-THREADING - THE  PARALLELIZATION BELOW SEEMS
C     TO BE THE FASTEST. HOWEVER, IT IT ALSO THE ONE THAT REQUIRES THE
C     LARGEST AMOUNT OF STACK SIZE (MEMORY PER  THREAD) BECAUSE OF THE
C     ARRAYS HRIGHE, ETC. FOR  LARGE  BASES  AND/OR  ANGULAR  MOMENTUM
C     CALCULATIONS, IT  MAY BE NECESSARY TO CHANGE THE PARALLELIZATION
C     SCHEME SO THAT MULTITHREADING TAKES PLACE  (I)  FIRST WITHIN THE
C     LOOP OVER NX (II) THEN ALSO WITHIN THE LOOP OVER IY
C=======================================================================
C
      I_FAIL=0
C
      IF (.NOT.ALLOCATED(HRIGHE)) THEN
C
          ALLOCATE(HRIGHE(0:NDXMAX,0:NDYMAX,1:4*NDSTAT,0:NDSPIN),
     *                                              STAT=I_FAIL)
          IF (I_FAIL.NE.0) THEN
              WRITE(6,'("Error in Allocating HRIGHE - DENSHF")')
              STOP 'Error in Allocating HRIGHE'
          END IF
C
          ALLOCATE(HRIGDH(0:NDXMAX,0:NDYMAX,1:4*NDSTAT,0:NDSPIN),
     *                                              STAT=I_FAIL)
          IF (I_FAIL.NE.0) THEN
              WRITE(6,'("Error in Allocating HRIGDH - DENSHF")')
              STOP 'Error in Allocating HRIGDH'
          END IF
C
          ALLOCATE(HRIGDD(0:NDXMAX,0:NDYMAX,1:4*NDSTAT,0:NDSPIN),
     *                                              STAT=I_FAIL)
          IF (I_FAIL.NE.0) THEN
              WRITE(6,'("Error in Allocating HRIGDD - DENSHF")')
              STOP 'Error in Allocating HRIGDD'
          END IF
C
          IF (IKERNE.EQ.1) THEN
C
              ALLOCATE(HLEFHE(0:NDXMAX,0:NDYMAX,1:4*NDSTAT,0:NDSPIN),
     *                                                  STAT=I_FAIL)
              IF (I_FAIL.NE.0) THEN
                  WRITE(6,'("Error in Allocating HLEFHE - DENSHF")')
                  STOP 'Error in Allocating HLEFHE'
              END IF
C
              ALLOCATE(HLEFDH(0:NDXMAX,0:NDYMAX,1:4*NDSTAT,0:NDSPIN),
     *                                                  STAT=I_FAIL)
              IF (I_FAIL.NE.0) THEN
                  WRITE(6,'("Error in Allocating HLEFDH - DENSHF")')
                  STOP 'Error in Allocating HLEFDH'
              END IF
C
              ALLOCATE(HLEFDD(0:NDXMAX,0:NDYMAX,1:4*NDSTAT,0:NDSPIN),
     *                                                  STAT=I_FAIL)
              IF (I_FAIL.NE.0) THEN
                  WRITE(6,'("Error in Allocating HLEFDD - DENSHF")')
                  STOP 'Error in Allocating HLEFDD'
              END IF
C
          END IF ! end if IKERNE
C
      END IF ! end if ALLOCATED
C
      DO IZ=1,NZHERM/IHABOZ
C
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SCHEDULE(DYNAMIC)
!$OMP& SHARED(NXMAXV,LTOTST,HRIGHE,HRIGDH,HRIGDD,HLEFHE,HLEFDH,HLEFDD,
!$OMP&        LYOFXV,LZOXYV,C_ZERO,IKERNE,INDICE,
!$OMP&        WARIGH,WALEFT,IZ,
!$OMP&        LTWCEN,ITWCEN,CHERI4,CDHRI4,CDDRI4,CHELE4,CDHLE4,CDDLE4,
!$OMP&        IND4HK,IND4HL)
!$OMP& PRIVATE(NX,NY,NZ,ISPIN,IBASE,ISTATE,ONEWAV,RMTS,LAYOFX_1,
!$OMP&         LAZOXY_1)
!$OMP& FIRSTPRIVATE(CERMTS,CHRMTS,CDHRMT)
C
         DO ISTATE=1,LTOTST
            DO ISPIN=0,NDSPIN
C
               IF (ITWCEN.EQ.2) THEN
C
                   CERMTS(:,:,:)=CHERI4(:,:,:,LTWCEN)
                   CHRMTS(:,:,:)=CDHRI4(:,:,:,LTWCEN)
                   CDHRMT(:,:,:)=CDDRI4(:,:,:,LTWCEN)
C
               END IF
C
               DO NX=0,NXMAXV(IND4HL(LTWCEN))
                  LAYOFX_1=LYOFXV(NX,IND4HL(LTWCEN))
                  DO NY=0,LAYOFX_1
C
                     ONEWAV=C_ZERO
                     LAZOXY_1=LZOXYV(NX,NY,IND4HL(LTWCEN))
C
                     DO NZ = 0,LAZOXY_1
                       IBASE = INDICE(NX,NY,NZ,IND4HL(LTWCEN))
                       RMTS = CERMTS(NZ,IZ,3)
                       ONEWAV=ONEWAV+WARIGH(IBASE,ISTATE,ISPIN)*RMTS
                     END DO
                     HRIGHE(NX,NY,ISTATE,ISPIN)=ONEWAV
C
                     ONEWAV=C_ZERO
                     DO NZ = 0,LAZOXY_1
                       IBASE = INDICE(NX,NY,NZ,IND4HL(LTWCEN))
                       RMTS = CHRMTS(NZ,IZ,3)
                       ONEWAV=ONEWAV+WARIGH(IBASE,ISTATE,ISPIN)*RMTS
                     END DO
                     HRIGDH(NX,NY,ISTATE,ISPIN)=ONEWAV
C
                     ONEWAV=C_ZERO
                     DO NZ = 0,LAZOXY_1
                       IBASE = INDICE(NX,NY,NZ,IND4HL(LTWCEN))
                       RMTS = CDHRMT(NZ,IZ,3)
                       ONEWAV=ONEWAV+WARIGH(IBASE,ISTATE,ISPIN)*RMTS
                     END DO
                     HRIGDD(NX,NY,ISTATE,ISPIN)=ONEWAV
C
                  END DO !NY
               END DO !NX
C
               IF (IKERNE.EQ.1) THEN
C
                   IF (ITWCEN.EQ.2) THEN
C
                       CERMTS(:,:,:)=CHELE4(:,:,:,LTWCEN)
                       CHRMTS(:,:,:)=CDHLE4(:,:,:,LTWCEN)
                       CDHRMT(:,:,:)=CDDLE4(:,:,:,LTWCEN)
C
                   END IF
C
                   DO NX=0,NXMAXV(IND4HK(LTWCEN))
                      LAYOFX_1=LYOFXV(NX,IND4HK(LTWCEN))
                      DO NY=0,LAYOFX_1
C
                        ONEWAV=C_ZERO
                        LAZOXY_1=LZOXYV(NX,NY,IND4HK(LTWCEN))
                        DO NZ = 0,LAZOXY_1
                           IBASE = INDICE(NX,NY,NZ,IND4HK(LTWCEN))
                           RMTS = CERMTS(NZ,IZ,3)
                           ONEWAV=ONEWAV+WALEFT(IBASE,ISTATE,ISPIN)*RMTS
                        END DO
                        HLEFHE(NX,NY,ISTATE,ISPIN)=ONEWAV
C
                        ONEWAV=C_ZERO
                        DO NZ = 0,LAZOXY_1
                           IBASE = INDICE(NX,NY,NZ,IND4HK(LTWCEN))
                           RMTS = CHRMTS(NZ,IZ,3)
                           ONEWAV=ONEWAV+WALEFT(IBASE,ISTATE,ISPIN)*RMTS
                        END DO
                        HLEFDH(NX,NY,ISTATE,ISPIN)=ONEWAV
C
                        ONEWAV=C_ZERO
                        DO NZ = 0,LAZOXY_1
                           IBASE = INDICE(NX,NY,NZ,IND4HK(LTWCEN))
                           RMTS = CDHRMT(NZ,IZ,3)
                           ONEWAV=ONEWAV+WALEFT(IBASE,ISTATE,ISPIN)*RMTS
                        END DO
                        HLEFDD(NX,NY,ISTATE,ISPIN)=ONEWAV
C
                      END DO !NY
                   END DO !NX
C
               END IF
C
            END DO !ISPIN
         END DO !ISTATE
C
!$OMP END PARALLEL DO
C
C=======================================================================
C        LOOP OVER GAUSS-HERMITE POINTS OF Y-INTEGRATION
C=======================================================================
C
!$OMP PARALLEL
!$OMP& DEFAULT(NONE)
!$OMP& SHARED(NXHERM,NYHERM,HRIGHE,HRIGDH,HRIGDD,HLEFHE,HLEFDH,HLEFDD,
!$OMP&        IHABOX,IHABOY,NXMAXV,LTOTST,LYOFXV,LZOXYV,C_UNIT,C_ZERO,
!$OMP&        IDEVAR,IPAHFB,IKERNE,V1OCCU,SQUWAV,
!$OMP&        IFTEMP,LUPPER,FERMFN,MUSYME,LREVER,ISIMPY,UNIT_I,LTIMUP,
!$OMP&        DE_RHO,DE_TAU,DE_LPR,DE_DIV,DE_SPI,DE_KIS,DE_LPS,DE_GRR,
!$OMP&        DE_CUR,DE_DIJ,DE_DIS,PD_DIS,PP_DIS,ZERO,
!$OMP&        DE_KIF,DE_ROS,DE_ROC,DE_SCU,DE_DES,PD_RHO,PP_RHO,PD_TAU,
!$OMP&        PP_TAU,PD_LPR,PP_LPR,PD_GRR,PP_GRR,PD_SCU,PP_SCU,ITPNMX,
!$OMP&        LSTATE,ITIREP,MREVER,IZ,ICHARG,
!$OMP&        CHERI4,CDHRI4,CDDRI4,CHELE4,CDHLE4,CDDLE4,IND4HK,IND4HL,
!$OMP&        ITWCEN,LTWCEN,I_SING,V_SING,IGRAIN)
!$OMP& PRIVATE(IX,IY,NX,ISPIN,IBASE,ISTATE,MU,NU,Q,QLA,P,PLA,K,L,
!$OMP&         ARHEHE,ARHEDH,ARDHHE,ARHEDD,ARDDHE,ALHEHE,ALHEDH,ALDHHE,
!$OMP&         ALHEDD,ALDDHE,JSTATE,U1OCCU,DLUPUP,DLDWDW,DLUPDW,DLDWUP,
!$OMP&         DEUPUP,DEDWDW,DEUPDW,DEDWUP,DENAUX,LOFSET,PAUPUP,PADWDW,
!$OMP&         PAUPDW,PADWUP,PCUPUP,PCDWDW,PCUPDW,PCDWUP,PLUPUP,PLDWDW,
!$OMP&         PLUPDW,PLDWUP,CLUPUP,CLDWDW,CLUPDW,CLDWUP,SIMFAC,LOFTRV,
!$OMP&         LUPTRV,num_threads,LAYOFX_1,DENAUY)
!$OMP& FIRSTPRIVATE(CERMTS,CHRMTS,CDHRMT)
!$OMP DO
!$OMP& SCHEDULE(STATIC)
C
         DO IY=1,NYHERM/IHABOY
C
            DO ISPIN=0,NDSPIN
               DO ISTATE=1,LTOTST
C
                  IF (ITWCEN.EQ.2) THEN
C
                      CERMTS(:,:,:)=CHERI4(:,:,:,LTWCEN)
                      CHRMTS(:,:,:)=CDHRI4(:,:,:,LTWCEN)
                      CDHRMT(:,:,:)=CDDRI4(:,:,:,LTWCEN)
C
                  END IF
C
                  DO NX=0,NXMAXV(IND4HL(LTWCEN))
C
                     LAYOFX_1 = LYOFXV(NX,IND4HL(LTWCEN)) + 1
C
                     ARHEHE(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                      HRIGHE(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                      CERMTS(0,IY,2),1)
C
                     ARHEDH(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                      HRIGDH(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                      CERMTS(0,IY,2),1)
C
                     ARDHHE(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                      HRIGHE(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                      CHRMTS(0,IY,2),1)
C
                     ARHEDD(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                      HRIGDD(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                      CERMTS(0,IY,2),1)
C
                     ARDDHE(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                      HRIGHE(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                      CDHRMT(0,IY,2),1)
C
                  END DO ! end loop NX
C
                  IF (IKERNE.EQ.1) THEN
C
                      IF (ITWCEN.EQ.2) THEN
C
                          CERMTS(:,:,:)=CHELE4(:,:,:,LTWCEN)
                          CHRMTS(:,:,:)=CDHLE4(:,:,:,LTWCEN)
                          CDHRMT(:,:,:)=CDDLE4(:,:,:,LTWCEN)
C
                      END IF
C
                      DO NX=0,NXMAXV(IND4HK(LTWCEN))
C
                         LAYOFX_1 = LYOFXV(NX,IND4HK(LTWCEN)) + 1
C
                         ALHEHE(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                       HLEFHE(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                       CERMTS(0,IY,2),1)
C
                         ALHEDH(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                       HLEFDH(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                       CERMTS(0,IY,2),1)
C
                         ALDHHE(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                       HLEFHE(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                       CHRMTS(0,IY,2),1)
C
                         ALHEDD(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                       HLEFDD(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                       CERMTS(0,IY,2),1)
C
                         ALDDHE(NX,ISTATE,ISPIN)=ZDOTU(LAYOFX_1,
     *                       HLEFHE(NX,0,ISTATE,ISPIN),NDXMAX+1,
     *                       CDHRMT(0,IY,2),1)
C
                      END DO ! end loop NX
C
                  END IF
C
               END DO ! end loop ISTATE
            END DO ! end loop ISPIN
C
C=======================================================================
C           LOOP OVER GAUSS-HERMITE POINTS OF X-INTEGRATION
C=======================================================================
C
            DO IX=1,NXHERM/IHABOX
C
               DO ISPIN=0,NDSPIN
C
                  IF (ITWCEN.EQ.2) THEN
C
                      CERMTS(:,:,:)=CHERI4(:,:,:,LTWCEN)
                      CHRMTS(:,:,:)=CDHRI4(:,:,:,LTWCEN)
                      CDHRMT(:,:,:)=CDDRI4(:,:,:,LTWCEN)
C
                  END IF
C
                  CALL ZGEMV('T',NXMAXV(IND4HL(LTWCEN))+1,LTOTST,C_UNIT,
     *                           ARHEHE(0,1,ISPIN),
     *                           NDXMAX+1,CERMTS(0,IX,1),1,C_ZERO,
     *                           P(0,1,ISPIN), NDKART+2)
                  CALL ZGEMV('T',NXMAXV(IND4HL(LTWCEN))+1,LTOTST,C_UNIT,
     *                           ARHEHE(0,1,ISPIN),
     *                           NDXMAX+1,CHRMTS(0,IX,1),1,C_ZERO,
     *                           P(1,1,ISPIN), NDKART+2)
                  CALL ZGEMV('T',NXMAXV(IND4HL(LTWCEN))+1,LTOTST,C_UNIT,
     *                           ARDHHE(0,1,ISPIN),
     *                           NDXMAX+1,CERMTS(0,IX,1),1,C_ZERO,
     *                           P(2,1,ISPIN), NDKART+2)
                  CALL ZGEMV('T',NXMAXV(IND4HL(LTWCEN))+1,LTOTST,C_UNIT,
     *                           ARHEDH(0,1,ISPIN),
     *                           NDXMAX+1,CERMTS(0,IX,1),1,C_ZERO,
     *                           P(3,1,ISPIN), NDKART+2)
C
                  CALL ZGEMV('T',NXMAXV(IND4HL(LTWCEN))+1,LTOTST,C_UNIT,
     *                           ARHEHE(0,1,ISPIN),
     *                           NDXMAX+1,CDHRMT(0,IX,1),1,C_ZERO,
     *                           PLA(1,ISPIN), 1)
                  CALL ZGEMV('T',NXMAXV(IND4HL(LTWCEN))+1,LTOTST,C_UNIT,
     *                           ARDDHE(0,1,ISPIN),
     *                           NDXMAX+1,CERMTS(0,IX,1),1,C_UNIT,
     *                           PLA(1,ISPIN), 1)
                  CALL ZGEMV('T',NXMAXV(IND4HL(LTWCEN))+1,LTOTST,C_UNIT,
     *                           ARHEDD(0,1,ISPIN),
     *                           NDXMAX+1,CERMTS(0,IX,1),1,C_UNIT,
     *                           PLA(1,ISPIN), 1)
C
                  IF (IKERNE.EQ.1) THEN
C
                      IF (ITWCEN.EQ.2) THEN
C
                          CERMTS(:,:,:)=CHELE4(:,:,:,LTWCEN)
                          CHRMTS(:,:,:)=CDHLE4(:,:,:,LTWCEN)
                          CDHRMT(:,:,:)=CDDLE4(:,:,:,LTWCEN)
C
                      END IF
C
                      CALL ZGEMV('T',NXMAXV(IND4HK(LTWCEN))+1,LTOTST,
     *                               C_UNIT,ALHEHE(0,1,ISPIN),
     *                               NDXMAX+1,CERMTS(0,IX,1),1,C_ZERO,
     *                               Q(0,1,ISPIN), NDKART+2)
                      CALL ZGEMV('T',NXMAXV(IND4HK(LTWCEN))+1,LTOTST,
     *                               C_UNIT,ALHEHE(0,1,ISPIN),
     *                               NDXMAX+1,CHRMTS(0,IX,1),1,C_ZERO,
     *                               Q(1,1,ISPIN), NDKART+2)
                      CALL ZGEMV('T',NXMAXV(IND4HK(LTWCEN))+1,LTOTST,
     *                               C_UNIT,ALDHHE(0,1,ISPIN),
     *                               NDXMAX+1,CERMTS(0,IX,1),1,C_ZERO,
     *                               Q(2,1,ISPIN), NDKART+2)
                      CALL ZGEMV('T',NXMAXV(IND4HK(LTWCEN))+1,LTOTST,
     *                               C_UNIT,ALHEDH(0,1,ISPIN),
     *                               NDXMAX+1,CERMTS(0,IX,1),1,C_ZERO,
     *                               Q(3,1,ISPIN), NDKART+2)
C
                      CALL ZGEMV('T',NXMAXV(IND4HK(LTWCEN))+1,LTOTST,
     *                               C_UNIT,ALHEHE(0,1,ISPIN),
     *                               NDXMAX+1,CDHRMT(0,IX,1),1,C_ZERO,
     *                               QLA(1,ISPIN), 1)
                      CALL ZGEMV('T',NXMAXV(IND4HK(LTWCEN))+1,LTOTST,
     *                               C_UNIT,ALDDHE(0,1,ISPIN),
     *                               NDXMAX+1,CERMTS(0,IX,1),1,C_UNIT,
     *                               QLA(1,ISPIN), 1)
                      CALL ZGEMV('T',NXMAXV(IND4HK(LTWCEN))+1,LTOTST,
     *                               C_UNIT,ALHEDD(0,1,ISPIN),
     *                               NDXMAX+1,CERMTS(0,IX,1),1,C_UNIT,
     *                               QLA(1,ISPIN), 1)
C
                  END IF ! end if IKERNE
C
               END DO ! end loop ISPIN
C
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS 2.10A AND 2.99U ARRAYS "P" AND "Q"
C                    WERE EXCHANGED WITH RESPECT TO (I) WHAT  THEY  WERE
C                    SUPPOSED TO CONTAIN, (II) WHAT WAS SPECIFIED IN THE
C                    COMMENTS, AND (III) WHAT WAS IMPLIED  BY  NAMES  OF
C                    ARRAYS WARIGH AND WALEFT. THE INTENTION WAS TO FEED
C                    INTO DENSHF THE WAVE FUNCTION OF THE RIGHT AND LEFT
C                    GCM STATES THROUGH WARIGH AND WALEFT, RESPECTIVELY.
C                    FOR THE SINGLE-REFERENCE  APPLICATIONS  (IKERNE=0),
C                    ONE HAS WARIGH=WALEFT, AND  THUS  THE  BUG  HAD  NO
C                    CONSEQUENCES. HOWEVER, FOR THE MULTI-REFERENCE USE,
C                    THE NO-PAIRING TRANSITION DENSITY MATRIX READS (SEE
C                    NOTES 99-B):
C
C                    RHO =  WARIGH * (WALEFT^+ * WARIGH)^(-1) * WALEFT^+
C
C                    THAT IS, THE WAVE-FUNCTIONS OF  THE  R I G H T  GCM
C                    STATE APPEAR CONFUSINGLY ON THE  L E F T -HAND-SIDE
C                    OF THE  EXPRESSION.  IN  THE  EXPRESSIONS  DEFINING
C                    LOCAL DENSITIES, THE LEFT GCM WAVE FUNCTIONS WALEFT
C                    MUST APPEAR WITH  COMPLEX  CONJUGATION.  THEREFORE,
C                    THE RIGHT AND LEFT GCM WAVE FUNCTIONS  MUST  DEFINE
C                    THE "P" AND "Q"  ARRAYS  WITHOUT AND  WITH  COMPLEX
C                    CONJUGATION, RESPECTIVELY.
C                    THE BUG WAS CORRECTED 15/09/2020 IN VERSION  2.99V.
C=======================================================================
C
C              AT THIS POINT:
C
C              P(0,ISTATE,ISPIN) CONTAINS THE ISTATE-TH  SINGLE-PARTICLE
C                                "RIGHT" GCM WAVE FUNCTION, OR UPPER AND
C                                LOWER COMPONENTS  OF  THE  "RIGHT"  GCM
C                                QUASI-PARTCLE WAVE FUNCTION, IN ONE  OF
C                                THE SPIN BLOCKS, AS DESCRIBED ABOVE.
C              P(K,ISTATE,ISPIN) (K=1,2,3) CONTAINS ITS X,Y,Z DERIVATIVE
C              PLA(ISTATE,ISPIN) CONTAINS ITS LAPLACIAN
C
C              Q(0,ISTATE,ISPIN) CONTAINS THE ISTATE-TH  SINGLE-PARTICLE
C                                "LEFT" GCM WAVE FUNCTION, OR UPPER  AND
C                                LOWER  COMPONENTS  OF  THE  "LEFT"  GCM
C                                QUASI-PARTCLE WAVE FUNCTION, IN ONE  OF
C                                THE SPIN BLOCKS, AS DESCRIBED ABOVE.
C              Q(K,ISTATE,ISPIN) (K=1,2,3) CONTAINS ITS X,Y,Z DERIVATIVE
C              QLA(ISTATE,ISPIN) CONTAINS ITS LAPLACIAN
C
C              THEY ARE CALCULATED AT THE  (IX,IY,IZ)-TH  POINT  OF  THE
C              INTEGRATION MESH
C
C=======================================================================
C              FOR IKERNE=0 P( . . . ) IS COPIED INTO IN Q( . . . )
C=======================================================================
C
               IF (IKERNE.NE.1) THEN
C
                   Q  =P
                   QLA=PLA
C # --- IN THE ATDHF CALCULATION, SINGULAR VAULE IS MULTIPLIED HERE ---
                   IF(I_SING.EQ.1) THEN
                      DO ISTATE=1,LTOTST
                         PLA(ISTATE,:) = PLA(ISTATE,:)*V_SING(ISTATE)
                         P(:,ISTATE,:) = P(:,ISTATE,:)*V_SING(ISTATE)
                      ENDDO
                   ENDIF
C
               END IF
C
C=======================================================================
C              Q( . . . ) IS COMPLEX CONJUGATED
C=======================================================================
C
               Q  =CONJG(Q)
               QLA=CONJG(QLA)
C
C=======================================================================
C              STORING SQUARES OF WAVE FUNCTIONS FOR THE CALCULATION OF
C              PAIRING MATRIX ELEMENTS
C=======================================================================
C
               IF (IDEVAR.EQ.1.AND.IPAHFB.LT.1) THEN
C
                   IF (LSTATE.GT.NDSTAT)
     *
     *                 STOP ' (12) LSTATE.GT.NDSTAT IN DENSHF'
C
                      JSTATE=LSTATE
                   DO ISTATE=1,LSTATE
                      JSTATE=JSTATE+1
                      U1OCCU=SQRT(1.0d0-V1OCCU(ISTATE)**2)
C
                      SQUWAV(ISTATE,IX,IY,IZ)=
     *                                2.0D0*REAL(P(0,ISTATE,1)
     *                                          *Q(0,ISTATE,1)
     *                                          +P(0,ISTATE,0)
     *                                          *Q(0,ISTATE,0))
C
C=======================================================================
C              HERE THE WAVE FUNCTIONS ARE MULTIPLIED BY THE OCCUPATION
C              PROBABILTIES
C=======================================================================
C
                      DO ISPIN=0,NDSPIN
C
                         CALL ZDSCAL(NDKART+1,V1OCCU(ISTATE),
     *                                    P(0,ISTATE,ISPIN),1)
                         CALL ZDSCAL(NDKART+1,V1OCCU(ISTATE),
     *                                    Q(0,ISTATE,ISPIN),1)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
                         IF (IFTEMP.EQ.1) THEN
                             CALL ZDSCAL(NDKART+1,U1OCCU,
     *                                    P(0,JSTATE,ISPIN),1)
                             CALL ZDSCAL(NDKART+1,U1OCCU,
     *                                    Q(0,JSTATE,ISPIN),1)
                         END IF
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
                         PLA(ISTATE,ISPIN)=
     *                   PLA(ISTATE,ISPIN)*V1OCCU(ISTATE)
C
                         QLA(ISTATE,ISPIN)=
     *                   QLA(ISTATE,ISPIN)*V1OCCU(ISTATE)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
                         IF (IFTEMP.EQ.1) THEN
                             PLA(JSTATE,ISPIN)=
     *                       PLA(JSTATE,ISPIN)*U1OCCU
C
                             QLA(JSTATE,ISPIN)=
     *                       QLA(JSTATE,ISPIN)*U1OCCU
                        END IF
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
                      END DO ! end loop ISPIN
C
                   END DO ! end loop ISTATE
C
               END IF ! end if IDEVAR
C
C=======================================================================
C              SUMMING UP DENSITIES IN THE P-H CHANNEL
C=======================================================================
C
C=======================================================================
C              SUMMING UP CONTRIBUTIONS TO THE AUXILIARY P-H DENSITIES
C=======================================================================
C
               DLUPUP=C_ZERO
               DLDWDW=C_ZERO
               DLUPDW=C_ZERO
               DLDWUP=C_ZERO
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
               IF (IFTEMP.EQ.0) THEN
C
                   DLUPUP=(ZDOTU(LUPPER,PLA(1,1),1,Q(0,1,1),NDKART+2) +
     *                     ZDOTU(LUPPER,QLA(1,1),1,P(0,1,1),NDKART+2))/2
                   DLDWDW=(ZDOTU(LUPPER,PLA(1,0),1,Q(0,1,0),NDKART+2) +
     *                     ZDOTU(LUPPER,QLA(1,0),1,P(0,1,0),NDKART+2))/2
                   DLUPDW=(ZDOTU(LUPPER,PLA(1,1),1,Q(0,1,0),NDKART+2) +
     *                     ZDOTU(LUPPER,QLA(1,0),1,P(0,1,1),NDKART+2))/2
                   DLDWUP=(ZDOTU(LUPPER,PLA(1,0),1,Q(0,1,1),NDKART+2) +
     *                     ZDOTU(LUPPER,QLA(1,1),1,P(0,1,0),NDKART+2))/2
C
               ELSE
C
                      JSTATE=LUPPER
                   DO ISTATE=1,LUPPER
                      JSTATE=JSTATE+1
C
                      DLUPUP=DLUPUP+(PLA(ISTATE,1)*Q(0,ISTATE,1)
     *                             + P(0,ISTATE,1)*QLA(ISTATE,1))
     *                             *(1.D0-FERMFN(ISTATE,ICHARG))
     *                             +(PLA(JSTATE,1)*Q(0,JSTATE,1)
     *                             + P(0,JSTATE,1)*QLA(JSTATE,1))
     *                             * FERMFN(ISTATE,ICHARG)
                      DLDWDW=DLDWDW+(PLA(ISTATE,0)*Q(0,ISTATE,0)
     *                             + P(0,ISTATE,0)*QLA(ISTATE,0))
     *                             *(1.D0-FERMFN(ISTATE,ICHARG))
     *                             +(PLA(JSTATE,0)*Q(0,JSTATE,0)
     *                             + P(0,JSTATE,0)*QLA(JSTATE,0))
     *                             * FERMFN(ISTATE,ICHARG)
C
                      DLUPDW=DLUPDW+(PLA(ISTATE,1)*Q(0,ISTATE,0)
     *                             + P(0,ISTATE,1)*QLA(ISTATE,0))
     *                             *(1.D0-FERMFN(ISTATE,ICHARG))
     *                             +(PLA(JSTATE,1)*Q(0,JSTATE,0)
     *                             + P(0,JSTATE,1)*QLA(JSTATE,0))
     *                             * FERMFN(ISTATE,ICHARG)
C
                      DLDWUP=DLDWUP+(PLA(ISTATE,0)*Q(0,ISTATE,1)
     *                             + P(0,ISTATE,0)*QLA(ISTATE,1))
     *                             *(1.D0-FERMFN(ISTATE,ICHARG))
     *                             +(PLA(JSTATE,0)*Q(0,JSTATE,1)
     *                             + P(0,JSTATE,0)*QLA(JSTATE,1))
     *                             * FERMFN(ISTATE,ICHARG)
                   END DO ! end loop ISTATE
C
                   DLUPUP=DLUPUP/2
                   DLDWDW=DLDWDW/2
                   DLUPDW=DLUPDW/2
                   DLDWUP=DLDWUP/2
C
               END IF ! end if IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C              P-H DENSITIES
C=======================================================================
C              SPIN UP-UP AND DOWN-DOWN P-H DENSITIES
C=======================================================================
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
               IF (IFTEMP.EQ.0) THEN
                   CALL ZGEMM('N','T',NDKART+1,NDKART+1,LUPPER,C_UNIT,
     *                        P(0,1,1),NDKART+2,Q(0,1,1),NDKART+2,
     *                        C_ZERO,DEUPUP(0,0), NDKART+2)
                   CALL ZGEMM('N','T',NDKART+1,NDKART+1,LUPPER,C_UNIT,
     *                        P(0,1,0),NDKART+2,Q(0,1,0),NDKART+2,
     *                        C_ZERO,DEDWDW(0,0), NDKART+2)
               ELSE
C
                   DO MU=0,NDKART
                      DO NU=0,MUSYME(MU)
C
                         DEUPUP(MU,NU)=C_ZERO
                         DEDWDW(MU,NU)=C_ZERO
C
                            JSTATE=LUPPER
                         DO ISTATE=1,LUPPER
                            JSTATE=JSTATE+1
C
                            DEUPUP(MU,NU)=DEUPUP(MU,NU)
     *                             +(P(MU,ISTATE,1)* Q(NU,ISTATE,1))
     *                              * (1.D0-FERMFN(ISTATE,ICHARG))
     *                                             +(P(MU,JSTATE,1)
     *                                             * Q(NU,JSTATE,1))
     *                                    * FERMFN(ISTATE,ICHARG)
                            DEDWDW(MU,NU)=DEDWDW(MU,NU)
     *                             +(P(MU,ISTATE,0)* Q(NU,ISTATE,0))
     *                               *(1.D0-FERMFN(ISTATE,ICHARG))
     *                                            + (P(MU,JSTATE,0)
     *                                            *  Q(NU,JSTATE,0))
     *                                    * FERMFN(ISTATE,ICHARG)
                         END DO
C
                         IF (IKERNE.NE.1) THEN
                             DEUPUP(NU,MU)=CONJG(DEUPUP(MU,NU))
                             DEDWDW(NU,MU)=CONJG(DEDWDW(MU,NU))
                         END IF
C
                      END DO ! end loop NU
                   END DO ! end loop MU
C
               END IF ! end if IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C              SPIN UP-DOWN P-H DENSITIES
C=======================================================================
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
               IF (IFTEMP.EQ.0) THEN
C
                   CALL ZGEMM('N','T',NDKART+1,NDKART+1,LUPPER,C_UNIT,
     *                        P(0,1,1),NDKART+2,
     *                        Q(0,1,0),NDKART+2,
     *                        C_ZERO,DEUPDW(0,0),NDKART+2)
C
               ELSE
C
                   DO MU=0,NDKART
                      DO NU=0,NDKART
C
                         DEUPDW(MU,NU)=C_ZERO
C
                            JSTATE=LUPPER
                         DO ISTATE=1,LUPPER
                            JSTATE=JSTATE+1
C
                            DEUPDW(MU,NU)=DEUPDW(MU,NU)
     *                             +(P(MU,ISTATE,1) * Q(NU,ISTATE,0))
     *                               * (1.D0-FERMFN(ISTATE,ICHARG))
     *                                             + (P(MU,JSTATE,1)
     *                                             *  Q(NU,JSTATE,0))
     *                                      *FERMFN(ISTATE,ICHARG)
                         END DO
C
                      END DO ! end loop NU
                   END DO ! end loop MU
C
               END IF ! end if IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C              SPIN DOWN-UP P-H DENSITIES
C=======================================================================
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
               IF (IFTEMP.EQ.0) THEN
C
                   IF (IKERNE.EQ.1) THEN
C
                       CALL ZGEMM('N','T',NDKART+1,NDKART+1,LUPPER,
     *                            C_UNIT,P(0,1,0),NDKART+2,
     *                                   Q(0,1,1),NDKART+2,
     *                            C_ZERO,DEDWUP(0,0),NDKART+2)
C
                   ELSE
C
                       DO MU=0,NDKART
                         DO NU=0,NDKART
                            DEDWUP(MU,NU)=CONJG(DEUPDW(NU,MU))
                         END DO
                       END DO
C
                   END IF
C
               ELSE
C
                   DO MU=0,NDKART
                      DO NU=0,NDKART
C
                         DEDWUP(MU,NU)=C_ZERO
C
                         IF (IKERNE.EQ.1) THEN
C
                                JSTATE=LUPPER
                             DO ISTATE=1,LUPPER
                                JSTATE=JSTATE+1
C
                                DEDWUP(MU,NU)=DEDWUP(MU,NU)
     *                                 +(P(MU,ISTATE,0)* Q(NU,ISTATE,1))
     *                                 * (1.0D0-FERMFN(ISTATE,ICHARG))
     *                                                + (P(MU,JSTATE,0)
     *                                                *  Q(NU,JSTATE,1))
     *                                         *FERMFN(ISTATE,ICHARG)
C
                             END DO
C
                         ELSE
C
                             DEDWUP(MU,NU)=CONJG(DEUPDW(NU,MU))
C
                         END IF
C
                      END DO ! end loop NU
                   END DO ! end loop MU
C
               END IF ! end if IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C              CALCULATING   THE   SCALAR P-H DENSITIES
C=======================================================================
C
               DE_RHO(IX,IY,IZ,ITPNMX,LTWCEN)=
     *         DE_RHO(IX,IY,IZ,ITPNMX,LTWCEN)+DEUPUP(0,0)+DEDWDW(0,0)
C
               DE_TAU(IX,IY,IZ,ITPNMX,LTWCEN)=
     *         DE_TAU(IX,IY,IZ,ITPNMX,LTWCEN)+DEUPUP(1,1)+DEDWDW(1,1)
     *                                +DEUPUP(2,2)+DEDWDW(2,2)
     *                                +DEUPUP(3,3)+DEDWDW(3,3)
C
               DE_LPR(IX,IY,IZ,ITPNMX,LTWCEN)=
     *         DE_LPR(IX,IY,IZ,ITPNMX,LTWCEN)+2*(DLUPUP     +DLDWDW
     *                                   +DEUPUP(1,1)+DEDWDW(1,1)
     *                                   +DEUPUP(2,2)+DEDWDW(2,2)
     *                                   +DEUPUP(3,3)+DEDWDW(3,3))
C
               DE_DIV(IX,IY,IZ,ITPNMX,LTWCEN)=
     *         DE_DIV(IX,IY,IZ,ITPNMX,LTWCEN)+((DEUPDW(2,3)-DEUPDW(3,2))
     *                                 +(DEDWUP(2,3)-DEDWUP(3,2)))
     *                                              *UNIT_I
     *                                +((DEUPDW(3,1)-DEUPDW(1,3))
     *                                 -(DEDWUP(3,1)-DEDWUP(1,3)))*(-1)
     *                                +((DEUPUP(1,2)-DEUPUP(2,1))
     *                                 -(DEDWDW(1,2)-DEDWDW(2,1)))
     *                                              *UNIT_I
C
C=======================================================================
C              CALCULATING THE VECTOR P-H DENSITIES
C=======================================================================
C
               DE_SPI(IX,IY,IZ,1,ITPNMX,LTWCEN)=
     *         DE_SPI(IX,IY,IZ,1,ITPNMX,LTWCEN)+(DEUPDW(0,0)
     *                                          +DEDWUP(0,0))
C
               DE_SPI(IX,IY,IZ,2,ITPNMX,LTWCEN)=
     *         DE_SPI(IX,IY,IZ,2,ITPNMX,LTWCEN)+(DEUPDW(0,0)
     *                                       -DEDWUP(0,0))*UNIT_I
C
               DE_SPI(IX,IY,IZ,3,ITPNMX,LTWCEN)=
     *         DE_SPI(IX,IY,IZ,3,ITPNMX,LTWCEN)+(DEUPUP(0,0)
     *                                          -DEDWDW(0,0))
C
C=======================================================================
C
               DE_KIS(IX,IY,IZ,1,ITPNMX,LTWCEN)=
     *         DE_KIS(IX,IY,IZ,1,ITPNMX,LTWCEN)+(DEUPDW(1,1)+DEDWUP(1,1)
     *                                   +DEUPDW(2,2)+DEDWUP(2,2)
     *                                   +DEUPDW(3,3)+DEDWUP(3,3))
C
               DE_KIS(IX,IY,IZ,2,ITPNMX,LTWCEN)=
     *         DE_KIS(IX,IY,IZ,2,ITPNMX,LTWCEN)+(DEUPDW(1,1)-DEDWUP(1,1)
     *                                   +DEUPDW(2,2)-DEDWUP(2,2)
     *                                   +DEUPDW(3,3)-DEDWUP(3,3))
     *                                               *UNIT_I
C
               DE_KIS(IX,IY,IZ,3,ITPNMX,LTWCEN)=
     *         DE_KIS(IX,IY,IZ,3,ITPNMX,LTWCEN)+(DEUPUP(1,1)-DEDWDW(1,1)
     *                                   +DEUPUP(2,2)-DEDWDW(2,2)
     *                                   +DEUPUP(3,3)-DEDWDW(3,3))
C
C=======================================================================
C
               DE_LPS(IX,IY,IZ,1,ITPNMX,LTWCEN)=
     *         DE_LPS(IX,IY,IZ,1,ITPNMX,LTWCEN)+2*(DLUPDW     +DLDWUP
     *                                     +DEUPDW(1,1)+DEDWUP(1,1)
     *                                     +DEUPDW(2,2)+DEDWUP(2,2)
     *                                     +DEUPDW(3,3)+DEDWUP(3,3))
C
               DE_LPS(IX,IY,IZ,2,ITPNMX,LTWCEN)=
     *         DE_LPS(IX,IY,IZ,2,ITPNMX,LTWCEN)+2*(DLUPDW     -DLDWUP
     *                                     +DEUPDW(1,1)-DEDWUP(1,1)
     *                                     +DEUPDW(2,2)-DEDWUP(2,2)
     *                                     +DEUPDW(3,3)-DEDWUP(3,3))
     *                                                 *UNIT_I
C
               DE_LPS(IX,IY,IZ,3,ITPNMX,LTWCEN)=
     *         DE_LPS(IX,IY,IZ,3,ITPNMX,LTWCEN)+2*(DLUPUP     -DLDWDW
     *                                     +DEUPUP(1,1)-DEDWDW(1,1)
     *                                     +DEUPUP(2,2)-DEDWDW(2,2)
     *                                     +DEUPUP(3,3)-DEDWDW(3,3))
C
C=======================================================================
C
               DO K=1,NDKART
C
                  DE_GRR(IX,IY,IZ,K,ITPNMX,LTWCEN)=
     *            DE_GRR(IX,IY,IZ,K,ITPNMX,LTWCEN)+(DEUPUP(K,0)+
     *                          DEUPUP(0,K)+DEDWDW(K,0)+DEDWDW(0,K))
C
                  DE_CUR(IX,IY,IZ,K,ITPNMX,LTWCEN)=
     *            DE_CUR(IX,IY,IZ,K,ITPNMX,LTWCEN)+(DEUPUP(K,0)-
     *                          DEUPUP(0,K)+DEDWDW(K,0)-DEDWDW(0,K))
     *                                      /2/UNIT_I
C
                  DENAUX(K,1)=((DEUPDW(K,0)+DEUPDW(0,K))
     *                        +(DEDWUP(K,0)+DEDWUP(0,K)))
C
                  DENAUX(K,2)=((DEUPDW(K,0)+DEUPDW(0,K))
     *                        -(DEDWUP(K,0)+DEDWUP(0,K)))*UNIT_I
C
                  DENAUX(K,3)=((DEUPUP(K,0)+DEUPUP(0,K))
     *                        -(DEDWDW(K,0)+DEDWDW(0,K)))
C
               END DO
C
C=======================================================================
C
               DO K=1,NDKART
                  DO L=1,NDKART
C
                     DENAUY(K,L,1)=(DEUPDW(K,L)+DEDWUP(K,L))
C
                     DENAUY(K,L,2)=(DEUPDW(K,L)-DEDWUP(K,L))*UNIT_I
C
                     DENAUY(K,L,3)=(DEUPUP(K,L)-DEDWDW(K,L))
C
                  END DO
               END DO
C
               DO K=1,NDKART
                  DO L=1,NDKART
C
                     DE_KIF(IX,IY,IZ,K,ITPNMX,LTWCEN)=
     *               DE_KIF(IX,IY,IZ,K,ITPNMX,LTWCEN)+
     *                         (DENAUY(K,L,L) + DENAUY(L,K,L))/2
C
                  END DO
               END DO
C
C=======================================================================
C
               DE_ROS(IX,IY,IZ,1,ITPNMX,LTWCEN)=
     *         DE_ROS(IX,IY,IZ,1,ITPNMX,LTWCEN)+DENAUX(2,3)-DENAUX(3,2)
C
               DE_ROS(IX,IY,IZ,2,ITPNMX,LTWCEN)=
     *         DE_ROS(IX,IY,IZ,2,ITPNMX,LTWCEN)+DENAUX(3,1)-DENAUX(1,3)
C
               DE_ROS(IX,IY,IZ,3,ITPNMX,LTWCEN)=
     *         DE_ROS(IX,IY,IZ,3,ITPNMX,LTWCEN)+DENAUX(1,2)-DENAUX(2,1)
C
C=======================================================================
C
               DE_ROC(IX,IY,IZ,1,ITPNMX,LTWCEN)=
     *         DE_ROC(IX,IY,IZ,1,ITPNMX,LTWCEN)+(DEUPUP(2,3)-DEUPUP(3,2)
     *                                   +DEDWDW(2,3)-DEDWDW(3,2))
     *                                               *UNIT_I
C
               DE_ROC(IX,IY,IZ,2,ITPNMX,LTWCEN)=
     *         DE_ROC(IX,IY,IZ,2,ITPNMX,LTWCEN)+(DEUPUP(3,1)-DEUPUP(1,3)
     *                                   +DEDWDW(3,1)-DEDWDW(1,3))
     *                                               *UNIT_I
C
               DE_ROC(IX,IY,IZ,3,ITPNMX,LTWCEN)=
     *         DE_ROC(IX,IY,IZ,3,ITPNMX,LTWCEN)+(DEUPUP(1,2)-DEUPUP(2,1)
     *                                   +DEDWDW(1,2)-DEDWDW(2,1))
     *                                               *UNIT_I
C
C=======================================================================
C              CALCULATING THE TENSOR P-H DENSITY
C=======================================================================
C
               DO K=1,NDKART
C
                  DE_SCU(IX,IY,IZ,K,1,ITPNMX,LTWCEN)=
     *            DE_SCU(IX,IY,IZ,K,1,ITPNMX,LTWCEN)
     *                  +((DEUPDW(K,0)-DEUPDW(0,K))
     *                  + (DEDWUP(K,0)-DEDWUP(0,K)))
     *                  /2/UNIT_I
C
                  DE_SCU(IX,IY,IZ,K,2,ITPNMX,LTWCEN)=
     *            DE_SCU(IX,IY,IZ,K,2,ITPNMX,LTWCEN)
     *                  +((DEUPDW(K,0)-DEUPDW(0,K))
     *                  - (DEDWUP(K,0)-DEDWUP(0,K)))
     *                  /2
C
                  DE_SCU(IX,IY,IZ,K,3,ITPNMX,LTWCEN)=
     *            DE_SCU(IX,IY,IZ,K,3,ITPNMX,LTWCEN)
     *                  +((DEUPUP(K,0)-DEUPUP(0,K))
     *                  - (DEDWDW(K,0)-DEDWDW(0,K)))
     *                  /2/UNIT_I
C
                  DO L=1,NDKART
                     DE_DES(IX,IY,IZ,K,L,ITPNMX,LTWCEN)=
     *               DE_DES(IX,IY,IZ,K,L,ITPNMX,LTWCEN)+DENAUX(K,L)
                  END DO
C
               END DO
C
               IF (IGRAIN.EQ.1) THEN
C
C=======================================================================
C           ATTENTION: AFTER THE WORK ON 3BODY GRADIENTS HAS STARTED  IN
C                      VERSION 2.85A, AND UP TO  VERSION  2.97E,  SWITCH
C                      "IGRAIN" WAS NOT TRANSFERRED  TO  "DENSHF".  THIS
C                      BUG WAS CORRECTED ON 18/07/2020 IN VERSION 2.97F.
C=======================================================================
C
                   DE_DIJ(IX,IY,IZ,ITPNMX,LTWCEN)=
     *             DE_DIJ(IX,IY,IZ,ITPNMX,LTWCEN)+(DLUPUP     +DLDWDW
     *                                     -DEUPUP(1,1)-DEDWDW(1,1)
     *                                     -DEUPUP(2,2)-DEDWDW(2,2)
     *                                     -DEUPUP(3,3)-DEDWDW(3,3))
     *                                               /2/UNIT_I
C
                   DE_DIS(IX,IY,IZ,1,ITPNMX,LTWCEN)=
     *             DE_DIS(IX,IY,IZ,1,ITPNMX,LTWCEN)+(DLUPDW     +DLDWUP
     *                                       -DEUPDW(1,1)-DEDWUP(1,1)
     *                                       -DEUPDW(2,2)-DEDWUP(2,2)
     *                                       -DEUPDW(3,3)-DEDWUP(3,3))
     *                                               /2/UNIT_I
C
                   DE_DIS(IX,IY,IZ,2,ITPNMX,LTWCEN)=
     *             DE_DIS(IX,IY,IZ,2,ITPNMX,LTWCEN)-(DLUPDW     -DLDWUP
     *                                       -DEUPDW(1,1)+DEDWUP(1,1)
     *                                       -DEUPDW(2,2)+DEDWUP(2,2)
     *                                       -DEUPDW(3,3)+DEDWUP(3,3))
     *                                               /2
C
                   DE_DIS(IX,IY,IZ,3,ITPNMX,LTWCEN)=
     *             DE_DIS(IX,IY,IZ,3,ITPNMX,LTWCEN)+(DLUPUP     -DLDWDW
     *                                       -DEUPUP(1,1)+DEDWDW(1,1)
     *                                       -DEUPUP(2,2)+DEDWDW(2,2)
     *                                       -DEUPUP(3,3)+DEDWDW(3,3))
     *                                               /2/UNIT_I
C
               END IF
C
C=======================================================================
C              SUMMING UP DENSITIES IN THE P-P CHANNEL
C=======================================================================
C
               IF (IPAHFB.EQ.1) THEN
C
                   LOFSET=0
                   LOFTRV=LTIMUP
                   LUPTRV=LSTATE
                   IF (LREVER.EQ.0) THEN
                       LOFSET=LTIMUP
                       LOFTRV=0
                   END IF
C
C=======================================================================
C              SPIN UP-UP, DOWN-DOWN, UP-DOWN, AND DOWN-UP P-P DENSITIES
C=======================================================================
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
                   IF (IFTEMP.EQ.0) THEN
C                 -----------------------------------------------------
C                 "Regular" pairing density, < L|aa|R >
C
C                 Time-up contribution
C                 TODO: check compatibility with various
C                 time-reversal-symmetry parameters
C
C                    THIS BLOCK IS INDENTED ONLY BY 2 SPACES
C
                     CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                          LSTATE-LUPPER,C_UNIT,
     *                          P(0,LOFSET+1,1),NDKART+2,
     *                          Q(0,LUPPER+1,1),NDKART+2,
     *                          C_ZERO,PAUPUP(0,0),NDKART+2)
                     CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                          LSTATE-LUPPER,C_UNIT,
     *                          P(0,LOFSET+1,0),NDKART+2,
     *                          Q(0,LUPPER+1,0),NDKART+2,
     *                          C_ZERO,PADWDW(0,0),NDKART+2)
                     CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                          LSTATE-LUPPER,C_UNIT,
     *                          P(0,LOFSET+1,1),NDKART+2,
     *                          Q(0,LUPPER+1,0),NDKART+2,
     *                          C_ZERO,PAUPDW(0,0),NDKART+2)
                     CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                          LSTATE-LUPPER,C_UNIT,
     *                          P(0,LOFSET+1,0),NDKART+2,
     *                          Q(0,LUPPER+1,1),NDKART+2,
     *                          C_ZERO,PADWUP(0,0),NDKART+2)
C
                     PLUPUP=(ZDOTU(LSTATE-LUPPER,PLA(LOFSET+1,1),1,
     *                                    Q(0,LUPPER+1,1),NDKART+2)
     *                     + ZDOTU(LSTATE-LUPPER,QLA(LUPPER+1,1),1,
     *                                    P(0,LOFSET+1,1),NDKART+2))/2
                     PLDWDW=(ZDOTU(LSTATE-LUPPER,PLA(LOFSET+1,0),1,
     *                                    Q(0,LUPPER+1,0),NDKART+2)
     *                     + ZDOTU(LSTATE-LUPPER,QLA(LUPPER+1,0),1,
     *                                    P(0,LOFSET+1,0),NDKART+2))/2
                     PLUPDW=(ZDOTU(LSTATE-LUPPER,PLA(LOFSET+1,1),1,
     *                                    Q(0,LUPPER+1,0),NDKART+2)
     *                     + ZDOTU(LSTATE-LUPPER,QLA(LUPPER+1,0),1,
     *                                    P(0,LOFSET+1,1),NDKART+2))/2
                     PLDWUP=(ZDOTU(LSTATE-LUPPER,PLA(LOFSET+1,0),1,
     *                                    Q(0,LUPPER+1,1),NDKART+2)
     *                     + ZDOTU(LSTATE-LUPPER,QLA(LUPPER+1,1),1,
     *                                    P(0,LOFSET+1,0),NDKART+2))/2
C
                     IF (IKERNE.EQ.1.OR.ISIMPY.EQ.0) THEN
C                       Time-down contribution
C
C                       THIS BLOCK IS INDENTED ONLY BY 3 SPACES
C
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LTOTST-LSTATE,C_UNIT,
     *                             P(0,LOFTRV+1,1),NDKART+2,
     *                             Q(0,LUPTRV+1,1),NDKART+2,
     *                             C_UNIT,PAUPUP(0,0),NDKART+2)
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LTOTST-LSTATE,C_UNIT,
     *                             P(0,LOFTRV+1,0),NDKART+2,
     *                             Q(0,LUPTRV+1,0),NDKART+2,
     *                             C_UNIT,PADWDW(0,0),NDKART+2)
                        CALL  ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LTOTST-LSTATE,C_UNIT,
     *                             P(0,LOFTRV+1,1),NDKART+2,
     *                             Q(0,LUPTRV+1,0),NDKART+2,
     *                             C_UNIT,PAUPDW(0,0),NDKART+2)
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LTOTST-LSTATE,C_UNIT,
     *                             P(0,LOFTRV+1,0),NDKART+2,
     *                             Q(0,LUPTRV+1,1),NDKART+2,
     *                             C_UNIT,PADWUP(0,0),NDKART+2)
C
                        PLUPUP=PLUPUP
     *                   +(ZDOTU(LTOTST-LSTATE,PLA(LOFTRV+1,1),1,
     *                                  Q(0,LUPTRV+1,1),NDKART+2)
     *                   + ZDOTU(LTOTST-LSTATE,QLA(LUPTRV+1,1),1,
     *                                  P(0,LOFTRV+1,1),NDKART+2))/2
                        PLDWDW=PLDWDW
     *                   +(ZDOTU(LTOTST-LSTATE,PLA(LOFTRV+1,0),1,
     *                                  Q(0,LUPTRV+1,0),NDKART+2)
     *                   + ZDOTU(LTOTST-LSTATE,QLA(LUPTRV+1,0),1,
     *                                  P(0,LOFTRV+1,0),NDKART+2))/2
                        PLUPDW=PLUPDW
     *                   +(ZDOTU(LTOTST-LSTATE,PLA(LOFTRV+1,1),1,
     *                                  Q(0,LUPTRV+1,0),NDKART+2)
     *                   + ZDOTU(LTOTST-LSTATE,QLA(LUPTRV+1,0),1,
     *                                  P(0,LOFTRV+1,1),NDKART+2))/2
                        PLDWUP=PLDWUP
     *                   +(ZDOTU(LTOTST-LSTATE,PLA(LOFTRV+1,0),1,
     *                                  Q(0,LUPTRV+1,1),NDKART+2)
     *                   + ZDOTU(LTOTST-LSTATE,QLA(LUPTRV+1,1),1,
     *                                  P(0,LOFTRV+1,0),NDKART+2))/2
C
                     END IF
C
C                    -----------------------------------------------------
C                    "Conjugate" pairing density, < L|a+a+|R >
C
                     IF (IKERNE.EQ.1.AND.MREVER.NE.1)
     *                    STOP
     *                    "IKERNE.EQ.1 WITH IPAHFB.EQ.1 REQUIRES\n
     *                     MREVER.EQ.1 IN DENSHF"
C
                     IF (IKERNE.EQ.1.AND.ITWCEN.EQ.1) THEN
C
C                       Time-up contribution
C                       TODO: check compatibility with various
C                       time-reversal-symmetry parameters
C
C=======================================================================
C            THIS BLOCK CALCULATES THE SECOND (PRIME) PAIRING DENSITIES.
C            THEY ARE NEEDED ONLY FOR THE MULTI-REFERENCE CASE IKERNE=1.
C            THEY ARE CALCULATED BY THE SAME EXPRSSIONS AS THOSE  GIVING
C            THE STANDARD PAIRING DENSITIES, BUT WITH ARRAYS "P" AND "Q"
C            EXCHANGED, SEE NOTES 99-C. SINCE THE STANDARD ARRAY "Q"  IS
C            COMPLEX CONJUGATED, CALCULATION OF THE SECOND PRIME PAIRING
C            DENSITIES IS FOLLOWED BY THE COMPLEX CONJUGATION.
C=======================================================================
C
C                       THIS BLOCK IS INDENTED ONLY BY 3 SPACES
C
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LSTATE-LUPPER,C_UNIT,
     *                             Q(0,LOFSET+1,1),NDKART+2,
     *                             P(0,LUPPER+1,1),NDKART+2,
     *                             C_ZERO,PCUPUP(0,0),NDKART+2)
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LSTATE-LUPPER,C_UNIT,
     *                             Q(0,LOFSET+1,0),NDKART+2,
     *                             P(0,LUPPER+1,0),NDKART+2,
     *                             C_ZERO,PCDWDW(0,0),NDKART+2)
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LSTATE-LUPPER,C_UNIT,
     *                             Q(0,LOFSET+1,1),NDKART+2,
     *                             P(0,LUPPER+1,0),NDKART+2,
     *                             C_ZERO,PCUPDW(0,0),NDKART+2)
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LSTATE-LUPPER,C_UNIT,
     *                             Q(0,LOFSET+1,0),NDKART+2,
     *                             P(0,LUPPER+1,1),NDKART+2,
     *                             C_ZERO,PCDWUP(0,0),NDKART+2)
C
                        CLUPUP=(ZDOTU(LSTATE-LUPPER,QLA(LOFSET+1,1),1,
     *                                    P(0,LUPPER+1,1),NDKART+2)
     *                        + ZDOTU(LSTATE-LUPPER,PLA(LUPPER+1,1),1,
     *                                    Q(0,LOFSET+1,1),NDKART+2))/2
                        CLDWDW=(ZDOTU(LSTATE-LUPPER,QLA(LOFSET+1,0),1,
     *                                    P(0,LUPPER+1,0),NDKART+2)
     *                        + ZDOTU(LSTATE-LUPPER,PLA(LUPPER+1,0),1,
     *                                    Q(0,LOFSET+1,0),NDKART+2))/2
                        CLUPDW=(ZDOTU(LSTATE-LUPPER,QLA(LOFSET+1,1),1,
     *                                    P(0,LUPPER+1,0),NDKART+2)
     *                        + ZDOTU(LSTATE-LUPPER,PLA(LUPPER+1,0),1,
     *                                    Q(0,LOFSET+1,1),NDKART+2))/2
                        CLDWUP=(ZDOTU(LSTATE-LUPPER,QLA(LOFSET+1,0),1,
     *                                    P(0,LUPPER+1,1),NDKART+2)
     *                        + ZDOTU(LSTATE-LUPPER,PLA(LUPPER+1,1),1,
     *                                    Q(0,LOFSET+1,0),NDKART+2))/2
C
C                       Time-down contribution
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LTOTST-LSTATE,C_UNIT,
     *                             Q(0,LOFTRV+1,1),NDKART+2,
     *                             P(0,LUPTRV+1,1),NDKART+2,
     *                             C_UNIT,PCUPUP(0,0),NDKART+2)
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LTOTST-LSTATE,C_UNIT,
     *                             Q(0,LOFTRV+1,0),NDKART+2,
     *                             P(0,LUPTRV+1,0),NDKART+2,
     *                             C_UNIT,PCDWDW(0,0),NDKART+2)
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LTOTST-LSTATE,C_UNIT,
     *                             Q(0,LOFTRV+1,1),NDKART+2,
     *                             P(0,LUPTRV+1,0),NDKART+2,
     *                             C_UNIT,PCUPDW(0,0),NDKART+2)
                        CALL ZGEMM('N','T',NDKART+1,NDKART+1,
     *                             LTOTST-LSTATE,C_UNIT,
     *                             Q(0,LOFTRV+1,0),NDKART+2,
     *                             P(0,LUPTRV+1,1),NDKART+2,
     *                             C_UNIT,PCDWUP(0,0),NDKART+2)
C
                        CLUPUP=CLUPUP
     *                    +(ZDOTU(LTOTST-LSTATE,QLA(LOFTRV+1,1),1,
     *                                  P(0,LUPTRV+1,1),NDKART+2)
     *                    + ZDOTU(LTOTST-LSTATE,PLA(LUPTRV+1,1),1,
     *                                  Q(0,LOFTRV+1,1),NDKART+2))/2
                        CLDWDW=CLDWDW
     *                    +(ZDOTU(LTOTST-LSTATE,QLA(LOFTRV+1,0),1,
     *                                  P(0,LUPTRV+1,0),NDKART+2)
     *                    + ZDOTU(LTOTST-LSTATE,PLA(LUPTRV+1,0),1,
     *                                  Q(0,LOFTRV+1,0),NDKART+2))/2
                        CLUPDW=CLUPDW
     *                    +(ZDOTU(LTOTST-LSTATE,QLA(LOFTRV+1,1),1,
     *                                  P(0,LUPTRV+1,0),NDKART+2)
     *                    + ZDOTU(LTOTST-LSTATE,PLA(LUPTRV+1,0),1,
     *                                  Q(0,LOFTRV+1,1),NDKART+2))/2
                        CLDWUP=CLDWUP
     *                    +(ZDOTU(LTOTST-LSTATE,QLA(LOFTRV+1,0),1,
     *                                  P(0,LUPTRV+1,1),NDKART+2)
     *                    + ZDOTU(LTOTST-LSTATE,PLA(LUPTRV+1,1),1,
     *                                  Q(0,LOFTRV+1,0),NDKART+2))/2
C
C                       IKERNE=1 case:
                        PCUPUP(:,:)=CONJG(PCUPUP(:,:))
                        PCDWDW(:,:)=CONJG(PCDWDW(:,:))
                        PCUPDW(:,:)=CONJG(PCUPDW(:,:))
                        PCDWUP(:,:)=CONJG(PCDWUP(:,:))
C
                        CLUPUP=CONJG(CLUPUP)
                        CLDWDW=CONJG(CLDWDW)
                        CLUPDW=CONJG(CLUPDW)
                        CLDWUP=CONJG(CLDWUP)
C
C=======================================================================
C            ATTENTION: TWO-CENTER BASIS OPTION WON'T WORK FOR GCM.
C                       THAT PROBLEM WILL BE ATTACKED LATER.
C=======================================================================
C
                     ELSE
C                       IKERNE=0 case:
                        PCUPUP(:,:)=PAUPUP(:,:)
                        PCDWDW(:,:)=PADWDW(:,:)
                        PCUPDW(:,:)=PAUPDW(:,:)
                        PCDWUP(:,:)=PADWUP(:,:)
C
                        CLUPUP=PLUPUP
                        CLDWDW=PLDWDW
                        CLUPDW=PLUPDW
                        CLDWUP=PLDWUP
                     END IF
C
                   ELSE          ! (IFTEMP.NE.0)
C
C                    THIS BLOCK IS INDENTED ONLY BY 2 SPACES
C
                     PLUPUP=C_ZERO
                     PLDWDW=C_ZERO
                     PLUPDW=C_ZERO
                     PLDWUP=C_ZERO
C
                     DO MU=0,NDKART
                        DO NU=0,NDKART
C
                           PAUPUP(MU,NU)=C_ZERO
                           PADWDW(MU,NU)=C_ZERO
                           PAUPDW(MU,NU)=C_ZERO
                           PADWUP(MU,NU)=C_ZERO
C
                           DO ISTATE=LUPPER+1,LTOTST
C
                              JSTATE=ISTATE-LUPPER+LOFSET
C                   ISTATE: lower (u)     time-reversed qp component
C                   JSTATE: upper (v) non-time-reversed qp component
C
                              PAUPUP(MU,NU)=PAUPUP(MU,NU)
     *                             +(P(MU,JSTATE,1)
     *                              *Q(NU,ISTATE,1))
     *                      *(1.D0-2.0D0*FERMFN(JSTATE,ICHARG))
                              PADWDW(MU,NU)=PADWDW(MU,NU)
     *                             +(P(MU,JSTATE,0)
     *                              *Q(NU,ISTATE,0))
     *                       *(1.D0-2.0D0*FERMFN(JSTATE,ICHARG))
                              PAUPDW(MU,NU)=PAUPDW(MU,NU)
     *                             +(P(MU,JSTATE,1)
     *                              *Q(NU,ISTATE,0))
     *                       *(1.D0-2.0D0*FERMFN(JSTATE,ICHARG))
                              PADWUP(MU,NU)=PADWUP(MU,NU)
     *                             +(P(MU,JSTATE,0)
     *                              *Q(NU,ISTATE,1))
     *                       *(1.D0-2.0D0*FERMFN(JSTATE,ICHARG))
                           END DO
C
                        END DO
                     END DO
C
                     PCUPUP(:,:)=PAUPUP(:,:)
                     PCDWDW(:,:)=PADWDW(:,:)
                     PCUPDW(:,:)=PAUPDW(:,:)
                     PCDWUP(:,:)=PADWUP(:,:)
C
                   END IF        ! (IFTEMP.EQ.0)
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C                   CALCULATING   THE   SCALAR P-P DENSITIES
C=======================================================================
C                   FOR THE  CONSERVED SIMPLEX (ISIMPY = 1) ONLY HALF OF
C                   THE QUASIPARTICLES CONTRIBUTE TO  THE P-P DENSITIES,
C                   AND THEREFORE THE DENSITIES BELOW ARE THEN MULTIPLED
C                   BY 2.
C=======================================================================
C
C                 Multiply by two except if kernel calculation,
C                 in which cases we used the whole
C                 basis to calculate the pair densities
                                                   SIMFAC=2.0d0
                   IF (IKERNE.EQ.1.OR.ISIMPY.EQ.0) SIMFAC=1.0d0
C
C                    THIS BLOCK IS INDENTED BY ADDITIONAL 2 SPACES
C
                     PD_RHO(IX,IY,IZ,ITPNMX,LTWCEN)=
     *                    PD_RHO(IX,IY,IZ,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PAUPUP(0,0)+PADWDW(0,0))
                     PP_RHO(IX,IY,IZ,ITPNMX,LTWCEN)=
     *                    PP_RHO(IX,IY,IZ,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PCUPUP(0,0)+PCDWDW(0,0))
C
                     PD_TAU(IX,IY,IZ,ITPNMX,LTWCEN)=
     *                    PD_TAU(IX,IY,IZ,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PAUPUP(1,1)+PADWDW(1,1)
     *                            +PAUPUP(2,2)+PADWDW(2,2)
     *                            +PAUPUP(3,3)+PADWDW(3,3))
                     PP_TAU(IX,IY,IZ,ITPNMX,LTWCEN)=
     *                    PP_TAU(IX,IY,IZ,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PCUPUP(1,1)+PCDWDW(1,1)
     *                            +PCUPUP(2,2)+PCDWDW(2,2)
     *                            +PCUPUP(3,3)+PCDWDW(3,3))
C
                     PD_LPR(IX,IY,IZ,ITPNMX,LTWCEN)=
     *                   PD_LPR(IX,IY,IZ,ITPNMX,LTWCEN)
     *                   +SIMFAC*2*(PLUPUP     +PLDWDW
     *                            +PAUPUP(1,1)+PADWDW(1,1)
     *                            +PAUPUP(2,2)+PADWDW(2,2)
     *                            +PAUPUP(3,3)+PADWDW(3,3))
                     PP_LPR(IX,IY,IZ,ITPNMX,LTWCEN)=
     *                   PP_LPR(IX,IY,IZ,ITPNMX,LTWCEN)
     *                   +SIMFAC*2*(CLUPUP     +CLDWDW
     *                            +PCUPUP(1,1)+PCDWDW(1,1)
     *                            +PCUPUP(2,2)+PCDWDW(2,2)
     *                            +PCUPUP(3,3)+PCDWDW(3,3))
C
                     DO K=1,NDKART
C
                       PD_GRR(IX,IY,IZ,K,ITPNMX,LTWCEN)=
     *                     PD_GRR(IX,IY,IZ,K,ITPNMX,LTWCEN)
     *                     +SIMFAC*(PAUPUP(K,0)+PAUPUP(0,K)
     *                             +PADWDW(K,0)+PADWDW(0,K))
                       PP_GRR(IX,IY,IZ,K,ITPNMX,LTWCEN)=
     *                     PP_GRR(IX,IY,IZ,K,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PCUPUP(K,0)+PCUPUP(0,K)
     *                            +PCDWDW(K,0)+PCDWDW(0,K))
C
                       PD_SCU(IX,IY,IZ,K,1,ITPNMX,LTWCEN)=
     *                    PD_SCU(IX,IY,IZ,K,1,ITPNMX,LTWCEN)
     *                    +SIMFAC*((PAUPDW(K,0)-PAUPDW(0,K))
     *                            +(PADWUP(K,0)-PADWUP(0,K)))
     *                    /2/UNIT_I
                       PP_SCU(IX,IY,IZ,K,1,ITPNMX,LTWCEN)=
     *                    PP_SCU(IX,IY,IZ,K,1,ITPNMX,LTWCEN)
     *                    +SIMFAC*((PCUPDW(K,0)-PCUPDW(0,K))
     *                            +(PCDWUP(K,0)-PCDWUP(0,K)))
     *                    /2/UNIT_I
C
                       PD_SCU(IX,IY,IZ,K,2,ITPNMX,LTWCEN)=
     *                    PD_SCU(IX,IY,IZ,K,2,ITPNMX,LTWCEN)
     *                    +SIMFAC*((PAUPDW(K,0)-PAUPDW(0,K))
     *                            -(PADWUP(K,0)-PADWUP(0,K)))
     *                    /2
                       PP_SCU(IX,IY,IZ,K,2,ITPNMX,LTWCEN)=
     *                    PP_SCU(IX,IY,IZ,K,2,ITPNMX,LTWCEN)
     *                    +SIMFAC*((PCUPDW(K,0)-PCUPDW(0,K))
     *                            -(PCDWUP(K,0)-PCDWUP(0,K)))
     *                    /2
C
                       PD_SCU(IX,IY,IZ,K,3,ITPNMX,LTWCEN)=
     *                    PD_SCU(IX,IY,IZ,K,3,ITPNMX,LTWCEN)
     *                    +SIMFAC*((PAUPUP(K,0)-PAUPUP(0,K))
     *                            -(PADWDW(K,0)-PADWDW(0,K)))
     *                    /2/UNIT_I
                       PP_SCU(IX,IY,IZ,K,3,ITPNMX,LTWCEN)=
     *                    PP_SCU(IX,IY,IZ,K,3,ITPNMX,LTWCEN)
     *                    +SIMFAC*((PCUPUP(K,0)-PCUPUP(0,K))
     *                            -(PCDWDW(K,0)-PCDWDW(0,K)))
     *                   /2/UNIT_I
C
                     END DO!K=1,NDKART
C
                     IF (IGRAIN.EQ.1) THEN
C
C=======================================================================
C           ATTENTION: AFTER THE WORK ON 3BODY GRADIENTS HAS STARTED  IN
C                      VERSION 2.85A, AND UP TO  VERSION  2.97E,  SWITCH
C                      "IGRAIN" WAS NOT TRANSFERRED  TO  "DENSHF".  THIS
C                      BUG WAS CORRECTED ON 18/07/2020 IN VERSION 2.97F.
C=======================================================================
C
                         PD_DIS(IX,IY,IZ,1,ITPNMX,LTWCEN)=
     *                   PD_DIS(IX,IY,IZ,1,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PLUPDW     +PLDWUP
     *                            -PAUPDW(1,1)-PADWUP(1,1)
     *                            -PAUPDW(2,2)-PADWUP(2,2)
     *                            -PAUPDW(3,3)-PADWUP(3,3))
     *                                    /2/UNIT_I
C
                         PD_DIS(IX,IY,IZ,2,ITPNMX,LTWCEN)=
     *                   PD_DIS(IX,IY,IZ,2,ITPNMX,LTWCEN)
     *                    -SIMFAC*(PLUPDW     -PLDWUP
     *                            -PAUPDW(1,1)+PADWUP(1,1)
     *                            -PAUPDW(2,2)+PADWUP(2,2)
     *                            -PAUPDW(3,3)+PADWUP(3,3))
     *                                    /2
C
                         PD_DIS(IX,IY,IZ,3,ITPNMX,LTWCEN)=
     *                   PD_DIS(IX,IY,IZ,3,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PLUPUP     -PLDWDW
     *                            -PAUPUP(1,1)+PADWDW(1,1)
     *                            -PAUPUP(2,2)+PADWDW(2,2)
     *                            -PAUPUP(3,3)+PADWDW(3,3))
     *                                    /2/UNIT_I
C
                         PP_DIS(IX,IY,IZ,1,ITPNMX,LTWCEN)=
     *                   PP_DIS(IX,IY,IZ,1,ITPNMX,LTWCEN)
     *                    +SIMFAC*(CLUPDW     +CLDWUP
     *                            -PCUPDW(1,1)-PCDWUP(1,1)
     *                            -PCUPDW(2,2)-PCDWUP(2,2)
     *                            -PCUPDW(3,3)-PCDWUP(3,3))
     *                                    /2/UNIT_I
C
                         PP_DIS(IX,IY,IZ,2,ITPNMX,LTWCEN)=
     *                   PP_DIS(IX,IY,IZ,2,ITPNMX,LTWCEN)
     *                    -SIMFAC*(CLUPDW     -CLDWUP
     *                            -PCUPDW(1,1)+PCDWUP(1,1)
     *                            -PCUPDW(2,2)+PCDWUP(2,2)
     *                            -PCUPDW(3,3)+PCDWUP(3,3))
     *                                    /2
C
                         PP_DIS(IX,IY,IZ,3,ITPNMX,LTWCEN)=
     *                   PP_DIS(IX,IY,IZ,3,ITPNMX,LTWCEN)
     *                    +SIMFAC*(CLUPUP     -CLDWDW
     *                            -PCUPUP(1,1)+PCDWDW(1,1)
     *                            -PCUPUP(2,2)+PCDWDW(2,2)
     *                            -PCUPUP(3,3)+PCDWDW(3,3))
     *                                    /2/UNIT_I
C
                     END IF
C
C                    END OF BLOCK INDENTED BY ADDITIONAL 2 SPACES
C
C=======================================================================
C              HERE ENDS THE PART EXECUTED ONLY FOR IPAHFB=1
C=======================================================================
C
               END IF ! end if IPAHFB=1
C
C               THIS MUST BE PROGRAMMED FOR THE CANONICAL BASIS
C
               IF (IPAHFB.EQ.2) THEN
C
C=======================================================================
C                  CALCULATING   THE   SCALAR P-P DENSITIES
C=======================================================================
C
                                                   SIMFAC=2.0d0
                   IF (IKERNE.EQ.1.OR.ISIMPY.EQ.0) SIMFAC=1.0d0
C
                     PD_RHO(IX,IY,IZ,ITPNMX,LTWCEN)=
     *                    PD_RHO(IX,IY,IZ,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PAUPUP(0,0)+PADWDW(0,0))
                     PP_RHO(IX,IY,IZ,ITPNMX,LTWCEN)=
     *                    PP_RHO(IX,IY,IZ,ITPNMX,LTWCEN)
     *                    +SIMFAC*(PCUPUP(0,0)+PCDWDW(0,0))
C
C=======================================================================
C              HERE ENDS THE PART EXECUTED ONLY FOR IPAHFB=2
C=======================================================================
C
               END IF ! end if IPAHFB=2
C
C=======================================================================
C              HERE WE ENFORCE THE TIME-REVERSAL SYMMETRY IN THE PAIRING
C              CHANNEL
C=======================================================================
C
               IF (ITIREP.EQ.1) THEN
C
                              PD_RHO(IX,IY,IZ,ITPNMX,LTWCEN)=
     *             CMPLX(REAL(PD_RHO(IX,IY,IZ,ITPNMX,LTWCEN)),ZERO)
                              PD_TAU(IX,IY,IZ,ITPNMX,LTWCEN)=
     *             CMPLX(REAL(PD_TAU(IX,IY,IZ,ITPNMX,LTWCEN)),ZERO)
                              PD_LPR(IX,IY,IZ,ITPNMX,LTWCEN)=
     *             CMPLX(REAL(PD_LPR(IX,IY,IZ,ITPNMX,LTWCEN)),ZERO)
C
                              PD_GRR(IX,IY,IZ,:,ITPNMX,LTWCEN)=
     *             CMPLX(REAL(PD_GRR(IX,IY,IZ,:,ITPNMX,LTWCEN)),ZERO)
                   IF (IGRAIN.EQ.1)
     *                        PD_DIS(IX,IY,IZ,:,ITPNMX,LTWCEN)=
     *             CMPLX(REAL(PD_DIS(IX,IY,IZ,:,ITPNMX,LTWCEN)),ZERO)
C
                              PD_SCU(IX,IY,IZ,:,:,ITPNMX,LTWCEN)=
     *             CMPLX(REAL(PD_SCU(IX,IY,IZ,:,:,ITPNMX,LTWCEN)),ZERO)
C
               END IF
C
C=======================================================================
C              ENDING THE DO-LOOPS OVER THE CARTESIAN POINTS
C=======================================================================
C
            END DO ! END OF LOOP OVER IX
         END DO ! END OF LOOP OVER IY
!$OMP END DO
!$OMP END PARALLEL
      END DO ! END OF LOOP OVER IZ
C
C=======================================================================
C         HERE WE THE PUT TENSOR PAIRING DENSITIES TO ZERO - FOR TESTING
C=======================================================================
C
C     PP_SCU=C_ZERO
C     PD_SCU=C_ZERO
C
C=======================================================================
C
      DEALLOCATE(HRIGHE,HRIGDH,HRIGDD,STAT=I_FAIL)
      IF (I_FAIL.NE.0) THEN
          WRITE(6,'("Error in DEALLOCATING arrays - DENSHF")')
          STOP 'Error in DEALLOCATION'
      END IF
      IF (IKERNE.EQ.1) THEN
          DEALLOCATE(HLEFHE,HLEFDH,HLEFDD,STAT=I_FAIL)
          IF (I_FAIL.NE.0) THEN
              WRITE(6,'("Error in DEALLOCATING arrays - DENSHF")')
              STOP 'Error in DEALLOCATION'
          END IF
      END IF
C
C=======================================================================
C         ATTENTION: IN THE VERSIONS  BETWEEN  2.22N  AND  2.37T,  ARRAY
C                    "WARIGH" WAS NOT BELOW MULTIPLIED BY THE OCCUPATION
C                    PROBABILITIES. AS  A  RESULT,  THE  DENSITY  MATRIX
C                    CALCULATED BY "DENMAC" WAS INCORRECT FOR  IDEVAR=1.
C                    THIS BUG HAS BEEN CORRECTED  IN  VERSION  2.37U  ON
C                    13/12/08.
C         ATTENTION: IN THE VERSIONS 2.49L AND X.XXx, ARRAY "WARIGH" WAS
C                    INCORRECTLY MULTIPLIED BY THE OCCUPATION PROBABILI-
C                    TIES AT FINITE-TEMPERATURE.
C=======================================================================
C
      IF (IDEVAR.EQ.1.AND.IPAHFB.LT.1) THEN
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
          IF (IFTEMP.EQ.0) THEN
C
              DO ISPIN=0,NDSPIN
                 DO ISTATE=1,LSTATE
                    DO IBASE=1,LDBASE
C
                       WARIGH(IBASE,ISTATE,ISPIN)=
     *                 WARIGH(IBASE,ISTATE,ISPIN)*V1OCCU(ISTATE)
C
                    END DO
                 END DO
              END DO
C
          ELSE
C
                 JSTATE=LSTATE
              DO ISTATE=1,LSTATE
                 JSTATE=JSTATE+1
C
                 U1OCCU=SQRT(1.0D0-V1OCCU(ISTATE)**2)
C
                 DO IBASE=1,LDBASE
                    DO ISPIN=0,NDSPIN
C
                       WARIGH(IBASE,JSTATE,ISPIN)=
     *                 WARIGH(IBASE,JSTATE,ISPIN)*U1OCCU
C
                    END DO
                 END DO
C
              END DO
C
              LDSTAT(ICHARG)=LSTATE/2
              LDUPPE(ICHARG)=LUPPER
              LDTIMU(ICHARG)=LTIMUP/2
C
          END IF ! end if IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
      END IF ! end if IDEVAR
C
C=======================================================================
C         TESTING FOR THE PRESENCE OF ANY OF THE THREE PLANE SYMMETRIES.
C         SYMDEN AND SYMPAI CAN BE CALLED ONLY WHEN THE CALCULATIONS FOR
C         THE WHOLE BOX ARE PERFORMED.  THIS CAN BE DONE BY SETTING  THE
C         PARAMETER ISYMDE=1 IN THE INPUT DATA.
C=======================================================================
C
      IF (NDALLD.NE.4+14*NDKART) STOP ' WRONG DIMENSIONS IN DENSHF'
C
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,1)
     *        =DE_RHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,2)
     *        =DE_TAU(1:NDXHRM,1:NDYHRM,1:NDZHRM,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,3)
     *        =DE_LPR(1:NDXHRM,1:NDYHRM,1:NDZHRM,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,4)
     *        =DE_DIV(1:NDXHRM,1:NDYHRM,1:NDZHRM,ITPNMX,LTWCEN)
C
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM, 4          +1: 4+  NDKART)
     *        =DE_SPI(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+  NDKART)+1:(4+2*NDKART))
     *        =DE_KIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+2*NDKART)+1:(4+3*NDKART))
     *        =DE_GRR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+3*NDKART)+1:(4+4*NDKART))
     *        =DE_LPS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+4*NDKART)+1:(4+5*NDKART))
     *        =DE_ROS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+5*NDKART)+1:(4+6*NDKART))
     *        =DE_ROC(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+6*NDKART)+1:(4+7*NDKART))
     *        =DE_CUR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+7*NDKART)+1:(4+8*NDKART))
     *        =DE_KIF(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
C
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+ 8*NDKART)+1:(4+ 9*NDKART))
     *      =DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+ 9*NDKART)+1:(4+10*NDKART))
     *      =DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+10*NDKART)+1:(4+11*NDKART))
     *      =DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+11*NDKART)+1:(4+12*NDKART))
     *      =DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+12*NDKART)+1:(4+13*NDKART))
     *      =DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2,ITPNMX,LTWCEN)
      DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,(4+13*NDKART)+1:(4+14*NDKART))
     *      =DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,ITPNMX,LTWCEN)
C
      IF (PRINIT.AND.ISYMDE.EQ.1) THEN
C
          CALL SYMDEN(DENALL,NAMEPN)
C
          IF (IPAHFB.GE.1)
     *
     *        CALL SYMPAI(ITPNMX)
C
      END IF
C
C=======================================================================
C         THE UNCALCULATED PARTS OF THE BOX ARE HERE COPIED FROM THE
C         CALCULATED PARTS.  THIS IS DONE ACCORDING TO THE TABLES OF
C         SYMMETRIES DEFINED EXPLICITLY IN COPDEN AND COPPAI.
C=======================================================================
C
      IF (DOSYME) THEN
C
          CALL COPDEN(DENALL,ISIGNY,ISIMPY,ISIQTY,ISIMTX,JSIMTY,ISIMTZ)
C
          IF (IPAHFB.GE.1)
     *
     *        CALL COPPAI(ITPNMX,IKERNE,
     *                    ISIGNY,ISIMPY,ISIQTY,ISIMTX,JSIMTY,ISIMTZ)
C
          DE_RHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,1)
          DE_TAU(1:NDXHRM,1:NDYHRM,1:NDZHRM,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,2)
          DE_LPR(1:NDXHRM,1:NDYHRM,1:NDZHRM,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,3)
          DE_DIV(1:NDXHRM,1:NDYHRM,1:NDZHRM,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,4)
C
          DE_SPI(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                      4          +1:4+  NDKART)
          DE_KIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+  NDKART)+1:(4+2*NDKART))
          DE_GRR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+2*NDKART)+1:(4+3*NDKART))
          DE_LPS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+3*NDKART)+1:(4+4*NDKART))
          DE_ROS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+4*NDKART)+1:(4+5*NDKART))
          DE_ROC(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+5*NDKART)+1:(4+6*NDKART))
          DE_CUR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+6*NDKART)+1:(4+7*NDKART))
          DE_KIF(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+7*NDKART)+1:(4+8*NDKART))
C
          DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+ 8*NDKART)+1:(4+ 9*NDKART))
          DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+ 9*NDKART)+1:(4+10*NDKART))
          DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+10*NDKART)+1:(4+11*NDKART))
          DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+11*NDKART)+1:(4+12*NDKART))
          DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,2,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+12*NDKART)+1:(4+13*NDKART))
          DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,3,ITPNMX,LTWCEN)
     *            =DENALL(1:NDXHRM,1:NDYHRM,1:NDZHRM,
     *                    (4+13*NDKART)+1:(4+14*NDKART))
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('DENSHF',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE COPDEN(DENALL,ISIGNY,ISIMPY,ISIQTY,ISIMTX,JSIMTY,
     *                                                     ISIMTZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          DENALL(NDXHRM,NDYHRM,NDZHRM,NDALLD)
      DIMENSION
     *          ISYDEN(NDKART,NDTYDE,       NDALLD)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
      DATA (((ISYDEN(KARTEZ,ITYDEN,NUMDEN),KARTEZ=1,NDKART),
     *                                     ITYDEN=1,NDTYDE),
     *                                     NUMDEN=1,NDALLD)
     *
     *                            /  1,  1,  1,    1,  1,  1,
     *                               1,  1,  1,    1,  1,  1,
     *                               1,  1,  1,    1,  1,  1,
     *                               1,  1,  1,    1,  1,  1,
     *                              -1, -1,  1,    1,  1, -1,
     *                               1,  1,  1,   -1, -1, -1,
     *                               1, -1, -1,   -1,  1,  1,
     *                              -1, -1,  1,    1,  1, -1,
     *                               1,  1,  1,   -1, -1, -1,
     *                               1, -1, -1,   -1,  1,  1,
     *                              -1,  1,  1,   -1,  1,  1,
     *                               1, -1,  1,    1, -1,  1,
     *                               1,  1, -1,    1,  1, -1,
     *                              -1, -1,  1,    1,  1, -1,
     *                               1,  1,  1,   -1, -1, -1,
     *                               1, -1, -1,   -1,  1,  1,
     *                               1,  1, -1,   -1, -1,  1,
     *                              -1, -1, -1,    1,  1,  1,
     *                              -1,  1,  1,    1, -1, -1,
     *                              -1, -1,  1,    1,  1, -1,
     *                               1,  1,  1,   -1, -1, -1,
     *                               1, -1, -1,   -1,  1,  1,
     *                               1,  1, -1,   -1, -1,  1,
     *                              -1, -1, -1,    1,  1,  1,
     *                              -1,  1,  1,    1, -1, -1,
     *                              -1, -1,  1,    1,  1, -1, ! KIF
     *                               1,  1,  1,   -1, -1, -1, ! KIF
     *                               1, -1, -1,   -1,  1,  1, ! KIF
     *                              -1, -1, -1,   -1, -1, -1,
     *                               1,  1, -1,    1,  1, -1,
     *                               1, -1,  1,    1, -1,  1,
     *                               1,  1, -1,    1,  1, -1,
     *                              -1, -1, -1,   -1, -1, -1,
     *                              -1,  1,  1,   -1,  1,  1,
     *                               1, -1,  1,    1, -1,  1,
     *                              -1,  1,  1,   -1,  1,  1,
     *                              -1, -1, -1,   -1, -1, -1,
     *                               1, -1,  1,   -1,  1, -1,
     *                              -1,  1,  1,    1, -1, -1,
     *                              -1, -1, -1,    1,  1,  1,
     *                              -1,  1,  1,    1, -1, -1,
     *                               1, -1,  1,   -1,  1, -1,
     *                               1,  1, -1,   -1, -1,  1,
     *                              -1, -1, -1,    1,  1,  1,
     *                               1,  1, -1,   -1, -1,  1,
     *                               1, -1,  1,   -1,  1, -1  /
C
C=======================================================================
C        THIS SUBROUTINE COPIES THE DENSITIES CALCULATED  IN  DENSHF
C        IN PARTS OF THE BOX INTO THE UNCALCULATED PARTS OF THE BOX,
C        ACCORDING TO THE TABLE OF SYMMETRIES DEFINED ABOVE  IN  THE
C        "ISYDEN" ARRAY.
C
C        ATTENTION: THE FIRST DUMMY ARGUMENT IS USED FOR ALL DENSITIES
C=======================================================================
C
      IF (ISIMTX.EQ.1) THEN
C
          ITYDEN=1
C
C=======================================================================
C         SYMMETRY IN THE X-DIRECTION
C
C         ATTENTION: IN THE PREVIOUS VERSIONS OF THE CODE, STARTING FROM
C                    VERSION 1.82N AND UP TO VERSION 1.98G  THE  COMMAND
C                    "IHABOY=2" BELOW WAS INCORRECTLY CODED  AS  COMMAND
C                    "IHABOZ=2". AS A RESULT, THE CODE  WAS NOT  WORKING
C                    PROPERLY WHENEVER, AND  O N L Y WHEN, THE REQUESTED
C                    SYMMETRIES WHERE  ISIMTX=1 AND ISIMTZ=0.  THIS  BUG
C                    WAS CORRECTED IN VERSION 1.98H (18/06/02).
C
C=======================================================================
C
                           IHABOZ=1
          IF (ISIMTZ.EQ.1) IHABOZ=2
          IF (ISIGNY.EQ.1) IHABOZ=2
          IF (ISIQTY.EQ.1) IHABOZ=2
C
                           IHABOY=1
          IF (ISIMPY.EQ.1) IHABOY=2
          IF (JSIMTY.EQ.1) IHABOY=2
C
                           IHABOX=2
C
          DO IZ=1,NZHERM/IHABOZ
             DO IY=1,NYHERM/IHABOY
                DO IX=1,NXHERM/IHABOX
C
                   IXREFL=NXHERM+1-IX
C
                   DO NUMDEN=1,NDALLD
C
                     DENALL(IXREFL,IY,IZ,NUMDEN)=ISYDEN(1,ITYDEN,NUMDEN)
     *                                          *DENALL(IX,IY,IZ,NUMDEN)
C
                   END DO
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      IF (ISIMPY.EQ.1.OR.JSIMTY.EQ.1) THEN
C
          IF (JSIMTY.EQ.1) ITYDEN=2
          IF (ISIMPY.EQ.1) ITYDEN=1
C
C=======================================================================
C         SYMMETRY IN THE Y-DIRECTION
C=======================================================================
C
                           IHABOZ=1
          IF (ISIMTZ.EQ.1) IHABOZ=2
          IF (ISIGNY.EQ.1) IHABOZ=2
          IF (ISIQTY.EQ.1) IHABOZ=2
C
                           IHABOY=2
C
                           IHABOX=1
C
          DO IX=1,NXHERM/IHABOX
             DO IZ=1,NZHERM/IHABOZ
                DO IY=1,NYHERM/IHABOY
C
                   IYREFL=NYHERM+1-IY
C
                   DO NUMDEN=1,NDALLD
C
                     DENALL(IX,IYREFL,IZ,NUMDEN)=ISYDEN(2,ITYDEN,NUMDEN)
     *                                          *DENALL(IX,IY,IZ,NUMDEN)
C
                   END DO
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      IF (ISIMTZ.EQ.1) THEN
C
          ITYDEN=1
C
C=======================================================================
C         SYMMETRY IN THE Z-DIRECTION
C=======================================================================
C
          IHABOZ=2
C
          IHABOY=1
C
          IHABOX=1
C
          DO IX=1,NXHERM/IHABOX
             DO IY=1,NYHERM/IHABOY
                DO IZ=1,NZHERM/IHABOZ
C
                   IZREFL=NZHERM+1-IZ
C
                   DO NUMDEN=1,NDALLD
C
                     DENALL(IX,IY,IZREFL,NUMDEN)=ISYDEN(3,ITYDEN,NUMDEN)
     *                                          *DENALL(IX,IY,IZ,NUMDEN)
C
                   END DO
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      IF (ISIGNY.EQ.1) THEN
C
          ITYDEN=1
C
C=======================================================================
C         SYMMETRIZATION WITH RESPECT TO THE Y-SIGNATURE
C=======================================================================
C
          IHABOZ=2
C
          IHABOY=1
C
          IHABOX=1
C
          DO IY=1,NYHERM/IHABOY
             DO IX=1,NXHERM/IHABOX
                DO IZ=1,NZHERM/IHABOZ
C
                   IXREFL=NXHERM+1-IX
                   IZREFL=NZHERM+1-IZ
C
                   DO NUMDEN=1,NDALLD
C
                     DENALL(IXREFL,IY,IZREFL,NUMDEN)
     *                                          =ISYDEN(1,ITYDEN,NUMDEN)
     *                                          *ISYDEN(3,ITYDEN,NUMDEN)
     *                                          *DENALL(IX,IY,IZ,NUMDEN)
C
                   END DO
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      IF (ISIQTY.EQ.1) THEN
C
          ITYDEN=1
C
C=======================================================================
C         SYMMETRIZATION WITH RESPECT TO THE PARITY
C=======================================================================
C
          IHABOZ=2
C
          IHABOY=1
C
          IHABOX=1
C
          DO IY=1,NYHERM/IHABOY
             DO IX=1,NXHERM/IHABOX
                DO IZ=1,NZHERM/IHABOZ
C
                   IXREFL=NXHERM+1-IX
                   IYREFL=NYHERM+1-IY
                   IZREFL=NZHERM+1-IZ
C
                   DO NUMDEN=1,NDALLD
C
                     DENALL(IXREFL,IYREFL,IZREFL,NUMDEN)
     *                                          =ISYDEN(1,ITYDEN,NUMDEN)
     *                                          *ISYDEN(2,ITYDEN,NUMDEN)
     *                                          *ISYDEN(3,ITYDEN,NUMDEN)
     *                                          *DENALL(IX,IY,IZ,NUMDEN)
C
                   END DO
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE COPPAI(ITPNMX,IKERNE,
     *                  ISIGNY,ISIMPY,ISIQTY,ISIMTX,JSIMTY,ISIMTZ)
C=======================================================================
      USE PD_DEN
      USE PP_DEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      DIMENSION
     *          ISYPAI(NDKART)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
      DATA (ISYPAI(KARTEZ),KARTEZ=1,NDKART)
     *
     *                            /  1,  1,  1  /
C
C=======================================================================
C        THIS SUBROUTINE COPIES THE DENSITIES CALCULATED  IN  DENSHF
C        IN PARTS OF THE BOX INTO THE UNCALCULATED PARTS OF THE BOX,
C        ACCORDING TO THE TABLE OF SYMMETRIES DEFINED ABOVE  IN  THE
C        "ISYPAI" ARRAY.
C
C        ATTENTION: THE FIRST DUMMY ARGUMENT IS USED FOR ALL DENSITIES
C
C        ATTENTION:  THIS SUBROUTINE IS NOT READY FOR  SWITCHING  THE
C                    CALCULATION OF THESE OTHER DENSITIES ON.
C
C        ATTENTION:  UP TO VERSION 2.00E THE IMAGINARY PARTS  OF  THE
C                    PAIRING DENSITIES WERE COPPIED  WITH  THE  WRONG
C                    SIGNS (X- AND Z-DIRECTIONS ONLY). THIS  BUG  WAS
C                    CORRECTED ON  12/07/2002  IN VERSION 2.00F.
C        ATTENTION:  THE ABOVE STILL REMAINS TO BE CHECKED (12/07/2002).
C
C        TL 11/2012: IT WOULD BE A GOOD TIME TO MAKE SURE :^)
C                    ADDED CODE FOR PP_RHO IN ADDITION TO PD_RHO
C                    REMOVED CONJG() IN COPY FOR T-SIMPLEX IF KERNEL
C                    CALCULATION (WITH T-SYMMETRY)
C=======================================================================
C
C     ICONJG determines whether the imaginary part is flipped on
C     copy/symmetrization
                       ICONJG = 1
      IF (IKERNE.EQ.1) ICONJG = 0
C
C=======================================================================
C
      IF (ISIMTX.EQ.1) THEN
C
C=======================================================================
C         SYMMETRY IN THE X-DIRECTION
C=======================================================================
C
                           IHABOZ=1
          IF (ISIMTZ.EQ.1) IHABOZ=2
          IF (ISIGNY.EQ.1) IHABOZ=2
          IF (ISIQTY.EQ.1) IHABOZ=2
C
                           IHABOY=1
          IF (ISIMPY.EQ.1) IHABOY=2
          IF (JSIMTY.EQ.1) IHABOY=2
C
                           IHABOX=2
C
          DO IZ=1,NZHERM/IHABOZ
             DO IY=1,NYHERM/IHABOY
                DO IX=1,NXHERM/IHABOX
C
                   IXREFL=NXHERM+1-IX
C
                   PD_RHO(IXREFL,IY,IZ,ITPNMX,1)
     *               =ISYPAI(1)
     *                *((1-ICONJG)*PD_RHO(IX,IY,IZ,ITPNMX,1)
     *                  +ICONJG*CONJG(PD_RHO(IX,IY,IZ,ITPNMX,1)))
C
                   PP_RHO(IXREFL,IY,IZ,ITPNMX,1)
     *               =ISYPAI(1)
     *                *((1-ICONJG)*PP_RHO(IX,IY,IZ,ITPNMX,1)
     *                  +ICONJG*CONJG(PP_RHO(IX,IY,IZ,ITPNMX,1)))
C
                END DO
             END DO
          END DO
C
      END IF
C
      IF (ISIMPY.EQ.1.OR.JSIMTY.EQ.1) THEN
C
C=======================================================================
C        SYMMETRY IN THE Y-DIRECTION
C=======================================================================
C
                           IHABOZ=1
          IF (ISIMTZ.EQ.1) IHABOZ=2
          IF (ISIGNY.EQ.1) IHABOZ=2
          IF (ISIQTY.EQ.1) IHABOZ=2
C
                           IHABOY=2
C
                           IHABOX=1
C
          DO IZ=1,NZHERM/IHABOZ
             DO IY=1,NYHERM/IHABOY
                DO IX=1,NXHERM/IHABOX
C
                   IYREFL=NYHERM+1-IY
C
                   IF (JSIMTY.EQ.1) THEN
                       PD_RHO(IX,IYREFL,IZ,ITPNMX,1)
     *                        =ISYPAI(2)
     *                        *((1-ICONJG)*PD_RHO(IX,IY,IZ,ITPNMX,1)
     *                        +ICONJG*CONJG(PD_RHO(IX,IY,IZ,ITPNMX,1)))
                       PP_RHO(IX,IYREFL,IZ,ITPNMX,1)
     *                        =ISYPAI(2)
     *                        *((1-ICONJG)*PP_RHO(IX,IY,IZ,ITPNMX,1)
     *                        +ICONJG*CONJG(PP_RHO(IX,IY,IZ,ITPNMX,1)))
                   END IF
C
                   IF (ISIMPY.EQ.1) THEN
                       PD_RHO(IX,IYREFL,IZ,ITPNMX,1)
     *                        =ISYPAI(2)
     *                        *PD_RHO(IX,IY,IZ,ITPNMX,1)
                       PP_RHO(IX,IYREFL,IZ,ITPNMX,1)
     *                        =ISYPAI(2)
     *                        *PP_RHO(IX,IY,IZ,ITPNMX,1)
                   END IF
C
                END DO
             END DO
          END DO
C
      END IF
C
      IF (ISIMTZ.EQ.1) THEN
C
C=======================================================================
C         SYMMETRY IN THE Z-DIRECTION
C=======================================================================
C
          IHABOZ=2
C
          IHABOY=1
C
          IHABOX=1
C
          DO IZ=1,NZHERM/IHABOZ
             DO IY=1,NYHERM/IHABOY
                DO IX=1,NXHERM/IHABOX
C
                   IZREFL=NZHERM+1-IZ
C
                   PD_RHO(IX,IY,IZREFL,ITPNMX,1)
     *               =ISYPAI(3)
     *               *((1-ICONJG)*PD_RHO(IX,IY,IZ,ITPNMX,1)
     *                 +ICONJG*CONJG(PD_RHO(IX,IY,IZ,ITPNMX,1)))
C
                   PP_RHO(IX,IY,IZREFL,ITPNMX,1)
     *               =ISYPAI(3)
     *               *((1-ICONJG)*PP_RHO(IX,IY,IZ,ITPNMX,1)
     *                 +ICONJG*CONJG(PP_RHO(IX,IY,IZ,ITPNMX,1)))
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      IF (ISIGNY.EQ.1) THEN
C
C=======================================================================
C         SYMMETRIZATION WITH RESPECT TO THE Y-SIGNATURE
C=======================================================================
C
          IHABOZ=2
C
          IHABOY=1
C
          IHABOX=1
C
          DO IZ=1,NZHERM/IHABOZ
             DO IY=1,NYHERM/IHABOY
                DO IX=1,NXHERM/IHABOX
C
                   IXREFL=NXHERM+1-IX
                   IZREFL=NZHERM+1-IZ
C
                   PD_RHO(IXREFL,IY,IZREFL,ITPNMX,1)
     *            =ISYPAI(1)*ISYPAI(3)
     *            *PD_RHO(IX,IY,IZ,ITPNMX,1)
C
                   PP_RHO(IXREFL,IY,IZREFL,ITPNMX,1)
     *            =ISYPAI(1)*ISYPAI(3)
     *            *PP_RHO(IX,IY,IZ,ITPNMX,1)
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      IF (ISIQTY.EQ.1) THEN
C
C=======================================================================
C         SYMMETRIZATION WITH RESPECT TO THE PARITY
C=======================================================================
C
          IHABOZ=2
C
          IHABOY=1
C
          IHABOX=1
C
          DO IZ=1,NZHERM/IHABOZ
             DO IY=1,NYHERM/IHABOY
                DO IX=1,NXHERM/IHABOX
C
                   IXREFL=NXHERM+1-IX
                   IYREFL=NYHERM+1-IY
                   IZREFL=NZHERM+1-IZ
C
                   PD_RHO(IXREFL,IYREFL,IZREFL,ITPNMX,1)
     *                                              =ISYPAI(1)
     *                                              *ISYPAI(2)
     *                                              *ISYPAI(3)
     *                              *PD_RHO(IX,IY,IZ,ITPNMX,1)
C
                   PP_RHO(IXREFL,IYREFL,IZREFL,ITPNMX,1)
     *                                              =ISYPAI(1)
     *                                              *ISYPAI(2)
     *                                              *ISYPAI(3)
     *                              *PP_RHO(IX,IY,IZ,ITPNMX,1)
C
                END DO
             END DO
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SYMDEN(DENALL,NAMEPN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CSYDEN*4
      CHARACTER
     *          NAMEPN*8
C
      COMPLEX
     *          DENALL(NDXHRM,NDYHRM,NDZHRM,NDALLD)
      DIMENSION
     *          SYMALL(NDKART,NDHALF,       NDALLD)
      DIMENSION
     *          CSYDEN(NDKART,              NDALLD)
C
      COMMON
     *       /INTMEM/ TWOWGT(1:NDGAUS,1:NDKART),
     *                TWOPNT(1:NDGAUS,1:NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE DETERMINES SYMMETRIES  OF THE SKYRME FUNCTIONAL
C        DENSITIES. ONLY THE REAL PARTS OF DENSITIES ARE CONSIDERED.
C        ATTENTION: THE FIRST DUMMY ARGUMENT IS USED FOR ALL DENSITIES
C=======================================================================
C
      SYMALL(:,:,:)=0.0D0
C
C=======================================================================
C        SYMMETRY IN THE X-DIRECTION
C=======================================================================
C
      DO IZ=1,NZHERM/2
         DO IY=1,NYHERM/2
C
            DO NUHALF=1,NDHALF
               DO IX=1+(NUHALF-1)*NXHERM/2,NUHALF*NXHERM/2
C
                  W_HERM=TWOWGT(IX,1)*TWOWGT(IY,2)*TWOWGT(IZ,3)
C
                  DO NUMDEN=1,NDALLD
C
                     SYMALL(1,NUHALF,NUMDEN)=SYMALL(1,NUHALF,NUMDEN)
     *                                 +REAL(DENALL(IX,IY,IZ,NUMDEN))
     *                                      *W_HERM
C
                  END DO
C
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        SYMMETRY IN THE Y-DIRECTION
C=======================================================================
C
      DO IZ=1,NZHERM/2
         DO IX=1,NXHERM/2
C
            DO NUHALF=1,NDHALF
               DO IY=1+(NUHALF-1)*NYHERM/2,NUHALF*NYHERM/2
C
                  W_HERM=TWOWGT(IX,1)*TWOWGT(IY,2)*TWOWGT(IZ,3)
C
                  DO NUMDEN=1,NDALLD
C
                     SYMALL(2,NUHALF,NUMDEN)=SYMALL(2,NUHALF,NUMDEN)
     *                                 +REAL(DENALL(IX,IY,IZ,NUMDEN))
     *                                      *W_HERM
C
                  END DO
C
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        SYMMETRY IN THE Z-DIRECTION
C=======================================================================
C
      DO IY=1,NYHERM/2
         DO IX=1,NXHERM/2
C
            DO NUHALF=1,NDHALF
               DO IZ=1+(NUHALF-1)*NZHERM/2,NUHALF*NZHERM/2
C
                  W_HERM=TWOWGT(IX,1)*TWOWGT(IY,2)*TWOWGT(IZ,3)
C
                  DO NUMDEN=1,NDALLD
C
                     SYMALL(3,NUHALF,NUMDEN)=SYMALL(3,NUHALF,NUMDEN)
     *                                 +REAL(DENALL(IX,IY,IZ,NUMDEN))
     *                                      *W_HERM
C
                  END DO
C
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        DETERMINING THE SYMMETRY
C=======================================================================
C
      DO KARTEZ=1,NDKART
         DO NUMDEN=1,NDALLD
C
            IF (SYMALL(KARTEZ,1,NUMDEN).EQ.0.0) THEN
C
                CSYDEN(KARTEZ,NUMDEN)='ZERO'
C
            ELSE
C
                DIVIDE=SYMALL(KARTEZ,2,NUMDEN)/SYMALL(KARTEZ,1,NUMDEN)
C
                IF (ABS(ABS(DIVIDE)-1.0).LT.1.E-6) THEN
C
                    IF (DIVIDE.GT.0.0) THEN
                        CSYDEN(KARTEZ,NUMDEN)=' +1 '
                    ELSE
                        CSYDEN(KARTEZ,NUMDEN)=' -1 '
                    END IF
C
                ELSE
                    CSYDEN(KARTEZ,NUMDEN)='NONE'
                END IF
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        PRINTING
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                    1H*,77X,1H*,/,
     *                 1H*,2X,''SYMMETRIES OF THE SKYRME DENSITIES'',
     *                        ''                               '',
     *                                               A8,2X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/,
     *                 1H*,''  N '',3(1H*,23X),         1X,1H*,/,
     *                 1H*,''  U '',1H*,'' X - PLANE  REFLECTION '',
     *                              1H*,'' Y - PLANE  REFLECTION '',
     *                              1H*,'' Z - PLANE  REFLECTION '',
     *                                                  1X,1H*,/,
     *                 1H*,''  M '',3(1H*,23X),         1X,1H*,/,
     *                                                 79(1H*),/,
     *              46(1H*,1X,I2,3(1X,2(1PE9.1),1X,A4),2X,1H*,/),
     *                                                  79(1H*),/)')
     *     NAMEPN,
     *    (NUMDEN,((SYMALL(KARTEZ,NUHALF,NUMDEN),NUHALF=1,NDHALF),
     *              CSYDEN(KARTEZ,       NUMDEN),
     *                                           KARTEZ=1,NDKART),
     *                                           NUMDEN=1,NDALLD)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SYMPAI(ITPNMX)
C=======================================================================
      USE PD_DEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CSYPAI*4
C
      COMPLEX
     *          SYMALL(NDKART,NDHALF)
C
      DIMENSION
     *          CSYPAI(NDKART,NDREIM)
C
      COMMON
     *       /INTMEM/ TWOWGT(1:NDGAUS,1:NDKART),
     *                TWOPNT(1:NDGAUS,1:NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
C=======================================================================
C        THIS SUBROUTINE DETERMINES SYMMETRIES  OF THE SKYRME FUNCTIONAL
C        PAIRING DENSITIES
C
C        ATTENTION: THE FIRST DUMMY ARGUMENT IS USED FOR ALL DENSITIES
C
C=======================================================================
C
      SYMALL(:,:)=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        SYMMETRY IN THE X-DIRECTION
C=======================================================================
C
      DO IZ=1,NZHERM/2
         DO IY=1,NYHERM/2
C
            DO NUHALF=1,NDHALF
               DO IX=1+(NUHALF-1)*NXHERM/2,NUHALF*NXHERM/2
C
                  W_HERM=TWOWGT(IX,1)*TWOWGT(IY,2)*TWOWGT(IZ,3)
C
                  SYMALL(1,NUHALF)=SYMALL(1,NUHALF)
     *                                   +PD_RHO(IX,IY,IZ,ITPNMX,1)
     *                                   *W_HERM
C
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        SYMMETRY IN THE Y-DIRECTION
C=======================================================================
C
      DO IZ=1,NZHERM/2
         DO IX=1,NXHERM/2
C
            DO NUHALF=1,NDHALF
               DO IY=1+(NUHALF-1)*NYHERM/2,NUHALF*NYHERM/2
C
                  W_HERM=TWOWGT(IX,1)*TWOWGT(IY,2)*TWOWGT(IZ,3)
C
                  SYMALL(2,NUHALF)=SYMALL(2,NUHALF)
     *                                   +PD_RHO(IX,IY,IZ,ITPNMX,1)
     *                                   *W_HERM
C
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        SYMMETRY IN THE Z-DIRECTION
C=======================================================================
C
      DO IY=1,NYHERM/2
         DO IX=1,NXHERM/2
C
            DO NUHALF=1,NDHALF
               DO IZ=1+(NUHALF-1)*NZHERM/2,NUHALF*NZHERM/2
C
                  W_HERM=TWOWGT(IX,1)*TWOWGT(IY,2)*TWOWGT(IZ,3)
C
                  SYMALL(3,NUHALF)=SYMALL(3,NUHALF)
     *                                   +PD_RHO(IX,IY,IZ,ITPNMX,1)
     *                                   *W_HERM
C
               END DO
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        DETERMINING THE SYMMETRY
C=======================================================================
C
      DO KARTEZ=1,NDKART
         DO NUREIM=1,NDREIM
C
            IF (NUREIM.EQ.1) THEN
C
                HALF_1= REAL(SYMALL(KARTEZ,1))
                HALF_2= REAL(SYMALL(KARTEZ,2))
            ELSE
                HALF_1=AIMAG(SYMALL(KARTEZ,1))
                HALF_2=AIMAG(SYMALL(KARTEZ,2))
C
            END IF
C
            IF (HALF_1.EQ.0.0) THEN
C
                CSYPAI(KARTEZ,NUREIM)='ZERO'
C
            ELSE
C
                DIVIDE=HALF_2/HALF_1
C
                IF (ABS(ABS(DIVIDE)-1.0D0).LT.1.D-6) THEN
C
                    IF (DIVIDE.GT.0.0) THEN
C
                        CSYPAI(KARTEZ,NUREIM)=' +1 '
                    ELSE
                        CSYPAI(KARTEZ,NUREIM)=' -1 '
C
                    END IF
C
                ELSE
                    CSYPAI(KARTEZ,NUREIM)='NONE'
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C        PRINTING
C=======================================================================
C
      WRITE(NFIPRI,'(79(1H*),/,                    1H*,77X,1H*,/,
     *                 1H*,2X,''SYMMETRIES OF PAIRING DENSITIE'',
     *                        ''S (REAL PARTS)                '',
     *                                                 15X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/,
     *                                             1H*,77X,1H*,/,
C    *              16(1H*,2X,I3,3(2(1PE9.1),1X,A4),    3X,1H*,/),
     *                (1H*,2X,I3,3(2(1PE9.1),1X,A4),    3X,1H*,/),
     *                                             1H*,77X,1H*,/,
     *                                                  79(1H*),/)')
     *
     *    (NUMPAI,((REAL(SYMALL(KARTEZ,NUHALF)),
     *                                           NUHALF=1,NDHALF),
     *              CSYPAI(KARTEZ,1),
     *                                           KARTEZ=1,NDKART),
     *                                           NUMPAI=1,NDALLP)
C
      WRITE(NFIPRI,'(79(1H*),/,                    1H*,77X,1H*,/,
     *                 1H*,2X,''SYMMETRIES OF PAIRING DENSITIE'',
     *                        ''S (IMAGINARY PARTS)           '',
     *                                                 15X,1H*,/,
     *                                             1H*,77X,1H*,/,
     *                                                 79(1H*),/,
     *                                             1H*,77X,1H*,/,
C    *              16(1H*,2X,I3,3(2(1PE9.1),1X,A4),    3X,1H*,/),
     *                (1H*,2X,I3,3(2(1PE9.1),1X,A4),    3X,1H*,/),
     *                                             1H*,77X,1H*,/,
     *                                                  79(1H*),/)')
     *
     *    (NUMPAI,((AIMAG(SYMALL(KARTEZ,NUHALF)),
     *                                           NUHALF=1,NDHALF),
     *              CSYPAI(KARTEZ,2),
     *                                           KARTEZ=1,NDKART),
     *                                           NUMPAI=1,NDALLP)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DBLING(ITPNMX)
C=======================================================================
      USE HE_DEN
      USE PD_DEN
      USE HETDEN
      USE PDTDEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          UNIT_I
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /ATHRGR/ TGRA10,TGRA11,TGRA20,TGRA21,TGRA22,IGRAIN
C
C=======================================================================
C
      ZERO=0.0D0
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES DENSITIES WHEN THEY  ARE  DETERMINED
C        IN "DENSHF" BY USING ONLY THE TIME-UP BLOCK OF WAVE  FUNCTIONS.
C        THE SUBROUTINE:
C
C           1. TAKES DOUBLED REAL  PARTS  OF  THE  CALCULATED  TIME-EVEN
C              "P-H" DENSITIES AS THESE SAME DENSITIES.
C           2. TAKES DOUBLED IMAGINARY PARTS MULTIPLIED BY THE IMAGINARY
C              UNIT OF THE CALCULATED TIME-ODD "P-H" DENSITIES AS  THESE
C              SAME DENSITIES.
C           3. SETS IMAGINARY PARTS OF THE CALCULATED PAIRING  DENSITIES
C              TO ZERO.
C
C         ATTENTION: OPERATION 3 IS INCOMPATIBLE WITH PAIRING TRANSITION
C                    DENSITIES, SO THIS SUBROUTINE CANNOT BE CALLED  FOR
C                    PROJECTION, GCM, OR PROTON-NEUTRON  MIXING  EMPLYED
C                    WITH PAIRING.
C=======================================================================
C
      DO IZ=1,NZHERM
         DO IY=1,NYHERM
            DO IX=1,NXHERM
C
C=======================================================================
C              SCALAR  DENSITIES
C=======================================================================
C
               DE_RHO(IX,IY,IZ,ITPNMX,1)=2*REAL(DE_RHO(IX,IY,IZ,ITPNMX,
     *                                                              1))
               DE_TAU(IX,IY,IZ,ITPNMX,1)=2*REAL(DE_TAU(IX,IY,IZ,ITPNMX,
     *                                                              1))
               DE_DIV(IX,IY,IZ,ITPNMX,1)=2*REAL(DE_DIV(IX,IY,IZ,ITPNMX,
     *                                                              1))
               DE_LPR(IX,IY,IZ,ITPNMX,1)=2*REAL(DE_LPR(IX,IY,IZ,ITPNMX,
     *                                                              1))
               IF (IGRAIN.EQ.1)
     *         DE_DIJ(IX,IY,IZ,ITPNMX,1)=2*REAL(DE_DIJ(IX,IY,IZ,ITPNMX,
     *                                                              1))
C
               PD_RHO(IX,IY,IZ,ITPNMX,1)=
     *                       CMPLX(REAL(PD_RHO(IX,IY,IZ,ITPNMX,1)),ZERO)
               PD_TAU(IX,IY,IZ,ITPNMX,1)=
     *                       CMPLX(REAL(PD_TAU(IX,IY,IZ,ITPNMX,1)),ZERO)
               PD_LPR(IX,IY,IZ,ITPNMX,1)=
     *                       CMPLX(REAL(PD_LPR(IX,IY,IZ,ITPNMX,1)),ZERO)
C
            END DO
         END DO
      END DO
C
      DO K=1,NDKART
C
         DO IZ=1,NZHERM
            DO IY=1,NYHERM
               DO IX=1,NXHERM
C
C=======================================================================
C              VECTOR DENSITIES
C=======================================================================
C
                  DE_SPI(IX,IY,IZ,K,ITPNMX,1)
     *                      =2*AIMAG(DE_SPI(IX,IY,IZ,K,ITPNMX,1))*UNIT_I
                  DE_KIS(IX,IY,IZ,K,ITPNMX,1)
     *                      =2*AIMAG(DE_KIS(IX,IY,IZ,K,ITPNMX,1))*UNIT_I
                  DE_GRR(IX,IY,IZ,K,ITPNMX,1)
     *                      =2* REAL(DE_GRR(IX,IY,IZ,K,ITPNMX,1))
                  DE_LPS(IX,IY,IZ,K,ITPNMX,1)
     *                      =2*AIMAG(DE_LPS(IX,IY,IZ,K,ITPNMX,1))*UNIT_I
                  DE_ROS(IX,IY,IZ,K,ITPNMX,1)
     *                      =2*AIMAG(DE_ROS(IX,IY,IZ,K,ITPNMX,1))*UNIT_I
                  DE_ROC(IX,IY,IZ,K,ITPNMX,1)
     *                      =2*AIMAG(DE_ROC(IX,IY,IZ,K,ITPNMX,1))*UNIT_I
                  DE_CUR(IX,IY,IZ,K,ITPNMX,1)
     *                      =2*AIMAG(DE_CUR(IX,IY,IZ,K,ITPNMX,1))*UNIT_I
                  DE_KIF(IX,IY,IZ,K,ITPNMX,1)
     *                      =2*AIMAG(DE_KIF(IX,IY,IZ,K,ITPNMX,1))*UNIT_I
                  IF (IGRAIN.EQ.1)
     *            DE_DIS(IX,IY,IZ,K,ITPNMX,1)
     *                      =2*AIMAG(DE_DIS(IX,IY,IZ,K,ITPNMX,1))*UNIT_I
C
                  PD_GRR(IX,IY,IZ,K,ITPNMX,1)=
     *                     CMPLX(REAL(PD_GRR(IX,IY,IZ,K,ITPNMX,1)),ZERO)
                  IF (IGRAIN.EQ.1)
     *            PD_DIS(IX,IY,IZ,K,ITPNMX,1)=
     *                CMPLX(REAL(PD_DIS(IX,IY,IZ,K,ITPNMX,1)),ZERO)
C
               END DO
            END DO
         END DO
C
      END DO
C
      DO L=1,NDKART
         DO K=1,NDKART
C
            DO IZ=1,NZHERM
               DO IY=1,NYHERM
                  DO IX=1,NXHERM
C
C=======================================================================
C                 TENSOR DENSITIES
C=======================================================================
C
                     DE_SCU(IX,IY,IZ,K,L,ITPNMX,1)
     *                           =2* REAL(DE_SCU(IX,IY,IZ,K,L,ITPNMX,1))
C
                     DE_DES(IX,IY,IZ,K,L,ITPNMX,1)
     *                           =2*AIMAG(DE_DES(IX,IY,IZ,K,L,ITPNMX,1))
     *                            *UNIT_I
C
                     PD_SCU(IX,IY,IZ,K,L,ITPNMX,1)=
     *                   CMPLX(REAL(PD_SCU(IX,IY,IZ,K,L,ITPNMX,1)),ZERO)
C
                  END DO
               END DO
            END DO
C
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ALLODE(LDPNMX,IGRAIN,LDTWCE,LDTWDD)
C=======================================================================
      USE HE_DEN
      USE PD_DEN
      USE PP_DEN
      USE HETDEN
      USE PDTDEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C        THIS SUBROUTINE ALLOCATES SPACE FOR THE SKYRME DENSITIES TAKING
C        INTO ACCOUNT POSSIBLE PROTON-NEUTRON MIXING
C=======================================================================
C
      IALLER=0
C
      IF(ALLOCATED(DE_RHO)) THEN
         DEALLOCATE(DE_RHO,DE_TAU,DE_LPR,DE_DIV,PD_RHO,PP_RHO,
     *              PD_TAU,PP_TAU,PD_LPR,PP_LPR)
      END IF
C
      IALLOC=0
C
      ALLOCATE(DE_RHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         DE_TAU(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         DE_LPR(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         DE_DIV(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         PD_RHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         PP_RHO(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         PD_TAU(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         PP_TAU(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         PD_LPR(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         PP_LPR(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWDD),
     *         STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 1 IN ALLODE'')')
          IALLER=1
      END IF
C
C=======================================================================
C
      IF(ALLOCATED(DE_SPI)) THEN
         DEALLOCATE(DE_SPI,DE_KIS,DE_GRR,DE_LPS,DE_ROS,DE_ROC,
     *              DE_CUR,DE_KIF,PD_GRR,PP_GRR)
      END IF
C
      IALLOC=0
C
      ALLOCATE(DE_SPI(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         DE_KIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         DE_GRR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         DE_LPS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         DE_ROS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         DE_ROC(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         DE_CUR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         DE_KIF(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         PD_GRR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         PP_GRR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                   ,1:LDTWDD),
     *         STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 2 IN ALLODE'')')
          IALLER=1
      END IF
C
C=======================================================================
C
      IF(ALLOCATED(DE_SCU)) THEN
         DEALLOCATE(DE_SCU,DE_DES,PD_SCU,PP_SCU)
      END IF
C
      IALLOC=0
C
      ALLOCATE(DE_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1:NDKART,
     *                                          0:LDPNMX,1:LDTWDD),
     *         DE_DES(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1:NDKART,
     *                                          0:LDPNMX,1:LDTWDD),
     *         PD_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1:NDKART,
     *                                          0:LDPNMX,1:LDTWDD),
     *         PP_SCU(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1:NDKART,
     *                                          0:LDPNMX,1:LDTWDD),
     *         STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 3 IN ALLODE'')')
          IALLER=1
      END IF
C
C=======================================================================
C
      IF (IGRAIN.EQ.1) THEN
C
          IALLOC=0
C
          IF(ALLOCATED(DE_DIJ)) THEN
             DEALLOCATE(DE_DIJ,DE_DIS)
          END IF
C
          ALLOCATE(DE_DIJ(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,
     *                                               1:LDTWDD),
     *             STAT=IALLOC)
          ALLOCATE(DE_DIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX
     *                                                     ,1:LDTWDD),
     *             STAT=IALLOC)
C
          IF (IALLOC.NE.0) THEN
              WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 4 IN ALLODE'')')
              IALLER=1
          END IF
C
C=======================================================================
C
          IALLOC=0
C
          IF(ALLOCATED(PD_DIS)) THEN
             DEALLOCATE(PD_DIS,PP_DIS)
          END IF
C
          ALLOCATE(PD_DIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX,
     *             1:LDTWDD),STAT=IALLOC)
          ALLOCATE(PP_DIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX,
     *             1:LDTWDD),STAT=IALLOC)
C
          IF (IALLOC.NE.0) THEN
              WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 5 IN ALLODE'')')
              IALLER=1
          END IF
C
      END IF
C
C=======================================================================
C
      IF (IALLER.NE.0) CALL NOALLO('ARRAYS','ALLODE')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEALDE
C=======================================================================
      USE HE_DEN
      USE HETDEN
      USE PD_DEN
      USE PP_DEN
      USE PDTDEN
      USE MAD_PP
      USE MAD_PM
      USE MAP_PP
      USE MAP_PM
C=======================================================================
C
      IF(ALLOCATED(DE_RHO)) THEN
         DEALLOCATE(DE_RHO,DE_TAU,DE_LPR,DE_DIV,PD_RHO,PP_RHO,
     *              PD_TAU,PP_TAU,PD_LPR,PP_LPR)
      END IF
C
      IF(ALLOCATED(DE_SPI)) THEN
         DEALLOCATE(DE_SPI,DE_KIS,DE_GRR,DE_LPS,DE_ROS,DE_ROC,
     *              DE_CUR,DE_KIF,PD_GRR,PP_GRR)
      END IF
C
      IF(ALLOCATED(DE_SCU)) THEN
         DEALLOCATE(DE_SCU,DE_DES,PD_SCU,PP_SCU)
      END IF
C
      IF(ALLOCATED(DE_DIJ)) THEN
         DEALLOCATE(DE_DIJ,DE_DIS)
      END IF
C
      IF(ALLOCATED(PD_DIS)) THEN
         DEALLOCATE(PD_DIS,PP_DIS)
      END IF
C
C=======================================================================
C
      IF (ALLOCATED(DEN_PP)) DEALLOCATE(DEN_PP)
C
      IF (ALLOCATED(DEN_PM)) DEALLOCATE(DEN_PM)
C
C=======================================================================
C
      IF (ALLOCATED(CHI_PM)) DEALLOCATE(CHI_PM)
C
      IF (ALLOCATED(CHI_PP)) DEALLOCATE(CHI_PP)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ALLOVF(LDPNMX,LDTWCE)
C=======================================================================
      USE VE_FLD
      USE WD_FLD
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C        THIS SUBROUTINE ALLOCATES SPACE FOR SKYRME FIELDS TAKING
C        INTO ACCOUNT POSSIBLE PROTON-NEUTRON MIXING
C=======================================================================
C
      IALLER=0
C
      IF(ALLOCATED(VE_MAS)) THEN
         DEALLOCATE(VE_MAS,VE_CEN,VE_SPT,VE_KIS,VE_SPI,VE_CUR,VE_KIT,
     *              VE_SOR)
      END IF
C
      IALLOC=0
C
      ALLOCATE(VE_MAS(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWCE),
     *         VE_CEN(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWCE),
     *         VE_SPT(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWCE),
     *         STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 1 IN ALLOVF'')')
          IALLER=1
      END IF
C
C=======================================================================
C
      IALLOC=0
C
      ALLOCATE(VE_KIS(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX,
     *                                                    1:LDTWCE),
     *         VE_SPI(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX,
     *                                                    1:LDTWCE),
     *         VE_CUR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX,
     *                                                    1:LDTWCE),
     *         VE_KIT(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,0:LDPNMX,
     *                                                    1:LDTWCE),
     *         STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 2 IN ALLOVF'')')
          IALLER=1
      END IF
C
C=======================================================================
C
      IALLOC=0
C
      ALLOCATE(VE_SOR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1:NDKART,
     *                                                    0:LDPNMX,
     *                                                    1:LDTWCE),
     *         STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 3 IN ALLOVF'')')
          IALLER=1
      END IF
C
C=======================================================================
C
      IF(ALLOCATED(WD_CEN)) THEN
         DEALLOCATE(WD_CEN,WD_TAU,WD_SOR)
      END IF
C
      IALLOC=0
C
      ALLOCATE(WD_CEN(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWCE),
     *         WD_TAU(1:NDXHRM,1:NDYHRM,1:NDZHRM,0:LDPNMX,1:LDTWCE),
     *         STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 4 IN ALLOVF'')')
          IALLER=1
      END IF
C
C=======================================================================
C
      IALLOC=0
C
      ALLOCATE(WD_SOR(1:NDXHRM,1:NDYHRM,1:NDZHRM,1:NDKART,1:NDKART,
     *                                                    0:LDPNMX,
     *                                                    1:LDTWCE),
     *         STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 5 IN ALLOVF'')')
          IALLER=1
      END IF
C
C=======================================================================
C
      IF (IALLER.NE.0) CALL NOALLO('ARRAYS','ALLOVF')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DEALVF
C=======================================================================
      USE VE_FLD
      USE WD_FLD
C=======================================================================
C
      IF(ALLOCATED(VE_MAS)) THEN
         DEALLOCATE(VE_MAS,VE_CEN,VE_SPT,VE_KIS,VE_SPI,VE_CUR,VE_KIT,
     *              VE_SOR)
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ALLORH(LDPNMX,ISIMPY)
C=======================================================================
      USE MAD_PP
      USE MAD_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C        THIS SUBROUTINE ALLOCATES SPACE FOR SAVING THE  DENSITY  MATRIX
C        TAKING INTO ACCOUNT POSSIBLE PROTON-NEUTRON MIXING
C=======================================================================
C
      IALLER=0
C
      IALLOC=0
C
      IF (ALLOCATED(DEN_PP)) DEALLOCATE(DEN_PP)
C
      ALLOCATE (DEN_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:LDPNMX),
     *          STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 1 IN ALLORH'')')
          IALLER=1
      END IF
C
      IF (ISIMPY.NE.1) THEN
C
          IALLOC=0
C
          IF (ALLOCATED(DEN_PM)) DEALLOCATE(DEN_PM)
C
          ALLOCATE (DEN_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:LDPNMX),
     *              STAT=IALLOC)
C
          IF (IALLOC.NE.0) THEN
              WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 2 IN ALLORH'')')
              IALLER=1
          END IF
C
      END IF
C
      IF (IALLER.NE.0) CALL NOALLO('ARRAYS','ALLORH')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ALLOKA(LDPNMX,ISIMPY)
C=======================================================================
      USE MAP_PP
      USE MAP_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C        THIS SUBROUTINE ALLOCATES SPACE FOR SAVING THE PAIRING TENSOR
C        TAKING INTO ACCOUNT POSSIBLE PROTON-NEUTRON MIXING
C=======================================================================
C
      IALLER=0
C
      IALLOC=0
C
      IF (ALLOCATED(CHI_PM)) DEALLOCATE(CHI_PM)
C
      ALLOCATE (CHI_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:LDPNMX),
     *          STAT=IALLOC)
C
      IF (IALLOC.NE.0) THEN
          WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 1 IN ALLOKA'')')
          IALLER=1
      END IF
C
      IF (ISIMPY.NE.1) THEN
C
          IALLOC=0
C
          IF (ALLOCATED(CHI_PP)) DEALLOCATE(CHI_PP)
C
          ALLOCATE (CHI_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:LDPNMX),
     *              STAT=IALLOC)
C
          IF (IALLOC.NE.0) THEN
              WRITE(NFIPRI,'(''ERROR ALLOCATING ARRAYS 2 IN ALLOKA'')')
              IALLER=1
          END IF
C
      END IF
C
      IF (IALLER.NE.0) CALL NOALLO('ARRAYS','ALLOKA')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ZEDENS(ITPNMX)
C=======================================================================
      USE HE_DEN
      USE PD_DEN
      USE PP_DEN
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
C
C=======================================================================
C        THIS SUBROUTINE PUTS ZEROS IN THE SKYRME DENSITIES
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C              SCALAR  DENSITIES
C=======================================================================
C
      DE_RHO(:,:,:,ITPNMX,:)=C_ZERO
      DE_TAU(:,:,:,ITPNMX,:)=C_ZERO
      DE_DIV(:,:,:,ITPNMX,:)=C_ZERO
      DE_LPR(:,:,:,ITPNMX,:)=C_ZERO
C
      PD_RHO(:,:,:,ITPNMX,:)=C_ZERO
      PD_TAU(:,:,:,ITPNMX,:)=C_ZERO
      PD_LPR(:,:,:,ITPNMX,:)=C_ZERO
      PP_RHO(:,:,:,ITPNMX,:)=C_ZERO
      PP_TAU(:,:,:,ITPNMX,:)=C_ZERO
      PP_LPR(:,:,:,ITPNMX,:)=C_ZERO
C
C=======================================================================
C              VECTOR DENSITIES
C=======================================================================
C
      DE_SPI(:,:,:,:,ITPNMX,:)=C_ZERO
      DE_KIS(:,:,:,:,ITPNMX,:)=C_ZERO
      DE_LPS(:,:,:,:,ITPNMX,:)=C_ZERO
      DE_GRR(:,:,:,:,ITPNMX,:)=C_ZERO
      DE_CUR(:,:,:,:,ITPNMX,:)=C_ZERO
      DE_KIF(:,:,:,:,ITPNMX,:)=C_ZERO
      DE_ROS(:,:,:,:,ITPNMX,:)=C_ZERO
      DE_ROC(:,:,:,:,ITPNMX,:)=C_ZERO
C
      PD_GRR(:,:,:,:,ITPNMX,:)=C_ZERO
      PP_GRR(:,:,:,:,ITPNMX,:)=C_ZERO
C
C=======================================================================
C                 TENSOR DENSITY
C=======================================================================
C
      DE_SCU(:,:,:,:,:,ITPNMX,:)=C_ZERO
      DE_DES(:,:,:,:,:,ITPNMX,:)=C_ZERO
C
      PD_SCU(:,:,:,:,:,ITPNMX,:)=C_ZERO
      PP_SCU(:,:,:,:,:,ITPNMX,:)=C_ZERO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE LIPNAP(IX_FIX,ILIPOX,GAUSHI,ISIMPY,MREVER,ICHARG)
      USE HFODD_SIZES
      USE CANBAS
C
      COMMON
     *       /CAOCNP/ V2OCNP(1:4*NDBASE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
C   Number of GAUGE Points for STUDYING THE BEHAVIOR OF THE OVERLAP KERNELS:N, P
C      INTEGER, INTENT(IN) :: NPGAUG
      INTEGER, INTENT(IN) :: MREVER
      INTEGER, INTENT(IN) :: ISIMPY
      INTEGER, INTENT(IN) :: ICHARG
      INTEGER, INTENT(IN) :: IX_FIX
      REAL GAUSHI
C
Cc   CONSTANTS PARAMETERS ==========================================
      COMPLEX
     *          C_ZERO,UNIT_I,C_UNIT
      REAL,PARAMETER :: PI = 4.0D0*ATAN(1.0D0)
      INTEGER,PARAMETER :: NORDER = 6
      INTEGER,PARAMETER :: NODGAU = 1000
Cc     ==================================================================
C -->  LIPKIN METHOD PARTICLE NUMBERS RELATED
C
      COMPLEX
     *          RLIPNU,NLIPNU
      COMMON
     *       /LIPNUM/
     *          RLIPNU(0:6,0:NODGAU,0:NDISOS),
     *          NLIPNU(0:6,0:NODGAU,0:NDISOS)
C
      REAL
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
      COMMON
     *       /LIPLAM/
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
      REAL
     *       ELIP2N,ELIP2P,ELIP4N,ELIP4P,ELIP6N,ELIP6P,
     *       ELAM4N,ELAM6N,ELAM4P,ELAM6P
      COMMON
     *       /LIPADE/
     *       ELIP2N,ELIP2P,ELIP4N,ELIP4P,ELIP6N,ELIP6P,
     *       ELAM4N,ELAM6N,ELAM4P,ELAM6P
CCCC---------ORDER(max=6 FOR NOW)--GAUGE POINTS-ICHARG--------------------------
      COMPLEX
     *          C_ACTV, C_ACTU
      COMPLEX
     *          OVRLAP,ILNOVR
      COMPLEX
     *          C_U0V2, C_U2V2, C_UVUV, C_U4V4, C_U4V2, C_U2V4,
     *          C_U6V4, C_U4V6
C
      COMPLEX
     *          C_U6V2, C_U2V6, C_U6V6, C_U8V4, C_U4V8
      DIMENSION
     *          OVRLAP(0:NODGAU,0:NDISOS), ILNOVR(0:NODGAU,0:NDISOS)
      DIMENSION
     *          C_U0V2(0:NODGAU,0:NDISOS), C_U2V2(0:NODGAU,0:NDISOS),
     *          C_UVUV(0:NODGAU,0:NDISOS)
      DIMENSION
     *          C_U4V4(0:NODGAU,0:NDISOS), C_U4V2(0:NODGAU,0:NDISOS),
     *          C_U2V4(0:NODGAU,0:NDISOS)
      DIMENSION
     *          C_U4V6(0:NODGAU,0:NDISOS), C_U6V4(0:NODGAU,0:NDISOS),
     *          C_U2V6(0:NODGAU,0:NDISOS)
      DIMENSION
     *          C_U6V2(0:NODGAU,0:NDISOS), C_U6V6(0:NODGAU,0:NDISOS),
     *          C_U8V4(0:NODGAU,0:NDISOS)
      DIMENSION
     *          C_U4V8(0:NODGAU,0:NDISOS)
C
CCCC--------trace-high-power of densities--------------------------
      COMPLEX
     *         CRHOX1,CRHOX2,CRHOX3,CRHOX4,CRHOX5,CRHOX6
      COMPLEX
     *         CLAM4T,CLAM6T
C
C
CC-----------------OUT PUT FILES-------------------------------------------
C
CCCCCCCCCC--------PRINT ON THE OUTPUT FILE --------------------------------
      COMMON
     *       /CFIPRI/ NFIPRI
C
C     ------------------------------------------------------------------
C     Internal variables:
C     ==================================================================
C
      INTEGER :: IALLOC,ISTATE
      INTEGER :: IPOINT,IORDER
      REAL    :: THETAN,THETAP,THETAS
C
      COMPLEX :: ZSHIFN, ZSHIFP, ZSHIFT, CFUPPR, CFLOWR
C OUTPUT FILE NUMBER
      INTEGER :: NFILEP
      INTEGER :: ILABLE,IILABL
      REAL    :: VIACTU
      DIMENSION
     *          VIACTU(1:2*NDBASE)
C
      INTEGER :: GAUP_N,NEUTPT
C=======================================================================
C     THIS SUBROUTINE CALCULATING THE REDUCED KERNELS OF LIPKIN METHOD
C=======================================================================
C
      CALL CPUTIM('LIPNAP',1)
C
CC----------------------------INITIALIZING------------------------------------
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
C ILIPOX.GT.2 USE TOTAL SHIFTED ANGLE:
      IF (ILIPOX.LT.2) NEUTPT=1
      IF (ILIPOX.EQ.2) NEUTPT=2
      IF (ILIPOX.EQ.4) NEUTPT=3
      IF (ILIPOX.EQ.6) NEUTPT=4
C
            THETAS= GAUSHI/(NEUTPT-1.0D0)
            THETAN=-THETAS
C
C-----------------------------------------------------------------------------
C
      IF (ISIMPY.NE.1) THEN
C
      STOP ' SIMPLEX BROKEN IS NOT IMPLEMENTED IN LIPNAP!'
C
      END IF
C
      DO IPOINT = 1, NEUTPT
C
C           Gauge angles
C            THETAN= (IPOINT-1.0d0) * 2*PI / GAUP_N
C            THETAN=THETAN+THETAS
            THETAN=THETAS*(IPOINT-1.0d0)
C
C           Complex shifts
C
            ZSHIFT=CMPLX(COS(THETAN), SIN(THETAN))
C-----------------------------------------------------------------------------
C
C=======================================================================
C        CALCULATING THE LIPKIN SUMS FOR PARTICLE NUMBER RESTORATION
C=======================================================================
C
C        ---INTIALIZING C_U0V2, C_U2V2, ETC.-----------------
        OVRLAP(IPOINT,ICHARG)=C_UNIT
        ILNOVR(IPOINT,ICHARG)=C_ZERO
        C_U0V2(IPOINT,ICHARG)=C_ZERO
        C_U2V2(IPOINT,ICHARG)=C_ZERO
        C_UVUV(IPOINT,ICHARG)=C_ZERO
        C_U4V4(IPOINT,ICHARG)=C_ZERO
        C_U4V2(IPOINT,ICHARG)=C_ZERO
        C_U2V4(IPOINT,ICHARG)=C_ZERO
        C_U6V4(IPOINT,ICHARG)=C_ZERO
        C_U4V6(IPOINT,ICHARG)=C_ZERO
        C_U6V2(IPOINT,ICHARG)=C_ZERO
        C_U2V6(IPOINT,ICHARG)=C_ZERO
        C_U6V6(IPOINT,ICHARG)=C_ZERO
        C_U8V4(IPOINT,ICHARG)=C_ZERO
        C_U4V8(IPOINT,ICHARG)=C_ZERO
C
C   CRHOX1,CRHOX2,CRHOX3,CRHOX4,CRHOX5,CRHOX6
C
        CRHOX1=C_ZERO
        CRHOX2=C_ZERO
          CRHOX3=C_ZERO
          CRHOX4=C_ZERO
        CRHOX5=C_ZERO
          CRHOX6=C_ZERO
C
        CLAM4T=C_ZERO
        CLAM6T=C_ZERO
C
C
        DO IORDER=1,NORDER
        RLIPNU(IORDER,IPOINT,ICHARG)=C_ZERO
        NLIPNU(IORDER,IPOINT,ICHARG)=C_ZERO
        END DO
C
        ILABLE=1
C
        DO IREVER=0,MREVER
C
        DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
C FOLLOW THE CONVENTION OF T.L.!
            IF (ABS(V_CAN(ISTATE,IREVER,
     *        ICHARG)).GE.0.0D0) THEN
C
             V_ACTU=ABS(V_CAN(ISTATE,IREVER,
     *        ICHARG))
C
         ELSE
C
             V_ACTU=0.0D0
C
         END IF
C
CC FOLLOW THE CONVENTION OF T.L.!
         IF (ABS(V_CAN(ISTATE,IREVER,
     *        ICHARG)).LE.1.0D0) THEN
C
              U_ACTU=ABS(U_CAN(ISTATE,IREVER,
     *        ICHARG))
C
         ELSE
C
             U_ACTU=0.0D0
             V_ACTU=1.0D0
C
         END IF
C
         VIACTU(ILABLE)=V_ACTU
C
C
         IF (ABS(V_CAN(ISTATE,IREVER,
     *        ICHARG)).GE.0.0D0) THEN
C
             C_ACTV=ZSHIFT*V_ACTU
     *              /SQRT(U_ACTU**2+V_ACTU**2*ZSHIFT**2)
C
         ELSE
C
             C_ACTV=C_ZERO
C
         END IF
C
         IF (ABS(V_CAN(ISTATE,IREVER,
     *        ICHARG)).LE.1.0D0) THEN
C
             C_ACTU= U_ACTU
     *              /SQRT(U_ACTU**2+V_ACTU**2*ZSHIFT**2)
C
         ELSE
C
             C_ACTU=C_ZERO
             C_ACTV=C_UNIT
C
         END IF
C
C=======================================================================
C                  BEGING CALCULATING THE C_U0V2, C_U2V2
C=======================================================================
C=======================================================================
C                          OVERLAPS
C=======================================================================
       IF ((ISIMPY.EQ.1).AND.(MREVER.EQ.0)) THEN
C-HALF
         OVRLAP(IPOINT,ICHARG) = OVRLAP(IPOINT,ICHARG)
     *                           *(U_ACTU**2+V_ACTU**2*ZSHIFT**2)
       ELSE
C=======================================================================
C        ELIMINATE THE DEGENERATE V_i'
C
        IF (ILABLE.GT.1) THEN
          DO IILABL=1,ILABLE-1
          IF (ABS(VIACTU(IILABL)-V_ACTU).LT.1.0D-11 ) THEN
          GO TO 999
          END IF
          END DO
          OVRLAP(IPOINT,ICHARG) = OVRLAP(IPOINT,ICHARG)
     *                          *(U_ACTU**2+V_ACTU**2*ZSHIFT**2)
  999   CONTINUE
        END IF
       END IF
C
       ILABLE = ILABLE+1
C
C
C
         C_U0V2(IPOINT,ICHARG)= C_U0V2(IPOINT,ICHARG)
     *                                   + C_ACTV**2
         C_U2V2(IPOINT,ICHARG)= C_U2V2(IPOINT,ICHARG)
     *                                   + C_ACTV**2*C_ACTU**2
         C_UVUV(IPOINT,ICHARG)= C_UVUV(IPOINT,ICHARG)
     *                          +C_ACTV**2*C_ACTU**2
     *                          *(C_ACTU**2-C_ACTV**2)
         C_U4V4(IPOINT,ICHARG)= C_U4V4(IPOINT,ICHARG)
     *                                   + C_ACTV**4*C_ACTU**4
         C_U4V2(IPOINT,ICHARG)= C_U4V2(IPOINT,ICHARG)
     *                                   + C_ACTV**2*C_ACTU**4
         C_U2V4(IPOINT,ICHARG)= C_U2V4(IPOINT,ICHARG)
     *                                   + C_ACTV**4*C_ACTU**2
         C_U6V4(IPOINT,ICHARG)= C_U6V4(IPOINT,ICHARG)
     *                                   + C_ACTV**4*C_ACTU**6
         C_U4V6(IPOINT,ICHARG)= C_U4V6(IPOINT,ICHARG)
     *                                   + C_ACTV**6*C_ACTU**4
         C_U6V2(IPOINT,ICHARG)= C_U6V2(IPOINT,ICHARG)
     *                                   + C_ACTV**2*C_ACTU**6
         C_U2V6(IPOINT,ICHARG)= C_U2V6(IPOINT,ICHARG)
     *                                   + C_ACTV**6*C_ACTU**2
         C_U6V6(IPOINT,ICHARG)= C_U6V6(IPOINT,ICHARG)
     *                                   + C_ACTV**6*C_ACTU**6
         C_U8V4(IPOINT,ICHARG)= C_U8V4(IPOINT,ICHARG)
     *                              + C_ACTV**4*C_ACTU**8
         C_U4V8(IPOINT,ICHARG)= C_U4V8(IPOINT,ICHARG)
     *                                   + C_ACTV**8*C_ACTU**4
C
C
C
        IF (IPOINT.EQ.1) THEN
C
        CRHOX1=CRHOX1+C_ACTV**2
        CRHOX2=CRHOX2+C_ACTV**4
        CRHOX3=CRHOX3+C_ACTV**6
        CRHOX4=CRHOX4+C_ACTV**8
        CRHOX5=CRHOX5+C_ACTV**10
        CRHOX6=CRHOX6+C_ACTV**12
C
          END IF
C
        END DO
        END DO
C
C--- DOUBLE THE VALUES IF MREVER IS ZERO----------------------
      IF (MREVER.EQ.0) THEN
C
          C_U0V2(IPOINT,ICHARG)=2* C_U0V2(IPOINT,ICHARG)
          C_U2V2(IPOINT,ICHARG)=2* C_U2V2(IPOINT,ICHARG)
          C_UVUV(IPOINT,ICHARG)=2* C_UVUV(IPOINT,ICHARG)
          C_U4V4(IPOINT,ICHARG)=2* C_U4V4(IPOINT,ICHARG)
          C_U4V2(IPOINT,ICHARG)=2* C_U4V2(IPOINT,ICHARG)
          C_U2V4(IPOINT,ICHARG)=2* C_U2V4(IPOINT,ICHARG)
          C_U6V4(IPOINT,ICHARG)=2* C_U6V4(IPOINT,ICHARG)
          C_U4V6(IPOINT,ICHARG)=2* C_U4V6(IPOINT,ICHARG)
          C_U6V2(IPOINT,ICHARG)=2* C_U6V2(IPOINT,ICHARG)
          C_U2V6(IPOINT,ICHARG)=2* C_U2V6(IPOINT,ICHARG)
          C_U6V6(IPOINT,ICHARG)=2* C_U6V6(IPOINT,ICHARG)
          C_U8V4(IPOINT,ICHARG)=2* C_U8V4(IPOINT,ICHARG)
          C_U4V8(IPOINT,ICHARG)=2* C_U4V8(IPOINT,ICHARG)
CC
        CRHOX1=2* CRHOX1
        CRHOX2=2* CRHOX2
          CRHOX3=2* CRHOX3
        CRHOX4=2* CRHOX4
        CRHOX5=2* CRHOX5
          CRHOX6=2* CRHOX6
C
      END IF
C
C------------LN OVERLAP ---------------------------------------------------
         OVRLAP(IPOINT,ICHARG) = OVRLAP(IPOINT,ICHARG)
     *                          *ZSHIFT**(-IX_FIX)
C
         ILNOVR(IPOINT,ICHARG)=LOG(OVRLAP(IPOINT,ICHARG))
C
C-------------------------------------------------------------------------
C
C------------RLIPNU(IORDER,IPOINT,ICHARG) CALCULATION-----------------------
C
       RLIPNU(1,IPOINT,ICHARG)= C_U0V2(IPOINT,ICHARG)- IX_FIX
       RLIPNU(2,IPOINT,ICHARG)= 2.0D0*C_U2V2(IPOINT,ICHARG)
       RLIPNU(3,IPOINT,ICHARG)= 4.0D0*C_UVUV(IPOINT,ICHARG)
       RLIPNU(4,IPOINT,ICHARG)= 8.0D0*C_U2V2(IPOINT,ICHARG)
     *                          -48.0D0*C_U4V4(IPOINT,ICHARG)
       RLIPNU(5,IPOINT,ICHARG)= 16.0D0*C_U4V2(IPOINT,ICHARG)
     *                          -16.0D0*C_U2V4(IPOINT,ICHARG)
     *                          -192.0D0*C_U6V4(IPOINT,ICHARG)
     *                          +192.0D0*C_U4V6(IPOINT,ICHARG)
C
       RLIPNU(6,IPOINT,ICHARG)= 32.0D0*C_U6V2(IPOINT,ICHARG)
     *                          -128.0D0*C_U4V4(IPOINT,ICHARG)
     *                          +32.0D0*C_U2V6(IPOINT,ICHARG)
     *                          +2304.0D0*C_U6V6(IPOINT,ICHARG)
     *                          -768.0D0*C_U8V4(IPOINT,ICHARG)
     *                          -768.0D0*C_U4V8(IPOINT,ICHARG)
C
C------------NLIPNU(IORDER,IPOINT,ICHARG) CALCULATION-----------------------
C
C       NLIPNU(0,IPOINT,ICHARG)= OVRLAP(IPOINT,ICHARG)
C
       NLIPNU(1,IPOINT,ICHARG)= RLIPNU(1,IPOINT,ICHARG)
       NLIPNU(2,IPOINT,ICHARG)= RLIPNU(1,IPOINT,ICHARG)**2
     *                          +RLIPNU(2,IPOINT,ICHARG)
       NLIPNU(3,IPOINT,ICHARG)= RLIPNU(1,IPOINT,ICHARG)**3
     *                          +3.0D0*RLIPNU(1,IPOINT,ICHARG)
     *                          *RLIPNU(2,IPOINT,ICHARG)
     *                          +RLIPNU(3,IPOINT,ICHARG)
       NLIPNU(4,IPOINT,ICHARG)= RLIPNU(1,IPOINT,ICHARG)**4
     *                          +6.0D0*RLIPNU(1,IPOINT,ICHARG)**2
     *                          *RLIPNU(2,IPOINT,ICHARG)
     *                          +4.0D0*RLIPNU(1,IPOINT,ICHARG)
     *                          *RLIPNU(3,IPOINT,ICHARG)
     *                          +3.0D0*RLIPNU(2,IPOINT,ICHARG)**2
     *                          +RLIPNU(4,IPOINT,ICHARG)
       NLIPNU(5,IPOINT,ICHARG)= RLIPNU(1,IPOINT,ICHARG)**5
     *                          +10.0D0*RLIPNU(1,IPOINT,ICHARG)**3
     *                          *RLIPNU(2,IPOINT,ICHARG)
     *                          +10.0D0*RLIPNU(1,IPOINT,ICHARG)**2
     *                          *RLIPNU(3,IPOINT,ICHARG)
     *                          +15.0D0*RLIPNU(1,IPOINT,ICHARG)
     *                          *RLIPNU(2,IPOINT,ICHARG)**2
     *                          +5.0D0*RLIPNU(1,IPOINT,ICHARG)
     *                          *RLIPNU(4,IPOINT,ICHARG)
     *                          +10.0D0*RLIPNU(2,IPOINT,ICHARG)
     *                          *RLIPNU(3,IPOINT,ICHARG)
     *                          +RLIPNU(5,IPOINT,ICHARG)
       NLIPNU(6,IPOINT,ICHARG)=  RLIPNU(1,IPOINT,ICHARG)**6
     *                           +15.0D0*RLIPNU(1,IPOINT,ICHARG)**4
     *                           *RLIPNU(2,IPOINT,ICHARG)
     *                           +20.0D0*RLIPNU(1,IPOINT,ICHARG)**3
     *                           *RLIPNU(3,IPOINT,ICHARG)
     *                           +45.0D0*RLIPNU(1,IPOINT,ICHARG)**2
     *                           *RLIPNU(2,IPOINT,ICHARG)**2
     *                           +15.0D0*RLIPNU(1,IPOINT,ICHARG)**2
     *                           *RLIPNU(3,IPOINT,ICHARG)
     *                           +9.0D0*RLIPNU(1,IPOINT,ICHARG)**2
     *                           *RLIPNU(4,IPOINT,ICHARG)
     *                           +60.0D0*RLIPNU(1,IPOINT,ICHARG)
     *                           *RLIPNU(2,IPOINT,ICHARG)
     *                           *RLIPNU(3,IPOINT,ICHARG)
     *                           +6.0D0*RLIPNU(1,IPOINT,ICHARG)
     *                           *RLIPNU(5,IPOINT,ICHARG)
     *                           +15.0D0*RLIPNU(2,IPOINT,ICHARG)**3
     *                           +15.0D0*RLIPNU(2,IPOINT,ICHARG)
     *                           *RLIPNU(4,IPOINT,ICHARG)
     *                           +10.0D0*RLIPNU(3,IPOINT,ICHARG)**2
     *                           +RLIPNU(6,IPOINT,ICHARG)
C
      IF (IPOINT.EQ.1) THEN
C
        CLAM4T=4*CRHOX1+6*NLIPNU(2,1,ICHARG)*CRHOX1
     *       -(12*NLIPNU(2,1,ICHARG)+56)*CRHOX2
     *       +144*CRHOX3-96*CRHOX4
C
      IF (ICHARG.EQ.0) THEN
        CLAM4T=CLAM4T*LAM4_N-NLIPNU(4,1,0)*LAM4_N
      ELSE
        CLAM4T=CLAM4T*LAM4_P-NLIPNU(4,1,1)*LAM4_P
       END IF
C
      IF (ICHARG.EQ.0) ELAM4N=REAL(CLAM4T)
      IF (ICHARG.EQ.1) ELAM4P=REAL(CLAM4T)
C
C
         CLAM6T=(16+45*NLIPNU(2,1,ICHARG)**2+40*REAL(NLIPNU(3,1,ICHARG))
     *     +60*NLIPNU(2,1,ICHARG)+15*REAL(RLIPNU(4,1,ICHARG)))*CRHOX1
     *     -(992+90*NLIPNU(2,1,ICHARG)**2+240*REAL(NLIPNU(3,1,ICHARG))
     *   +840*NLIPNU(2,1,ICHARG) +30*REAL(RLIPNU(4,1,ICHARG)))*CRHOX2
     *    +(8640+2160*NLIPNU(2,1,ICHARG)  +240*REAL(NLIPNU(3,1,ICHARG))
     *      )*CRHOX3
     *    -(24960+1440*NLIPNU(2,1,ICHARG))*CRHOX4
     *    +28800*CRHOX5-11520*CRHOX6
C
C
C
      IF (ICHARG.EQ.0) THEN
        CLAM6T=CLAM6T*LAM6_N-NLIPNU(6,1,0)*LAM6_N
      ELSE
        CLAM6T=CLAM6T*LAM6_P-NLIPNU(6,1,1)*LAM6_P
        END IF
C
C
C
      IF (ICHARG.EQ.0) ELAM6N=REAL(CLAM6T)
      IF (ICHARG.EQ.1) ELAM6P=REAL(CLAM6T)
C
        END IF
C
      END DO     !!!!-------------  DO IPOINT = 1, NPGAUG
C
C=======================================================================
C        ENDING CALCULATING, THE FOLLOWING IS FOR PRINTING
C=======================================================================
C
       IPRIFU=1
       IF (IPRIFU.EQ.0) THEN
C
       WRITE(*,*)'ICHARG=',ICHARG
       DO IPOINT=1, NEUTPT
       WRITE(*,*)'IPOINT=',IPOINT,'n2=',NLIPNU(2,IPOINT,ICHARG)
       END DO
C
       DO IPOINT=1, NEUTPT
       WRITE(*,*)'IPOINT=',IPOINT,'n3=',NLIPNU(3,IPOINT,ICHARG)
       END DO
C
       WRITE(*,*)'ICHARG=',ICHARG
       DO IPOINT=1, NEUTPT
       WRITE(*,*)'IPOINT=',IPOINT,'n4=',NLIPNU(4,IPOINT,ICHARG)
       END DO
C
       DO IPOINT=1, NEUTPT
       WRITE(*,*)'IPOINT=',IPOINT,'n5=',NLIPNU(5,IPOINT,ICHARG)
       END DO
C
       WRITE(*,*)'ICHARG=',ICHARG
       DO IPOINT=1, NEUTPT
       WRITE(*,*)'IPOINT=',IPOINT,'n6=',NLIPNU(6,IPOINT,ICHARG)
       END DO
C
       ELSE
C
C!      out put the N, R LIPNU
C      IF(ICHARG.EQ.0) THEN
C
C       NFILEP=222
C       OPEN(unit=NFILEP,FILE='NEUTRON-GAUGE-OEVERLAP-R.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C       OPEN(unit=NFILEP+1,FILE='NEUTRON-GAUGE-OEVERLAP-N.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C       OPEN(unit=NFILEP+2,FILE='NEUTRON-GAUGE-OEVERLAP-ABSR.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C       OPEN(unit=NFILEP+3,FILE='NEUTRON-GAUGE-OEVERLAP-ABSN.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C       OPEN(unit=NFILEP+4,FILE='NEUTRON-GAUGE-OEVERLAP.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C      ELSE
C      NFILEP=333
C       OPEN(unit=NFILEP,FILE='PROTON-GAUGE-OEVERLAP-R.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C       OPEN(unit=NFILEP+1,FILE='PROTON-GAUGE-OEVERLAP-N.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C       OPEN(unit=NFILEP+2,FILE='PROTON-GAUGE-OEVERLAP-ABSR.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C       OPEN(unit=NFILEP+3,FILE='PROTON-GAUGE-OEVERLAP-ABSN.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C       OPEN(unit=NFILEP+4,FILE='PROTON-GAUGE-OEVERLAP.dat',
C     * STATUS='UNKNOWN',FORM='FORMATTED')
C      END IF
C  111 FORMAT(1X,I5,3X,F10.5,3X,'(',1x,F16.6,',',1x,F16.6,')',
C     * 3X, '(',1x,F20.6,',',1x,F20.6,')',
C     * 3X, '(',1x,F20.6,',',1x,F20.6,')',
C     * 3X, '(',1x,F20.6,',',1x,F20.6,')',
C     * 3X, '(',1x,F25.6,',',1x,F25.6,')',
C     * 3X, '(',1x,F25.6,',',1x,F25.6,')')
C  112 FORMAT(1X,I5,3X,F10.5,3X,'(',1x,F16.6,')',
C     * 3X, '(',1x,F16.6,')',
C     * 3X, '(',1x,F16.6,')',
C     * 3X, '(',1x,F16.6,')',
C     * 3X, '(',1x,F24.6,')',
C     * 3X, '(',1x,F24.6,')')
C  113 FORMAT(1X,I5,3X,F10.7,3X,'(',1x,F18.14,',',1x,F18.14,')',
C     * 3X, '(',1x,F18.14,')',
C     * 3X, '(',1x,F18.14,',',1x,F18.14,')',
C     * 3X, '(',1x,F18.14,')')
C
C  --------------SEQUNTIAL OUTPUT----------------------------------------------
C
C       DO IPOINT = 1, NPGAUG
C       THETAN= (IPOINT-1.0d0) * 2*PI / NPGAUG
C       WRITE(NFILEP,111)IPOINT,THETAN,(RLIPNU(IORDER,IPOINT,ICHARG),
C     * IORDER=1,6)
C       WRITE(NFILEP+1,111)IPOINT,THETAN,(NLIPNU(IORDER,IPOINT,ICHARG),
C     * IORDER=1,6)
C       WRITE(NFILEP+2,112)IPOINT,THETAN,(ABS(RLIPNU(IORDER,
C     * IPOINT,ICHARG)),IORDER=1,6)
C       WRITE(NFILEP+3,112)IPOINT,THETAN,(ABS(NLIPNU(IORDER,
C     * IPOINT,ICHARG)),IORDER=1,6)
C       WRITE(NFILEP+4,113)IPOINT,THETAN,OVRLAP(IPOINT,ICHARG),
C     * ABS(OVRLAP(IPOINT,ICHARG)),
C     * ILNOVR(IPOINT,ICHARG),
C     * ABS(ILNOVR(IPOINT,ICHARG))
C       END DO
C
C
       END IF
C
      CALL CPUTIM('LIPNAP',0)
C
C=======================================================================
C
      RETURN
      END
C
C=====================================================================
C
      SUBROUTINE LIPVAP(IN_FIX,IZ_FIX,ILIPON,ILIPOP,
     *                                       GAUSHI,
     *                         ISIMTX,JSIMTY,ISIMTZ,
     *                         ISIGNY,ISIMPY,ISIQTY,
     *                  IPAHFB,MREVER,IPNMIX,NUMCOU,
     *                  BOUCOU,ICOTYP,ICOUDI,ICOUEX,
     *                                       IDOTHC,
     *                  COUSCA,NAMEPN,PRINIT,IDEVAR,
     *                  ITERUN,ISYMDE,INIROT,INIINV,
     *                         INIKAR,ISAWAV,IKERNE,
     *                                       MIN_QP,
     *                                       ITWCEN)
      USE CANBAS
      USE WAVR_L
      USE HFODD_SIZES
C--------------------------------------------------------------------
C RHO_PP: DENSITY MATRIX
      USE MAT_PP
      USE MAT_PM
CDLI_PP
      USE MLI_PP
      USE MLI_PM
C---------------------------------------------------------------------------
C HIGH POWER OF DENSITIES:
      USE MAD2PP
      USE MAD3PP
      USE MAD4PP
      USE MAD5PP
C-----------------------------------------------------------------
C Input
C
C Number of Points for Particle-Number Projection of Neutrons/Protons
      INTEGER, INTENT(IN) :: ILIPON,ILIPOP
      REAL, INTENT(IN) :: GAUSHI
C Standard parameters -- see subroutine NAMELI
      INTEGER, INTENT(IN) :: IN_FIX,IZ_FIX
      INTEGER, INTENT(IN) :: ISIMTX,JSIMTY,ISIMTZ
      INTEGER, INTENT(IN) :: ISIGNY,ISIMPY,ISIQTY
      INTEGER, INTENT(IN) :: IPAHFB
      INTEGER, INTENT(IN) :: MREVER
      INTEGER, INTENT(IN) :: IPNMIX
      INTEGER, INTENT(IN) :: NUMCOU,ICOTYP,ICOUDI,ICOUEX
      REAL,    INTENT(IN) :: BOUCOU,COUSCA
      LOGICAL, INTENT(IN) :: PRINIT
      INTEGER, INTENT(IN) :: IDEVAR
      INTEGER, INTENT(IN) :: ITERUN
      INTEGER, INTENT(IN) :: ISYMDE
      INTEGER, INTENT(IN) :: INIROT
      INTEGER, INTENT(IN) :: INIINV
      INTEGER, INTENT(IN) :: INIKAR
      INTEGER, INTENT(IN) :: ISAWAV
C
      CHARACTER(LEN=8), INTENT(IN) :: NAMEPN
C
C-----------------------------------------------------------------
C=================================================================
C Globals
C
      INTEGER :: LDBASE, LDTOTS, LDSTAT, LDUPPE, LDTIMU, NUMBQP
      COMPLEX :: PHASPI, ECCALL
C
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMSTA/ LDTOTS(0:NDISOS),LDSTAT(0:NDISOS),
     *                LDUPPE(0:NDISOS),LDTIMU(0:NDISOS)
      COMMON
     *       /SPIPHA/ PHASPI(1:NDBASE,0:NDREVE,0:NDSPIN,1:NDTWCE)
      COMMON
     *       /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON
     *       /ECCSKY/ ECCALL(NDCOUT)
      COMMON
     *       /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON
     *       /ALLENE/ EKIN_N,EKIN_P,EKIN_T,
     *                EPOT_N,EPOT_P,EPOT_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *                EREA_N,EREA_P,EREA_T,
     *                ELIP_N,ELIP_P,ELIP_T,
     *
     *                ECOULD,ECOULE,ECOULT,
     *                       ECOULS,ECOULV,
     *
     *                EMULCO,EMUSLO,EMUREA,
     *                ESIFCO,ESISLO,ESIREA,
     *                ESPICO,ESPSLO,ESPREA,
     *
     *                ENREAR,ECORCM,ECOR_R,
     *
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
C=======================================================================
C                   COMMON BLOCK FOR LIPKIN ITERATION:
C=======================================================================
      INTEGER,PARAMETER :: NORDER = 10
      INTEGER,PARAMETER :: NODGAU = 1000
      REAL
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
      COMMON
     *       /LIPLAM/
     *       LAM2_N,LAM2_P,LAM4_N,LAM4_P,LAM6_N,LAM6_P
      REAL
     *       ELIP2N,ELIP2P,ELIP4N,ELIP4P,ELIP6N,ELIP6P,
     *       ELAM4N,ELAM6N,ELAM4P,ELAM6P
      COMMON
     *       /LIPADE/
     *       ELIP2N,ELIP2P,ELIP4N,ELIP4P,ELIP6N,ELIP6P,
     *       ELAM4N,ELAM6N,ELAM4P,ELAM6P
      COMMON
     *       /ISDLIP/ IS_DLI(0:NDISOS)
C
      INTEGER PROTPT,NEUTPT
C
      COMPLEX
     *          RLIPNU,NLIPNU
      COMMON
     *       /LIPNUM/
     *          RLIPNU(0:6,0:NODGAU,0:NDISOS),
     *          NLIPNU(0:6,0:NODGAU,0:NDISOS)
      COMPLEX
     *          ELIPNU
      DIMENSION
     *          ELIPNU(0:NODGAU,0:NODGAU)
C=======================================================================
      COMPLEX UNIT_I, C_ZERO,C_UNIT
C2*2
      COMPLEX AA,BB,CC,DD,EE
      COMPLEX EA,EB,EC,ED,EEE
C
      COMPLEX AAX,BBX,CCX,DDX,EEX,UUX
      COMPLEX KA,KB,KC,KD,KE
      INTEGER
     *        IA,IB,IC,ID,IE
      COMPLEX
     *        AUX,BUX,CUX,DUX,EUX
      DIMENSION
     *        AA(1:2,1:2),AUX(1:2,1:2),
     *        IA(1:2,1:2),AAX(1:2,1:2),
     *        KA(1:2),EA(1:2)
C3*3
      DIMENSION
     *        BB(1:3,1:3),BUX(1:3,1:3),
     *        IB(1:3,1:3),BBX(1:3,1:3),
     *        KB(1:3),EB(1:3)
C4*4
      DIMENSION
     *        CC(1:4,1:4),CUX(1:4,1:4),
     *        IC(1:4,1:4),CCX(1:4,1:4),
     *        KC(1:4),EC(1:4)
C5*5
      DIMENSION
     *        DD(1:5,1:5),DUX(1:5,1:5),
     *        ID(1:5,1:5),DDX(1:5,1:5),
     *        KD(1:5),ED(1:5)
C6*6
      DIMENSION
     *        EE(1:6,1:6),EUX(1:6,1:6),
     *        IE(1:6,1:6),EEX(1:6,1:6),
     *        KE(1:6),EEE(1:6)
      DIMENSION
     *        UUX(1:7,1:7)
      COMPLEX
     *          DETWRK,DETERM
      DIMENSION
     *          DETWRK(2)
      REAL
     *          RICOND
C=======================================================================
C
      REAL, PARAMETER :: PI = 4.0D0*ATAN(1.0D0)
C
C=======================================================================
C
      INTEGER :: IALLOC, IBASE,  ISTATE, JSTATE, ISPIN,ICHARG,IN, IP
      INTEGER :: IREVER, INN, IZZ
C
      REAL    :: THETAN, THETAP, ENEDUM
C
      COMPLEX :: ZSHIFN, ZSHIFP, ZSHIFT, CFUPPR, CFLOWR
      COMPLEX :: OVRLAP, EKERNL, EDUMCX
      COMPLEX :: EKEKIN(0:NDISOS),EKESKY,EKESCA,EKEVEC,
     *           EKEPAI(0:NDISOS),EKECOU,EKECOD,EKECOE
C
C=======================================================================
      CALL CPUTIM('LIPVAP',1)
C=======================================================================
CPrepare arrays for storing shifted wave functions
C
      IF (.NOT.ALLOCATED(WALEFT)) THEN
          ALLOCATE (WALEFT(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WALEFT','LIPVAP')
      END IF
      WALEFT(:,:,:) = 0.0d0
C
      IF (.NOT.ALLOCATED(WARIGH)) THEN
          ALLOCATE (WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('WARIGH','LIPVAP')
      END IF
      WARIGH(:,:,:) = 0.0d0
C=======================================================================
C
      IALLOC=0
C
      IF (.NOT.ALLOCATED(DLI_PP)) THEN
          ALLOCATE (DLI_PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                     STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DLI_PP','LIPVAP')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(DLI_PM).AND.ISIMPY.NE.1) THEN
           ALLOCATE (DLI_PM(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
           IF (IALLOC.NE.0) CALL NOALLO('DLI_PM','LIPVAP')
      END IF
C=======================================================================
C
C     PREPARE ARRAYS FOR HIGH POWER TERMS OF DENSITIES !
      IF (.NOT.ALLOCATED(DEN2PP)) THEN
          ALLOCATE (DEN2PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DEN2PP','LIPVAP')
      END IF
C
      IF (.NOT.ALLOCATED(DEN3PP)) THEN
      ALLOCATE (DEN3PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('DEN3PP','LIPVAP')
      END IF
C
C=======================================================================
C     PREPARE ARRAYS FOR HIGH POWER TERMS OF DENSITIES !
      IF (.NOT.ALLOCATED(DEN4PP)) THEN
          ALLOCATE (DEN4PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DEN4PP','LIPVAP')
      END IF
C
      IF (.NOT.ALLOCATED(DEN5PP)) THEN
          ALLOCATE (DEN5PP(1:NDBASE,1:NDBASE,0:NDREVE,0:NDISOS),
     *                                                      STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('DEN5PP','LIPVAP')
      END IF
C
C=======================================================================
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
      C_ZERO=CMPLX(0.0D0,0.0D0)
      C_UNIT=CMPLX(1.0D0,0.0D0)
C
      ELIPNU(1, 1)=ETOTFU
C
C
      IF (ILIPON.LT.2) NEUTPT=1
      IF (ILIPON.EQ.2) NEUTPT=2
      IF (ILIPON.EQ.4) NEUTPT=3
      IF (ILIPON.EQ.6) NEUTPT=4
C
      IF (ILIPOP.LT.2) PROTPT=1
      IF (ILIPOP.EQ.2) PROTPT=2
      IF (ILIPOP.EQ.4) PROTPT=3
      IF (ILIPOP.EQ.6) PROTPT=4
C
      IF (ILIPON.GT.1) THEN
          THETSN= GAUSHI/(NEUTPT-1.0D0)
          THETAN=-THETSN
      ELSE
          THETSN=0.0D0
          THETAN=0.0D0
      END IF
C
      IF (ILIPOP.GT.1) THEN
          THETSP= GAUSHI/(PROTPT-1.0D0)
          THETAP=-THETSP
      ELSE
          THETSP=0.0D0
          THETAP=0.0D0
      END IF
C
      DO IN = 1, NEUTPT
         DO IP = 1, PROTPT
C
C Init energy kernel. We'll add up contributions there.
C
C
C...........................................................
            DO ICHARG=0,NDISOS
C
C            IF (IN.EQ.1.AND.IP.EQ.1) GO TO 111
C
               IF (ICHARG.EQ.0.AND.NEUTPT.EQ.1) THEN
                   EKEKIN(0)=EKIN_N
                   EKEPAI(0)=EPAI_N
                   GO TO 222
               END IF
C
               IF (ICHARG.EQ.1.AND.PROTPT.EQ.1) THEN
                   EKEKIN(1)=EKIN_P
                   EKEPAI(1)=EPAI_P
                   EKECOU=ECOULT
C
                   GO TO 222
               END IF
C
               EKERNL=0.0d0
C
C
               THETAN=THETSN*(IN-1.0D0)
               THETAP=THETSP*(IP-1.0D0)
C
C Complex shifts
               ZSHIFN=CMPLX(COS(THETAN), SIN(THETAN))
               ZSHIFP=CMPLX(COS(THETAP), SIN(THETAP))
C
C
C
C Shift (z)
               IF ( ICHARG == 0 ) THEN
C Neutrons
                  ZSHIFT = ZSHIFN
               ELSE
CProtons
                  ZSHIFT = ZSHIFP
               END IF
C
               JSTATE=0 ! Counter for wfs we put in WALEFT/WARIGH
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C First, upper components time+ then time-
               DO IREVER=0,1
C
CLoop on canonical states
                  DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
                     JSTATE=JSTATE+1
C
CLeft wave function
                     DO ISPIN=0,1
                        WALEFT(1:LDBASE,JSTATE,ISPIN) =
     *                        V_CAN(ISTATE,IREVER,ICHARG)
     *                        * WAVCAN(1:LDBASE,ISTATE,IREVER,ICHARG)
     *                        * PHASPI(1:LDBASE,IREVER,ISPIN,1)
                     END DO
C
C Right (shifted and normalized) wave function...
                     CFUPPR = ZSHIFT**2 * V_CAN(ISTATE,IREVER,ICHARG)
     *                     / ( U_CAN(ISTATE,IREVER,ICHARG)**2
     *                     +   (ZSHIFT*V_CAN(ISTATE,IREVER,ICHARG))**2 )
C
                     DO ISPIN=0,1
                        WARIGH(1:LDBASE,JSTATE,ISPIN) = CFUPPR
     *                        * WAVCAN(1:LDBASE,ISTATE,IREVER,ICHARG)
     *                        * PHASPI(1:LDBASE,IREVER,ISPIN,1)
                     END DO
                  END DO ! ISTATE
CNumber of time-up states
                  IF (IREVER==0) LDTIMU(ICHARG) = JSTATE
C
               END DO ! IREVER
C Number of upper HFB wave functions
               LDUPPE(ICHARG) = JSTATE
C
C . . . . . . . . . . . . . . . . . . . . . . . . . . . .
               DO IREVER=1,0,-1
C
                  DO ISTATE=1,NUMBQP(IREVER,ICHARG)
C
                     JSTATE=JSTATE+1
C
C                     ! Left wave function
                     DO ISPIN=0,1
                        WALEFT(1:LDBASE,JSTATE,ISPIN) =
     *                        U_CAN(ISTATE,IREVER,ICHARG) * (2*ISPIN-1)
     *                        * CONJG(
     *                        WAVCAN(1:LDBASE,ISTATE,IREVER,ICHARG)
     *                        * PHASPI(1:LDBASE,IREVER,1-ISPIN,1) )
                     END DO
C
C                    Right (normalized) wave function
C
                     CFLOWR = U_CAN(ISTATE,IREVER,ICHARG)
     *                     / ( U_CAN(ISTATE,IREVER,ICHARG)**2
     *                     +   (ZSHIFT*V_CAN(ISTATE,IREVER,ICHARG))**2 )
C
                     DO ISPIN=0,1
                        WARIGH(1:LDBASE,JSTATE,ISPIN) =
     *                       CFLOWR * (2*ISPIN-1)
     *                       * CONJG(
     *                       WAVCAN(1:LDBASE,ISTATE,IREVER,ICHARG)
     *                       * PHASPI(1:LDBASE,IREVER,1-ISPIN,1) )
                     END DO
C
                  END DO        ! ISTATE
C
C Number of states up to now....
                  IF(IREVER.EQ.1) LDSTAT(ICHARG) = JSTATE
C
               END DO           ! IREVER
C Total number of states
               LDTOTS(ICHARG) = JSTATE
C
C. . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C Calculating transition density matrix for K.E. computation
C (setting MREVER=1, see NB: above, and IPAHFB=1)
               CALL DENMAC(1,ICHARG,ISIMPY,1,WALEFT,WARIGH,1)
CCalculating kinetic energy kernel for current isospin
               CALL EKINET(ENEDUM,ENEDUM,EKEKIN(ICHARG),EDUMCX,1)
C
C
C. . . . . . . . . . . . . . . . . . . . . . . . . . . .
C
C Calculating transition densities for current isospin
C (setting IPAHFB=1, MREVER=1,
C ITPNMX=ICHARG, ITIREP=0, IKERNE=1)
               CALL ZEDENS(ICHARG) ! Zero densities first
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS 2.97F AND 2.99W, THE CALL TO DENSHF
C                   BELOW WAS PERFORMED WITH VARIABLE MIN_QP  ERRONOUSLY
C                   REPLACED BY AN UNDEFINED VARIABLE IGRAIN.  THIS  BUG
C                   WAS CORRECTED ON 17/09/2020 IN VERSION 2.99X.
C=======================================================================
C
                   CALL DENSHF(ISIMTX,JSIMTY,ISIMTZ,
     *                     ISIGNY,ISIMPY,ISIQTY,1     ,1     ,ICHARG,
     *                                          MIN_QP,IPNMIX,ICHARG,
     *                            0     ,NAMEPN,PRINIT,IDEVAR,ITERUN,
     *                     ISYMDE,INIROT,INIINV,INIKAR,ISAWAV,1     ,
     *                                                 ITWCEN,1)
C
C=======================================================================
C
C               DEN2PP, DEN3PP, etc
C
C=======================================================================
C               BETWEEN VERSIONS >271A AND <=273I, ARRAY DLI_PP WAS
C               UPDATED BASED ON THE VALUE OF RHO_PP,  WHICH IS NOT
C               COMPUTED WITHIN THE CURRENT LOOP BUT IN CANQUA().
C=======================================================================
C
               IF (IN.EQ.1.AND.IP.EQ.1) THEN
CDLI_PP
                   IF ((ICHARG.EQ.0.AND.ILIPON.GT.1).OR.
     *                 (ICHARG.EQ.1.AND.ILIPOP.GT.1)) THEN
C
                        DLI_PP(:,:,0,ICHARG)=BIG_PP(:,:,0)
                        DLI_PP(:,:,1,ICHARG)=BIG_PP(:,:,1)
C
                   END IF
C
                   IS_DLI(ICHARG)=1
C
                   IF ((ICHARG.EQ.0.AND.ILIPON.GT.3).OR.
     *                 (ICHARG.EQ.1.AND.ILIPOP.GT.3)) THEN
C
CDEN2PP
                        DEN2PP(:,:,:,ICHARG)=C_ZERO
C
                        CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                              C_UNIT,BIG_PP(:,:,0),NDBASE,
     *                                     BIG_PP(:,:,0),NDBASE,
     *                              C_ZERO,DEN2PP(1,1,0,ICHARG),NDBASE)
C
                        CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                              C_UNIT,BIG_PP(:,:,1),NDBASE,
     *                                     BIG_PP(:,:,1),NDBASE,
     *                              C_ZERO,DEN2PP(1,1,1,ICHARG),NDBASE)
C
CDEN3PP
                        DEN3PP(:,:,:,ICHARG)=C_ZERO
C
                        CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                              C_UNIT,BIG_PP(:,:,0),NDBASE,
     *                                     DEN2PP(:,:,0,ICHARG),NDBASE,
     *                              C_ZERO,DEN3PP(1,1,0,ICHARG),NDBASE)
C
                        CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                              C_UNIT,BIG_PP(:,:,1),NDBASE,
     *                                     DEN2PP(:,:,1,ICHARG),NDBASE,
     *                              C_ZERO,DEN3PP(1,1,1,ICHARG),NDBASE)
C
                   END IF
C
                   IF ((ICHARG.EQ.0.AND.ILIPON.EQ.6).OR.
     *                 (ICHARG.EQ.1.AND.ILIPOP.EQ.6)) THEN
C
CDEN4PP
                        DEN4PP(:,:,:,ICHARG)=C_ZERO
C
                        CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                              C_UNIT,BIG_PP(:,:,0),NDBASE,
     *                                     DEN3PP(:,:,0,ICHARG),NDBASE,
     *                              C_ZERO,DEN4PP(1,1,0,ICHARG),NDBASE)
C
                        CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                              C_UNIT,BIG_PP(:,:,1),NDBASE,
     *                                     DEN3PP(:,:,1,ICHARG),NDBASE,
     *                              C_ZERO,DEN4PP(1,1,1,ICHARG),NDBASE)
C
CDEN5PP
                        DEN5PP(:,:,:,ICHARG)=C_ZERO
C
                        CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                              C_UNIT,BIG_PP(:,:,0),NDBASE,
     *                                     DEN4PP(:,:,0,ICHARG),NDBASE,
     *                              C_ZERO,DEN5PP(1,1,0,ICHARG),NDBASE)
C
                        CALL ZGEMM('N','N',LDBASE,LDBASE,LDBASE,
     *                              C_UNIT,BIG_PP(:,:,1),NDBASE,
     *                                     DEN4PP(:,:,1,ICHARG),NDBASE,
     *                              C_ZERO,DEN5PP(1,1,1,ICHARG),NDBASE)
C
                   END IF
C
               END IF
C
C=======================================================================
C
C               DEN2PP, DEN3PP, etc ENDED
C
C=======================================================================
C
  222          CONTINUE
C
            END DO ! End DO ICHARG
C
            IF (PROTPT.GT.1) THEN
C
C...........................................................
C Calculate Coulomb energy kernel with previously calculated
C densities
C
C Default value if no Coulomb
                EKECOD = 0.0d0
                EKECOE = 0.0d0
C
C Calculate charge density
                CALL TRUCHD
C
C Direct Coulomb field and energy by solution of Poisson's
C equation
                IF (ICOUDI.EQ.1) THEN
C (setting IKERNE=1)
                    CALL COUMAT(NUMCOU,BOUCOU,ISIMPY,1)
                    CALL COULOD(ISIMPY,EKECOD)
                END IF
C
                IF (ICOUEX.EQ.1) THEN
                    CALL COULOE(EKECOE)
                END IF
C
                IF (ICOUDI.EQ.2.OR.ICOUEX.EQ.2) THEN
                    CALL COUENE(ISIMPY,
     *                          ICOTYP,ICOUDI,ICOUEX,
     *                                        IDOTHC,
     *                          EKECOD,EKESCA,EKEVEC)
C
                    IF (ICOUEX.EQ.2) EKECOE=EKESCA+EKEVEC
                END IF
C
C To match HFBTHO
                EKECOD = CONJG(EKECOD)
                EKECOE = CONJG(EKECOE)
C
C Direct+exchange coulomb energy
                EKECOU=EKECOD + EKECOE*COUSCA
C
            END IF
C
C
C..........................................................
CCalculate Skyrme energy kernel with previously calculated
Cdensities
C
C Calculate density for density-dependent terms
            CALL TRUTOD(1,1)
C
C Skyrme energy (setting LDPNMX=1)
            CALL ESKYRM(ENEDUM,ENEDUM,ENEDUM,ENEDUM,ENEDUM,ENEDUM,
     *                                   ENEDUM,EKESKY,1,IVIPRI,1)
C(Components of Skyrme energy now stored in ECCALL)
C
CSame for Pairing energy.
            DO ICHARG=0,NDISOS
               IF (ICHARG.EQ.0.AND.NEUTPT.EQ.1) GO TO 333
               IF (ICHARG.EQ.1.AND.PROTPT.EQ.1) GO TO 333
C(setting ITPNMX=ICHARG)
               CALL EPAIRI(IN_FIX,IZ_FIX,ICHARG,EKEPAI(ICHARG),1)
  333          CONTINUE
            END DO
C
C To match HFBTHO
            EKESKY    = CONJG(EKESKY)
            ECCALL(:) = CONJG(ECCALL(:))
            EKEPAI(:) = CONJG(EKEPAI(:))
C
C...........................................................
C
C . ..........................................................
            EKERNL=EKEKIN(0)+EKEKIN(1)+EKESKY+EKECOU
     *                     + EKEPAI(0)+EKEPAI(1)
C
            ELIPNU(IN, IP)=EKERNL
C
C
C 111       CONTINUE
C
C
         END DO ! IP
      END DO ! IN
C
C (end loop on gauge-angle integration points)
C-----------------------------------------------------------------
C
C=======================================================================
C     BEGIN THE CALCULATIONS OF COEFICIENTS FOR LIPKIN METHOD!
C=======================================================================
C
C=======================================================================
C                             NEUTRON:
C=======================================================================
C
      IF (ILIPON.EQ.2) THEN
C
          IN=2
C
          AA(1,1)=C_UNIT
          AA(1,2)=REAL(NLIPNU(2,1,0))
          AA(2,1)=C_UNIT
          AA(2,2)=REAL(NLIPNU(2,IN,0))
C
          IF (REAL(NLIPNU(1,1,0)).GT.0.000001) THEN
              EA(1)=REAL(ELIPNU(1,1))
              EA(2)=REAL(ELIPNU(IN,1))
          ELSE
              EA(1)=REAL(ELIPNU(1,1))
              EA(2)=REAL(ELIPNU(IN,1)-EFERMN*NLIPNU(1,IN,0))
          END IF
C
C----------------------------------------------------------------------
C
          mm=2
C
          DO ii=1,mm
             DO nn=1,mm
                AAX(nn,ii)=AA(nn,ii)
                UUX(nn,ii)=C_ZERO
             END DO
          END DO
C
          CALL ZGECO(AA,mm,mm,IA,RICOND,AUX)
C
          CALL ZGEDI(AA,mm,mm,IA,DETWRK,AUX,11)
C
          determ = DETWRK(1) * 10.0**REAL(DETWRK(2))
C
          DO nn=1,mm
             KA(nn)=C_ZERO
          END DO
C
          DO ii=1,mm
             DO nn=1,mm
C
                DO kk=1,mm
                   UUX(ii,nn)=UUX(ii,nn)+AA(ii,kk)*AAX(kk,nn)
                END DO
C
             END DO
          END DO
C
C          write(*,*)'check unitary'
C          DO nn=1,mm
C          WRITE(*,*) (UUX(nn,ii),ii=1,mm)
C          END DO
C
          DO ii=1,mm
             DO nn=1,mm
                KA(ii)=KA(ii)+AA(ii,nn)*EA(nn)
             END DO
          END DO
C
C          PRINT *,THETAN,KA(1),KA(2)
C
          LAM2_N=REAL(KA(2))
          ELIP2N=REAL(KA(1)-ELIPNU(1,1))
C
          IF (PRINIT) THEN
C
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',22x,'' LIPKIN METHOD ON '',
     *                       ''PARTICLE NUMBER'',22x,''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  LAM2_N=     '',f15.6,7X,
     *                       ''n_2=    '',f15.6,18x,''*'')')
     *                         LAM2_N, REAL(NLIPNU(2,1,0))
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  ELIP2N=     '',f15.6,48x,''*'')')
     *                            ELIP2N
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
C
          END IF
C
          IF (LAM2_N.GT.3.0D0.OR.LAM2_N.LT.0.0D0) THEN
C              PRINT *, 'TOO LARGE LAM2_N, SET 0.10'
              LAM2_N=0.1D0;ELIP2N=0.1D0*REAL(NLIPNU(2,1,0))
          END IF
C
C
      END IF
C
C----------------------------------------------------------------------!
C       4TH LIPKIN METHOD
C----------------------------------------------------------------------!
C
      IF (ILIPON.EQ.4) THEN
C
          IN=3
C
          BB(1,1)=C_UNIT
          BB(1,2)=REAL(NLIPNU(2,1,0))
          BB(1,3)=REAL(NLIPNU(4,1,0))
          BB(2,1)=C_UNIT
          BB(2,2)=REAL(NLIPNU(2,2,0))
          BB(2,3)=REAL(NLIPNU(4,2,0))
          BB(3,1)=C_UNIT
          BB(3,2)=REAL(NLIPNU(2,IN,0))
          BB(3,3)=REAL(NLIPNU(4,IN,0))
C
          IF (REAL(NLIPNU(1,1,0)).GT.0.000001) THEN
              EB(1)=REAL(ELIPNU(1,1))
              EB(2)=REAL(ELIPNU(2,1))
              EB(3)=REAL(ELIPNU(IN,1))
          ELSE
              EB(1)=REAL(ELIPNU(1,1))
              EB(2)=REAL(ELIPNU(2,1)-EFERMN*NLIPNU(1,2,0))
              EB(3)=REAL(ELIPNU(IN,1)-EFERMN*NLIPNU(1,IN,0))
          END IF
C
C----------------------------------------------------------------------
C
          mm=3
C
          DO ii=1,mm
             DO nn=1,mm
                BBX(nn,ii)=BB(nn,ii)
                UUX(nn,ii)=C_ZERO
             END DO
          END DO
C
          CALL ZGECO(BB,mm,mm,IB,RICOND,BUX)
C
          CALL ZGEDI(BB,mm,mm,IB,DETWRK,BUX,11)
C
          determ = DETWRK(1) * 10.0**REAL(DETWRK(2))
C
          DO nn=1,mm
             KB(nn)=C_ZERO
          END DO
C
C
          DO ii=1,mm
             DO nn=1,mm
                KB(ii)=KB(ii)+BB(ii,nn)*EB(nn)
             END DO
          END DO
C
          LAM2_N=REAL(KB(2))
          LAM4_N=REAL(KB(3))
C
          ELIP4N=REAL(KB(1)-ELIPNU(1,1))
C
          IF (PRINIT) THEN
C
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',22x,'' LIPKIN METHOD ON '',
     *                       ''PARTICLE NUMBER'',22x,''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  LAM2_N=     '',f15.6,7X,
     *                       ''n_2=    '',f15.6,18x,''*'')')
     *                         LAM2_N, REAL(NLIPNU(2,1,0))
              WRITE(NFIPRI,'(''*  LAM4_N=     '',f15.6,7X,
     *                       ''n_4=    '',f15.6,18x,''*'')')
     *                         LAM4_N, REAL(NLIPNU(4,1,0))
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  ELIP4N=     '',f15.6,48x,''*'')')
     *                            ELIP4N
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
C
          END IF
C
          IF (LAM2_N.GT.3.0D0.OR.LAM4_N.GT.1.0D0.OR.
     *        LAM2_N.LT.0.0D0) THEN
C               PRINT *, 'TOO LARGE LAM_N, SET 0.10'
              LAM2_N=0.1D0;ELIP4N=0.1D0*REAL(NLIPNU(2,1,0))
              LAM4_N=0.0D0
          END IF
C
      END IF
C
C----------------------------------------------------------------------!
C       6TH LIPKIN METHOD
C----------------------------------------------------------------------!
C
      IF (ILIPON.EQ.6) THEN    !.AND.ITERUN.GT.29
C
          IN=4
C
          CC(1,1)=C_UNIT
          CC(1,2)=REAL(NLIPNU(2,1,0))
          CC(1,3)=REAL(NLIPNU(4,1,0))
          CC(1,4)=REAL(NLIPNU(6,1,0))
          CC(2,1)=C_UNIT
          CC(2,2)=REAL(NLIPNU(2,2,0))
          CC(2,3)=REAL(NLIPNU(4,2,0))
          CC(2,4)=REAL(NLIPNU(6,2,0))
          CC(3,1)=C_UNIT
          CC(3,2)=REAL(NLIPNU(2,3,0))
          CC(3,3)=REAL(NLIPNU(4,3,0))
          CC(3,4)=REAL(NLIPNU(6,3,0))
          CC(4,1)=C_UNIT
          CC(4,2)=REAL(NLIPNU(2,IN,0))
          CC(4,3)=REAL(NLIPNU(4,IN,0))
          CC(4,4)=REAL(NLIPNU(6,IN,0))
C
          IF (REAL(NLIPNU(1,1,0)).GT.0.000001) THEN
              EC(1)=REAL(ELIPNU(1,1))
              EC(2)=REAL(ELIPNU(2,1))
              EC(3)=REAL(ELIPNU(3,1))
              EC(4)=REAL(ELIPNU(IN,1))
          ELSE
              EC(1)=REAL(ELIPNU(1,1))
              EC(2)=REAL(ELIPNU(2,1)-EFERMN*NLIPNU(1,2,0))
              EC(3)=REAL(ELIPNU(3,1)-EFERMN*NLIPNU(1,3,0))
              EC(4)=REAL(ELIPNU(IN,1)-EFERMN*NLIPNU(1,IN,0))
          END IF
C
C----------------------------------------------------------------------
C
          mm=4
C
          CALL ZGECO(CC,mm,mm,IC,RICOND,CUX)
C
          CALL ZGEDI(CC,mm,mm,IC,DETWRK,CUX,11)
C
          determ = DETWRK(1) * 10.0**REAL(DETWRK(2))
C
          DO nn=1,mm
             KC(nn)=C_ZERO
          END DO
C
          DO ii=1,mm
             DO nn=1,mm
                KC(ii)=KC(ii)+CC(ii,nn)*EC(nn)
             END DO
          END DO
C
          LAM2_N=REAL(KC(2))
          LAM4_N=REAL(KC(3))
          LAM6_N=REAL(KC(4))
C
          ELIP6N=REAL(KC(1)-ELIPNU(1,1))
C
          IF (PRINIT) THEN
C
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',22x,'' LIPKIN METHOD ON '',
     *                       ''PARTICLE NUMBER'',22x,''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  LAM2_N=     '',f15.6,7X,
     *                       ''n_2=    '',f15.6,18x,''*'')')
     *                         LAM2_N, REAL(NLIPNU(2,1,0))
              WRITE(NFIPRI,'(''*  LAM4_N=     '',f15.6,7X,
     *                       ''n_4=    '',f15.6,18x,''*'')')
     *                         LAM4_N, REAL(NLIPNU(4,1,0))
              WRITE(NFIPRI,'(''*  LAM6_N=     '',f15.6,7X,
     *                       ''n_6=    '',f15.6,18x,''*'')')
     *                         LAM6_N, REAL(NLIPNU(6,1,0))
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  ELIP6N=     '',f15.6,48x,''*'')')
     *                            ELIP6N
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
C
          END IF
C
          IF (LAM2_N.GT.3.0D0.OR.LAM4_N.GT.1.0D0.OR.
     *        LAM6_N.GT.1.0D0.OR.LAM2_N.LT.0.0D0) THEN
C              PRINT *, 'TOO LARGE LAM_N, SET 0.1D0'
              LAM2_N=0.1D0;ELIP6N=0.1D0*REAL(NLIPNU(2,1,0))
              LAM4_N=0.0D0
              LAM6_N=0.0D0
          END IF
C
      END IF
C
C=======================================================================
C                             PROTON:
C=======================================================================
C
      IF (ILIPOP.EQ.2) THEN
C
          IP=2
C
          AA(1,1)=C_UNIT
          AA(1,2)=REAL(NLIPNU(2,1,1))
          AA(2,1)=C_UNIT
          AA(2,2)=REAL(NLIPNU(2,IP,1))
C
          IF (REAL(NLIPNU(1,1,1)).GT.0.000001) THEN
              EA(1)=REAL(ELIPNU(1,1))
              EA(2)=REAL(ELIPNU(1,IP))
          ELSE
              EA(1)=REAL(ELIPNU(1,1))
              EA(2)=REAL(ELIPNU(1,IP)-EFERMP*NLIPNU(1,IP,1))
          END IF
C
C----------------------------------------------------------------------
C
          mm=2
C
          DO ii=1,mm
             DO nn=1,mm
                AAX(nn,ii)=AA(nn,ii)
                UUX(nn,ii)=C_ZERO
             END DO
          END DO
C
          CALL ZGECO(AA,mm,mm,IA,RICOND,AUX)
C
          CALL ZGEDI(AA,mm,mm,IA,DETWRK,AUX,11)
C
          determ = DETWRK(1) * 10.0**REAL(DETWRK(2))
C
          DO nn=1,mm
             KA(nn)=C_ZERO
          END DO
C
          DO ii=1,mm
             DO nn=1,mm
                KA(ii)=KA(ii)+AA(ii,nn)*EA(nn)
             END DO
          END DO
C          WRITE(NFILEK+1,*)THETAN,KA(1),KA(2)
C
          LAM2_P=REAL(KA(2))
C
          ELIP2P=REAL(KA(1)-ELIPNU(1,1))
C
          IF (PRINIT) THEN
C
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',22x,'' LIPKIN METHOD ON '',
     *                       ''PARTICLE NUMBER'',22x,''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  LAM2_P=     '',f15.6,7X,
     *                       ''p_2=    '',f15.6,18x,''*'')')
     *                         LAM2_P, REAL(NLIPNU(2,1,1))
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  ELIP2P=     '',f15.6,48x,''*'')')
     *                            ELIP2P
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
C
          END IF
C
          IF (LAM2_P.GT.3.0D0.OR.LAM2_P.LT.0.0D0) THEN
C              PRINT *, 'TOO LARGE LAM2_P, SET 0.1D0'
              LAM2_P=0.1D0;ELIP2P=LAM2_P*REAL(NLIPNU(2,1,1))
          END IF
C
      END IF
C
C----------------------------------------------------------------------!
C       4TH LIPKIN METHOD
C----------------------------------------------------------------------!
C
      IF (ILIPOP.EQ.4) THEN
C
          IP=3
C
          BB(1,1)=C_UNIT
          BB(1,2)=REAL(NLIPNU(2,1,1))
          BB(1,3)=REAL(NLIPNU(4,1,1))
          BB(2,1)=C_UNIT
          BB(2,2)=REAL(NLIPNU(2,2,1))
          BB(2,3)=REAL(NLIPNU(4,2,1))
          BB(3,1)=C_UNIT
          BB(3,2)=REAL(NLIPNU(2,IP,1))
          BB(3,3)=REAL(NLIPNU(4,IP,1))
C
          IF (REAL(NLIPNU(1,1,1)).GT.0.000001) THEN
              EB(1)=REAL(ELIPNU(1,1))
              EB(2)=REAL(ELIPNU(1,2))
              EB(3)=REAL(ELIPNU(1,IP))
          ELSE
              EB(1)=REAL(ELIPNU(1,1))
              EB(2)=REAL(ELIPNU(1,2)-EFERMP*NLIPNU(1,2,1))
              EB(3)=REAL(ELIPNU(1,IP)-EFERMP*NLIPNU(1,IP,1))
          END IF
C
C----------------------------------------------------------------------
C
          mm=3
C
C
          DO ii=1,mm
             DO nn=1,mm
                BBX(nn,ii)=BB(nn,ii)
                UUX(nn,ii)=C_ZERO
             END DO
          END DO
C
          CALL ZGECO(BB,mm,mm,IB,RICOND,BUX)
C
          CALL ZGEDI(BB,mm,mm,IB,DETWRK,BUX,11)
C
          determ = DETWRK(1) * 10.0**REAL(DETWRK(2))
C
          DO nn=1,mm
             KB(nn)=C_ZERO
          END DO
C
          DO ii=1,mm
             DO nn=1,mm
                KB(ii)=KB(ii)+BB(ii,nn)*EB(nn)
             END DO
          END DO
C
          LAM2_P=REAL(KB(2))
          LAM4_P=REAL(KB(3))
C
          ELIP4P=REAL(KB(1)-ELIPNU(1,1))
C
          IF (PRINIT) THEN
C
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',22x,'' LIPKIN METHOD ON '',
     *                       ''PARTICLE NUMBER'',22x,''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  LAM2_P=     '',f15.6,7X,
     *                       ''p_2=    '',f15.6,18x,''*'')')
     *                         LAM2_P, REAL(NLIPNU(2,1,1))
              WRITE(NFIPRI,'(''*  LAM4_P=     '',f15.6,7X,
     *                       ''p_4=    '',f15.6,18x,''*'')')
     *                         LAM4_P, REAL(NLIPNU(4,1,1))
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  ELIP4P=     '',f15.6,48x,''*'')')
     *                            ELIP4P
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
C
          END IF
C
          IF (LAM2_P.GT.3.0D0.OR.LAM4_P.GT.1.0D0.OR.
     *        LAM2_P.LT.0.0D0) THEN
C              PRINT *, 'TOO LARGE LAM_P, SET 0.1D0'
              LAM2_P=0.1D0;ELIP4P=LAM2_P*REAL(NLIPNU(2,1,1))
              LAM4_P=0.0D0
          END IF
C
      END IF
C
C----------------------------------------------------------------------!
C       6TH LIPKIN METHOD
C----------------------------------------------------------------------!
C
      IF (ILIPOP.EQ.6) THEN    !.AND.ITERUN.GT.29
C
          IP=4
C
          CC(1,1)=C_UNIT
          CC(1,2)=REAL(NLIPNU(2,1,1))
          CC(1,3)=REAL(NLIPNU(4,1,1))
          CC(1,4)=REAL(NLIPNU(6,1,1))
          CC(2,1)=C_UNIT
          CC(2,2)=REAL(NLIPNU(2,2,1))
          CC(2,3)=REAL(NLIPNU(4,2,1))
          CC(2,4)=REAL(NLIPNU(6,2,1))
          CC(3,1)=C_UNIT
          CC(3,2)=REAL(NLIPNU(2,3,1))
          CC(3,3)=REAL(NLIPNU(4,3,1))
          CC(3,4)=REAL(NLIPNU(6,3,1))
          CC(4,1)=C_UNIT
          CC(4,2)=REAL(NLIPNU(2,IP,1))
          CC(4,3)=REAL(NLIPNU(4,IP,1))
          CC(4,4)=REAL(NLIPNU(6,IP,1))
C
          IF (REAL(NLIPNU(1,1,1)).GT.0.000001) THEN
              EC(1)=REAL(ELIPNU(1,1))
              EC(2)=REAL(ELIPNU(1,2))
              EC(3)=REAL(ELIPNU(1,3))
              EC(4)=REAL(ELIPNU(1,IP))
          ELSE
              EC(1)=REAL(ELIPNU(1,1))
              EC(2)=REAL(ELIPNU(1,2)-EFERMP*NLIPNU(1,2,1))
              EC(3)=REAL(ELIPNU(1,3)-EFERMP*NLIPNU(1,3,1))
              EC(4)=REAL(ELIPNU(1,IP)-EFERMP*NLIPNU(1,IP,1))
          END IF
C
C----------------------------------------------------------------------
C
          mm=4
C
          CALL ZGECO(CC,mm,mm,IC,RICOND,CUX)
C
          CALL ZGEDI(CC,mm,mm,IC,DETWRK,CUX,11)
C
          determ = DETWRK(1) * 10.0**REAL(DETWRK(2))
C
          DO nn=1,mm
             KC(nn)=C_ZERO
          END DO
C
          DO ii=1,mm
             DO nn=1,mm
                KC(ii)=KC(ii)+CC(ii,nn)*EC(nn)
             END DO
          END DO
C
          LAM2_P=REAL(KC(2))
          LAM4_P=REAL(KC(3))
          LAM6_P=REAL(KC(4))
C
          ELIP6P=REAL(KC(1)-ELIPNU(1,1))
C
          IF (PRINIT) THEN
C
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',22x,'' LIPKIN METHOD ON '',
     *                       ''PARTICLE NUMBER'',22x,''*'')')
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  LAM2_P=     '',f15.6,7X,
     *                       ''p_2=    '',f15.6,18x,''*'')')
     *                         LAM2_P, REAL(NLIPNU(2,1,1))
              WRITE(NFIPRI,'(''*  LAM4_P=     '',f15.6,7X,
     *                       ''p_4=    '',f15.6,18x,''*'')')
     *                         LAM4_P, REAL(NLIPNU(4,1,1))
              WRITE(NFIPRI,'(''*  LAM6_P=     '',f15.6,7X,
     *                       ''p_6=    '',f15.6,18x,''*'')')
     *                         LAM6_P, REAL(NLIPNU(6,1,1))
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*  ELIP6P=     '',f15.6,48x,''*'')')
     *                            ELIP6P
              WRITE(NFIPRI,'(''*'',77x,''*'')')
              WRITE(NFIPRI,'(''*'',77(''*''),''*'')')
C
          END IF
C
          IF(LAM2_P.GT.3.0D0.OR.LAM4_P.GT.1.0D0.OR.
     *       LAM6_P.GT.1.0D0.OR.LAM2_P.LT.0.0D0) THEN
C             PRINT *, 'TOO LARGE LAM_P, SET 0.1D0'
             LAM2_P=0.1D0;ELIP6P=LAM2_P*REAL(NLIPNU(2,1,1))
             LAM4_P=0.0D0
             LAM6_P=0.0D0
          END IF
C
      END IF
C
C=======================================================================
C
      CALL CPUTIM('LIPVAP',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE WSHAMI(ITILAX,ITISAX,NO_ORB,ICHARG,ISIMPY)
C=======================================================================
      USE SPINOR
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          RESULT
C=======================================================================
      COMPLEX
     *          TIMEPP,TIMEPM,TIMEMP,TIMEMM
C
C=======================================================================
      ALLOCATABLE HAUXIL(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
C=======================================================================
      COMMON
     *       /SPE_WS/ ESINWS(1:NDBASE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXIL(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXIL','WSHAMI')
C=======================================================================
      IF (.NOT.ALLOCATED(BIG_PP)) THEN
          ALLOCATE (BIG_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PP','WSHAMI')
      END IF
      IF (.NOT.ALLOCATED(BIG_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (BIG_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PM','WSHAMI')
      END IF
C=======================================================================
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE CRANKED WOODS-SAXON HAMILTONIAN
C=======================================================================
C        ZEROING THE HAMILTONIAN
C=======================================================================
C
      BIG_PP(:,:,:)=CMPLX(0.0D0,0.0D0)
      IF (ISIMPY.NE.1) THEN
          BIG_PM(:,:,:)=CMPLX(0.0D0,0.0D0)
      END IF
C
C=======================================================================
C          INSERTING THE CRANKING MATRIX ELEMENTS
C=======================================================================
C
      IF (ITILAX.EQ.0.AND.ITISAX.EQ.0) GO TO 2
C
      IF (ISIMPY.EQ.1) GO TO 2
C
C=======================================================================
C          X-DIRECTION
C=======================================================================
C
      OMEGAC=0.0D0
      IF (ITILAX.NE.0) OMEGAC=OMEGAC+             OMOVAX
      IF (ITISAX.NE.0) OMEGAC=OMEGAC+(1-2*ICHARG)*OMISOX
C
      IF (NO_ORB.NE.1) THEN
C
          CALL INT_LX(IPHAPM(0,0,0),HAUXIL,OMEGAC)
C
          CALL PUTIMA(-1,HAUXIL,BIG_PM(1,1,1))
C
      END IF
C
      CALL INT_SX(HAUXIL,OMEGAC)
C
      CALL PUTREA(-1,HAUXIL,BIG_PM(1,1,1))
C
C=======================================================================
C          Z-DIRECTION
C=======================================================================
C
      OMEGAC=0.0D0
      IF (ITILAX.NE.0) OMEGAC=OMEGAC+             OMOVAZ
      IF (ITISAX.NE.0) OMEGAC=OMEGAC+(1-2*ICHARG)*OMISOZ
C
      IF (NO_ORB.NE.1) THEN
C
          CALL INT_LZ(IPHAPM(0,0,0),HAUXIL,OMEGAC)
C
          CALL PUTIMA(-1,HAUXIL,BIG_PM(1,1,1))
C
      END IF
C
      CALL INT_SZ(HAUXIL,OMEGAC)
C
      CALL PUTIMA(-1,HAUXIL,BIG_PM(1,1,1))
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C          Y-DIRECTION
C=======================================================================
C
      OMEGAC=OMOVAY+(1-2*ICHARG)*OMISOY
C
      IF (NO_ORB.NE.1) THEN
C
          CALL INT_LY(IPHAPP(0,0,0),HAUXIL,OMEGAC)
C
          CALL PUTIMA(-1,HAUXIL,BIG_PP(1,1,1))
C
      END IF
C
      CALL INT_SY(HAUXIL,OMEGAC)
C
      CALL PUTREA(-1,HAUXIL,BIG_PP(1,1,1))
C
C=======================================================================
C        CALCULATING THE BLOCKS OF THE HAMILTONIAN THAT ARE DIAGONAL IN
C        SIMPLEX. THE WAVE FUNCTIONS AND EIGEN ENERGIES ARE SUPPOSED TO
C        EXIST IN "WSWAVE" AND "SPESIM", RESPECTIVELY.
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            RESULT=CMPLX(0.0D0,0.0D0)
C
            DO ISTATE=1,LDBASE
               RESULT=RESULT+WSWAVE(IBRA,ISTATE,ICHARG)
     *                           *ESINWS(ISTATE,ICHARG)
     *               * CONJG(WSWAVE(IKET,ISTATE,ICHARG))
            END DO
C
            BIG_PP(IBRA,IKET,0)=BIG_PP(IBRA,IKET,0)+RESULT
C
         END DO
      END DO
C
C=======================================================================
C         COMBINING THE  TIME-EVEN  AND  TIME-ODD   PARTS
C              INTO THE  TIME-UP    AND  TIME-DOWN  PARTS
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            TIMEPP=       BIG_PP(IBRA,IKET,0) + BIG_PP(IBRA,IKET,1)
            TIMEMM= CONJG(BIG_PP(IBRA,IKET,0) - BIG_PP(IBRA,IKET,1))
C
            BIG_PP(IBRA,IKET,0) = TIMEPP
            BIG_PP(IBRA,IKET,1) = TIMEMM
C
         END DO
      END DO
C
      IF (ISIMPY.NE.1) THEN
C
          DO IKET=1,LDBASE
             DO IBRA=1,LDBASE
C
                TIMEPM=       BIG_PM(IBRA,IKET,0) + BIG_PM(IBRA,IKET,1)
                TIMEMP=-CONJG(BIG_PM(IBRA,IKET,0) - BIG_PM(IBRA,IKET,1))
C
                BIG_PM(IBRA,IKET,0) = TIMEPM
                BIG_PM(IBRA,IKET,1) = TIMEMP
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
      DEALLOCATE (HAUXIL)
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NILSON(ITILAX,ITISAX,NO_ORB,INNUMB,IZNUMB,
     *                         ICHARG,NAMEPN,HOMEGA,ISIMPY,
     *                                       ITWCEN,LTWCEN)
C=======================================================================
      USE MAT_PP
      USE MAT_PM
C=======================================================================
      USE hfodd_sizes
      USE hfodd_twocen
C=======================================================================
      CHARACTER
     *          NAMEPN*8
C
      COMPLEX
     *          TIMEPP,TIMEPM,TIMEMP,TIMEMM
C=======================================================================
      ALLOCATABLE HAUXIL(:,:)
C=======================================================================
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /NILPAR/ CNILSN,DNILSN,CNILSP,DNILSP,
     *                HBANIX,HBANIY,HBANIZ,NILDAT
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /OMISOS/ OMISOX,OMISOY,OMISOZ
      COMMON
     *       /ANGANG/ ANGU_N(1:NDKART),ANGU_P(1:NDKART),ANGU_T(1:NDKART)
      COMMON
     *       /ICNSTR/ STIFFI(1:NDKART),
     *                ASKEDI(1:NDKART),
     *                IFLAGI(1:NDKART)
      COMMON
     *       /ICNTTR/ STIFTI(1:NDKART),
     *                ASKETI(1:NDKART),
     *                IFTAGI(1:NDKART)
      COMMON
     *       /ACNSTR/ STIFFA,ASKEDA,IFLAGA
      COMMON
     *       /PLANCK/ HBMASS,HBMRPA,HBMINP
      COMMON
     *       /ESHIFT/ EFEBAS(0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /HOMTWC/ HOMEG2(1:NDTWCE)
      COMMON
     *       /FRCONS/ FRGSTF(0:NDISOS,1:NDTWCE),
     *                FRGASK(0:NDISOS,1:NDTWCE),
     *                IFLFRG(0:NDISOS,1:NDTWCE),
     *                CLMFRA(0:NDISOS,1:NDTWCE),
     *                AVEFRA(0:NDISOS,1:NDTWCE)
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('NILSON',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (HAUXIL(1:NDBASE,1:NDBASE),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('HAUXIL','NILSON')
      HAUXIL = 0.0D0
C=======================================================================
      IF (.NOT.ALLOCATED(BIG_PP)) THEN
          ALLOCATE (BIG_PP(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PP','NILSON')
      END IF
C=======================================================================
      IF (.NOT.ALLOCATED(BIG_PM).AND.ISIMPY.NE.1) THEN
          ALLOCATE (BIG_PM(1:NDBASE,1:NDBASE,0:NDREVE),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('BIG_PM','NILSON')
      END IF
C
                       BIG_PP = CMPLX(0.0D0,0.0D0)
      IF (ISIMPY.NE.1) BIG_PM = CMPLX(0.0D0,0.0D0)
C=======================================================================
C
C=======================================================================
C          THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF THE NILSSON
C          HAMILTONIAN
C=======================================================================
C
C=======================================================================
C           THE POTENTIAL ENERGY IS SHIFTED, SO AS TO BE EQUAL TO -8 MEV
C           AT THE FERMI SURFACE OF THE BASIS STATES.  THIS IS DONE ONLY
C           TO KEEP THE ENERGY SCALE OF THE NILSSON HAMILTONIAN  SIMILAR
C           TO THAT OF THE SELF-CONSISTENT AND WOODS-SAXON HAMILTONIANS.
C=======================================================================
C
      IF (LTWCEN.GT.2) STOP ' LTWCEN.GT.2 IN NILSON'
      IF (ITWCEN.EQ.2.AND.NILDAT.NE.0) STOP ' NILDAT!=0 FOR ITWCEN=2'
C
C=======================================================================
C     COMPUTING THE PARTICLES IN EACH FRAGMENT
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          INAUXI=INNUMB
          IZAUXI=IZNUMB
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          CALL TWC_FRAGPAR(INNUMB,IZNUMB,LTWCEN,IZAUXI,INAUXI)
C
      END IF
C
      ESCALE=EFEBAS(ICHARG)-(-8.0D0)
C
      IF (NILDAT.EQ.0) THEN
C
C=======================================================================
C         PARAMETERS AND DEFINITIONS ARE TAKEN FROM RING & SCHUCK,
C         CHAPTER 2.8.4. DEFORMATION IS SET TO THAT OF THE  BASIS.
C=======================================================================
C
          HBACTX=HBAROX(LTWCEN)
          HBACTY=HBAROY(LTWCEN)
          HBACTZ=HBAROZ(LTWCEN)
C
          AKAPPA=0.0D0
          AAAMIU=0.0D0
C
          IF (ICHARG.EQ.0) THEN
C
C=======================================================================
C         NEUTRON HAMILTONIAN
C=======================================================================
C
              IF (INAUXI.LE.0) STOP ' INNUMB.LE.0 IN NILSON'
C
              IF (INAUXI.LE.50) THEN
C
                  AKAPPA=0.08D0
                  AAAMIU=0.00D0
C
              END IF
C
              IF (INAUXI.GT.50.AND.INAUXI.LE.82) THEN
C
                  AKAPPA=0.0637D0
                  AAAMIU=0.60D0
C
              END IF
C
              IF (INAUXI.GT.82.AND.INAUXI.LE.126) THEN
C
                  AKAPPA=0.0637D0
                  AAAMIU=0.42D0
C
              END IF
C
              IF (INAUXI.GT.126) THEN
C
                  AKAPPA=0.0635D0
                  AAAMIU=0.325D0
C
              END IF
C
          ELSE
C
C=======================================================================
C         PROTON HAMILTONIAN
C=======================================================================
C
              IF (IZAUXI.LE.0) STOP ' IZNUMB.LE.0 IN NILSON'
C
              IF (IZAUXI.LE.50) THEN
C
                  AKAPPA=0.08D0
                  AAAMIU=0.00D0
C
              END IF
C
              IF (IZAUXI.GT.50.AND.IZAUXI.LE.82) THEN
C
                  AKAPPA=0.0637D0
                  AAAMIU=0.60D0
C
              END IF
C
              IF (IZAUXI.GT.82) THEN
C
                  AKAPPA=0.0577D0
                  AAAMIU=0.65D0
C
              END IF
C
          END IF
C
          CNILSS=-2*HOMEGA*AKAPPA
          DNILSS=  -HOMEGA*AKAPPA*AAAMIU
C
          IF (ITWCEN.EQ.2) THEN
C
          CNILSS=-2*HOMEG2(LTWCEN)*AKAPPA
          DNILSS=  -HOMEG2(LTWCEN)*AKAPPA*AAAMIU
C
          END IF
C
C=======================================================================
C         PRINTING THE NILSSON-MODEL PARAMETERS
C=======================================================================
C
          IF (ITWCEN.EQ.1) WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *          1H*, 2X,''PARAMETERS OF THE NILSSON MODEL'',
     *                                                  34X,A8,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                          79(1H*),/,1H*,77X,1H*,/,
     *          1H*,27X,''ESCALE ='',F6.3,3X,
     *                  ''KAPPA  ='',F6.3,3X,''   MIU ='',F6.3,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *          1H*,27X,''HOMEGA ='',F6.3,3X,
     *                  ''CNILSS ='',F6.3,3X,''DNILSS ='',F6.3,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *          1H*, 2X,''OSCILLATOR FREQUENCIES:'',2X,
     *                                            ''X='',F12.9,3X,
     *                                            ''Y='',F12.9,3X,
     *                                            ''Z='',F12.9,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *
     *                        NAMEPN,ESCALE,AKAPPA,AAAMIU,
     *                               HOMEGA,CNILSS,DNILSS,
     *                               HBACTX,HBACTY,HBACTZ
C
      ELSE
C
C=======================================================================
C         PARAMETERS ARE TAKEN FROM THE INPUT DATA. FOR NILDAT=2  THE
C         OSCILLATOR FREQUENCIES ARE KEPT EQUAL TO THOSE OF THE BASIS
C=======================================================================
C
          IF (NILDAT.EQ.1) THEN
C
              HBACTX=HBANIX
              HBACTY=HBANIY
              HBACTZ=HBANIZ
C
          ELSE
C
              HBACTX=HBAROX(LTWCEN)
              HBACTY=HBAROY(LTWCEN)
              HBACTZ=HBAROZ(LTWCEN)
C
          END IF
C
          IF (ICHARG.EQ.0) THEN
C
              CNILSS=CNILSN
              DNILSS=DNILSN
C
          ELSE
C
              CNILSS=CNILSP
              DNILSS=DNILSP
C
          END IF
C
C=======================================================================
C         PRINTING THE NILSSON-MODEL PARAMETERS
C=======================================================================
C
          WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *          1H*, 2X,''PARAMETERS OF THE NILSSON MODEL '',
     *                  ''TAKEN FROM THE INPUT DATA'',   8X,A8,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                          79(1H*),/,1H*,77X,1H*,/,
     *          1H*,27X,''ESCALE ='',F6.3,3X,
     *                  ''CNILSS ='',F6.3,3X,''DNILSS ='',F6.3,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *          1H*, 2X,''OSCILLATOR FREQUENCIES:'',2X,
     *                                            ''X='',F12.9,3X,
     *                                            ''Y='',F12.9,3X,
     *                                            ''Z='',F12.9,2X,1H*,/,
     *                                                    1H*,77X,1H*,/,
     *                                                      79(1H*),/)')
     *
     *                        NAMEPN,ESCALE,CNILSS,DNILSS,
     *                               HBACTX,HBACTY,HBACTZ
C
      END IF
C
C=======================================================================
C          AT THE BEGINNING: TIME-EVEN PART  IS PUT INTO BIG_PP(,,0)
C                            TIME-ODD  PART  IS PUT INTO BIG_PP(,,1)
C          AT THE END:
C                            TIME-UP   BLOCK IS PUT INTO BIG_PP(,,0)
C                            TIME-DOWN BLOCK IS PUT INTO BIG_PP(,,1)
C=======================================================================
C
C=======================================================================
C        ZEROING THOSE BLOCKS OF HAMILTONIAN, WHICH ARE OFF-DIAGONAL IN
C        SIMPLEX  -  SEE COMMENTS  IN  THE  "INTEGH"  SUBROUTINE.  SUCH
C        ELEMENTS MUST BE EQUAL TO ZERO, BECAUSE IN THE PRESENT VERSION
C        THE  NILSSON  POTENTIAL  IS  USED  IN  THE  SIMPLEX-CONSERVING
C        VERSION.
C=======================================================================
C
      BIG_PP(:,:,:)=CMPLX(0.0D0,0.0D0)
      IF (ISIMPY.NE.1) THEN
          BIG_PM(:,:,:)=CMPLX(0.0D0,0.0D0)
      END IF
C
C=======================================================================
C          INSERTING THE CRANKING MATRIX ELEMENTS
C=======================================================================
C
      OMEGAC=0.0D0
C
      OMEGAT=OMOVAX**2+OMOVAY**2+OMOVAZ**2
C
      OMEGAJ=OMOVAX*ANGU_T(1)+
     *       OMOVAY*ANGU_T(2)+
     *       OMOVAZ*ANGU_T(3)
C
      IF (ITILAX   .EQ.0.AND.ITISAX   .EQ.0.AND.
     *    IFLAGI(1).EQ.0.AND.IFLAGI(3).EQ.0.AND.
     *    IFTAGI(1).EQ.0.AND.IFTAGI(3).EQ.0) GO TO 2
C
      IF (ISIMPY.EQ.1) GO TO 2
C
C=======================================================================
C          X-DIRECTION
C=======================================================================
C
      OMEGAC=0.0D0
      IF (ITILAX   .NE.0) OMEGAC=OMEGAC+             OMOVAX
      IF (ITISAX   .NE.0) OMEGAC=OMEGAC+(1-2*ICHARG)*OMISOX
      IF (IFLAGI(1).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFI(1)*(ANGU_T(1)-ASKEDI(1))
      IF (IFTAGI(1).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFTI(1)*(ANGU_N(1)-ANGU_P(1)
     *                                                 -ASKETI(1))*
     *                                                (1-2*ICHARG)
      IF (IFLAGA   .NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFA   *(ANGU_T(1)*OMEGAT
     *                                       -OMOVAX   *OMEGAJ)/OMEGAT
C
      IF (NO_ORB.NE.1) THEN
C
          IF (ITWCEN.EQ.1) CALL INT_LX(IPHAPM(0,0,0),HAUXIL,OMEGAC)
C
          IF (ITWCEN.EQ.2) THEN
C
              CALL TWC_LX(HAUXIL,OMEGAC,LTWCEN)
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
                    NY=NYVECT(IBRA,LTWCEN)
                    MY=NYVECT(IKET,LTWCEN)
                    HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPM(NY,MY,0)
                 END DO
              END DO
C
          END IF
C
          CALL PUTIMA(-1,HAUXIL,BIG_PM(1,1,1))
C
      END IF
C
      IF (ITWCEN.EQ.1) CALL INT_SX(HAUXIL,OMEGAC)
C
      IF (ITWCEN.EQ.2) THEN
C
          CALL TWC_SX(HAUXIL,OMEGAC,LTWCEN)
          DO IBRA=1,LDBATW(IND2HL(LTWCEN))
             DO IKET=1,LDBATW(IND2HR(LTWCEN))
                NY=NYVECT(IBRA,LTWCEN)
                MY=NYVECT(IKET,LTWCEN)
                HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPM(NY,MY,1)
             END DO
          END DO
C
      END IF
C
      CALL PUTREA(-1,HAUXIL,BIG_PM(1,1,1))
C
C=======================================================================
C          Z-DIRECTION
C=======================================================================
C
      OMEGAC=0.0D0
      IF (ITILAX   .NE.0) OMEGAC=OMEGAC+             OMOVAZ
      IF (ITISAX   .NE.0) OMEGAC=OMEGAC+(1-2*ICHARG)*OMISOZ
      IF (IFLAGI(3).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFI(3)*(ANGU_T(3)-ASKEDI(3))
      IF (IFTAGI(3).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFTI(3)*(ANGU_N(3)-ANGU_P(3)
     *                                                 -ASKETI(3))*
     *                                                (1-2*ICHARG)
      IF (IFLAGA   .NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFA   *(ANGU_T(3)*OMEGAT
     *                                       -OMOVAZ   *OMEGAJ)/OMEGAT
C
      IF (NO_ORB.NE.1) THEN
C
          IF (ITWCEN.EQ.1) CALL INT_LZ(IPHAPM(0,0,0),HAUXIL,OMEGAC)
C
          IF (ITWCEN.EQ.2) THEN
C
              CALL TWC_LZ(HAUXIL,OMEGAC,LTWCEN)
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
                    NY=NYVECT(IBRA,LTWCEN)
                    MY=NYVECT(IKET,LTWCEN)
                    HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPM(NY,MY,0)
                 END DO
              END DO
C
          END IF
C
          CALL PUTIMA(-1,HAUXIL,BIG_PM(1,1,1))
C
      END IF
C
      IF (ITWCEN.EQ.1) CALL INT_SZ(HAUXIL,OMEGAC)
C
      IF (ITWCEN.EQ.2) THEN
C
          CALL TWC_SZ(HAUXIL,OMEGAC,LTWCEN)
          DO IBRA=1,LDBATW(IND2HL(LTWCEN))
             DO IKET=1,LDBATW(IND2HR(LTWCEN))
                NY=NYVECT(IBRA,LTWCEN)
                MY=NYVECT(IKET,LTWCEN)
                HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPM(NY,MY,3)
             END DO
          END DO
C
      END IF
C
      CALL PUTIMA(-1,HAUXIL,BIG_PM(1,1,1))
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C          Y-DIRECTION
C=======================================================================
C
      OMEGAC=OMOVAY+(1-2*ICHARG)*OMISOY
      IF (IFLAGI(2).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFI(2)*(ANGU_T(2)-ASKEDI(2))
      IF (IFTAGI(2).NE.0) OMEGAC=OMEGAC
     *                          -2*STIFTI(2)*(ANGU_N(2)-ANGU_P(2)
     *                                                 -ASKETI(2))*
     *                                                (1-2*ICHARG)
      IF (IFLAGA   .NE.0) OMEGAC=OMEGAC
     *                          -2*STIFFA   *(ANGU_T(2)*OMEGAT
     *                                       -OMOVAY   *OMEGAJ)/OMEGAT
C
      IF (NO_ORB.NE.1) THEN
C
          IF (ITWCEN.EQ.1) CALL INT_LY(IPHAPP(0,0,0),HAUXIL,OMEGAC)
C
          IF (ITWCEN.EQ.2) THEN
C
              CALL TWC_LY(HAUXIL,OMEGAC,LTWCEN)
              DO IBRA=1,LDBATW(IND2HL(LTWCEN))
                 DO IKET=1,LDBATW(IND2HR(LTWCEN))
                    NY=NYVECT(IBRA,LTWCEN)
                    MY=NYVECT(IKET,LTWCEN)
                    HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPP(NY,MY,0)
                 END DO
              END DO
C
          END IF
C
          CALL PUTIMA(-1,HAUXIL,BIG_PP(1,1,1))
C
      END IF
C
      IF (ITWCEN.EQ.1) CALL INT_SY(HAUXIL,OMEGAC)
C
      IF (ITWCEN.EQ.2) THEN
C
          CALL TWC_SY(HAUXIL,OMEGAC,LTWCEN)
          DO IBRA=1,LDBATW(IND2HL(LTWCEN))
             DO IKET=1,LDBATW(IND2HR(LTWCEN))
                NY=NYVECT(IBRA,LTWCEN)
                MY=NYVECT(IKET,LTWCEN)
                HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPP(NY,MY,2)
             END DO
          END DO
C
      END IF
C
      CALL PUTREA(-1,HAUXIL,BIG_PP(1,1,1))
C
C=======================================================================
C          CALCULATING THE BARE-MASS KINETIC ENERGY MATRIX ELEMENTS
C=======================================================================
C
      IF (ITWCEN.EQ.1) CALL INTKIN(HAUXIL,HBMASS,LTWCEN)
C
      IF (ITWCEN.EQ.2) THEN
C
          CALL TWC_INTKIN(HAUXIL,HBMASS,LTWCEN)
          DO IBRA=1,LDBATW(IND2HL(LTWCEN))
             DO IKET=1,LDBATW(IND2HR(LTWCEN))
                NY=NYVECT(IBRA,LTWCEN)
                MY=NYVECT(IKET,LTWCEN)
                HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPP(NY,MY,0)
             END DO
          END DO
C
      END IF
C
      CALL PUTREA(+1,HAUXIL,BIG_PP(1,1,0))
C
C=======================================================================
C           CALCULATING THE DEFORMED-HO POTENTIAL-ENERGY MATRIX ELEMENTS
C=======================================================================
C
      CALL INT_HO(HAUXIL,HBMASS,ESCALE,HBACTX,HBACTY,HBACTZ,LTWCEN)
C
      CALL PUTREA(+1,HAUXIL,BIG_PP(1,1,0))
C
C=======================================================================
C          CALCULATING THE L^2 MATRIX ELEMENTS
C=======================================================================
C
      CALL INT_L2(HAUXIL,DNILSS,LTWCEN)
C
      CALL PUTREA(+1,HAUXIL,BIG_PP(1,1,0))
C
C=======================================================================
C          CALCULATING THE SPIN-ORBIT MATRIX ELEMENTS
C=======================================================================
C
      IF (ITWCEN.EQ.1) THEN
C
          CALL INT_LX(IPHAPP(0,0,1),HAUXIL,CNILSS)
          CALL PUTIMA(+1,HAUXIL,BIG_PP(1,1,0))
C
          CALL INT_LY(IPHAPP(0,0,2),HAUXIL,CNILSS)
          CALL PUTIMA(+1,HAUXIL,BIG_PP(1,1,0))
C
          CALL INT_LZ(IPHAPP(0,0,3),HAUXIL,CNILSS)
          CALL PUTREA(-1,HAUXIL,BIG_PP(1,1,0))
C
      ELSEIF (ITWCEN.EQ.2) THEN
C
          CALL TWC_LX(HAUXIL,CNILSS,LTWCEN)
          DO IBRA=1,LDBATW(IND2HL(LTWCEN))
             DO IKET=1,LDBATW(IND2HR(LTWCEN))
                NY=NYVECT(IBRA,LTWCEN)
                MY=NYVECT(IKET,LTWCEN)
                HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPP(NY,MY,0)
             END DO
          END DO
          CALL PUTIMA(+1,HAUXIL,BIG_PP(1,1,0))
C
          CALL TWC_LY(HAUXIL,CNILSS,LTWCEN)
          DO IBRA=1,LDBATW(IND2HL(LTWCEN))
             DO IKET=1,LDBATW(IND2HR(LTWCEN))
                NY=NYVECT(IBRA,LTWCEN)
                MY=NYVECT(IKET,LTWCEN)
                HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPP(NY,MY,2)
             END DO
          END DO
          CALL PUTIMA(+1,HAUXIL,BIG_PP(1,1,0))
C
          CALL TWC_LZ(HAUXIL,CNILSS,LTWCEN)
          DO IBRA=1,LDBATW(IND2HL(LTWCEN))
             DO IKET=1,LDBATW(IND2HR(LTWCEN))
                NY=NYVECT(IBRA,LTWCEN)
                MY=NYVECT(IKET,LTWCEN)
                HAUXIL(IBRA,IKET)=HAUXIL(IBRA,IKET)*IPHAPP(NY,MY,3)
             END DO
          END DO
          CALL PUTREA(-1,HAUXIL,BIG_PP(1,1,0))
C
      END IF
C
C=======================================================================
C         COMBINING THE  TIME-EVEN  AND  TIME-ODD   PARTS
C              INTO THE  TIME-UP    AND  TIME-DOWN  PARTS
C=======================================================================
C
      DO IKET=1,LDBATW(IND2HR(LTWCEN))
         DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
            TIMEPP=       BIG_PP(IBRA,IKET,0) + BIG_PP(IBRA,IKET,1)
            TIMEMM= CONJG(BIG_PP(IBRA,IKET,0) - BIG_PP(IBRA,IKET,1))
C
            BIG_PP(IBRA,IKET,0) = TIMEPP
            BIG_PP(IBRA,IKET,1) = TIMEMM
C
         END DO
      END DO
C
      IF (ISIMPY.NE.1) THEN
C
          DO IKET=1,LDBATW(IND2HR(LTWCEN))
             DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
                TIMEPM=       BIG_PM(IBRA,IKET,0) + BIG_PM(IBRA,IKET,1)
                TIMEMP=-CONJG(BIG_PM(IBRA,IKET,0) - BIG_PM(IBRA,IKET,1))
C
                BIG_PM(IBRA,IKET,0) = TIMEPM
                BIG_PM(IBRA,IKET,1) = TIMEMP
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
      DEALLOCATE (HAUXIL)
C=======================================================================
C
      CALL CPUTIM('NILSON',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_L2(HAMLSQ,DNILSS,LTWCEN)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          HAMLSQ(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEDER/ CODERI(1:NDDERI,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COESCA/ COSCAL(1:NDSCAL,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF L2
C=======================================================================
C        THE FORMULA USED IS:
C
C        L2= 2SUM_I(X_I*D_I) - SUM_IJ(X_I*X_I*D_J*D_J - X_I*X_J*D_I*D_J)
C
C        WHERE X_I AND D_I ARE THE COMPONENTS OF THE POSITION AND GRAD-
C        IENT VECTORS, RESPECTIVELY. THE I=J TERMS CANCEL IN THE DOUBLE
C        SUMS AND ARE NOT CALCULATED. ONLY THE I<J TERMS ARE CALCULATED
C        FOR THE SECOND OF THE TWO DOUBLE SUMS.
C=======================================================================
C
      IF (LTWCEN.GT.2) STOP 'LTWCEN.GT.2 IN INT_L2'
C
      HAMLSQ(:,:)=0.0D0
C
C=======================================================================
C
      DO IKET=1,LDBATW(IND2HR(LTWCEN))
         DO IBRA=1,LDBATW(IND2HL(LTWCEN))
C
            NX=NXVECT(IBRA,LTWCEN)
            NY=NYVECT(IBRA,LTWCEN)
            NZ=NZVECT(IBRA,LTWCEN)
C
            MX=NXVECT(IKET,LTWCEN)
            MY=NYVECT(IKET,LTWCEN)
            MZ=NZVECT(IKET,LTWCEN)
C
            HAMLSQ(IBRA,IKET) = DNILSS * IPHAPP(NY,MY,0) *
     *
     *      (2*COSCAL(1,NX,MX,1)*COMULT(0,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *      +2*COMULT(0,NX,MX,1)*COSCAL(1,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *      +2*COMULT(0,NX,MX,1)*COMULT(0,NY,MY,2)*COSCAL(1,NZ,MZ,3)
     *
     *      -  COMULT(2,NX,MX,1)*CODERI(2,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *      -  COMULT(2,NX,MX,1)*COMULT(0,NY,MY,2)*CODERI(2,NZ,MZ,3)
     *
     *      -  CODERI(2,NX,MX,1)*COMULT(2,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *      -  COMULT(0,NX,MX,1)*COMULT(2,NY,MY,2)*CODERI(2,NZ,MZ,3)
     *
     *      -  CODERI(2,NX,MX,1)*COMULT(0,NY,MY,2)*COMULT(2,NZ,MZ,3)
     *      -  COMULT(0,NX,MX,1)*CODERI(2,NY,MY,2)*COMULT(2,NZ,MZ,3)
     *
     *      +2*COSCAL(1,NX,MX,1)*COSCAL(1,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *
     *      +2*COMULT(0,NX,MX,1)*COSCAL(1,NY,MY,2)*COSCAL(1,NZ,MZ,3)
     *
     *      +2*COSCAL(1,NX,MX,1)*COMULT(0,NY,MY,2)*COSCAL(1,NZ,MZ,3))
C
         END DO
C
C=======================================================================
C        HERE THE STANDARD AVERAGE VALUE OF L2 IS SUBTRACTED
C=======================================================================
C
         NTOTAL=MX+MY+MZ
C
         HAMLSQ(IKET,IKET) = HAMLSQ(IKET,IKET)
     *                     - DNILSS * NTOTAL*(NTOTAL+3)/2.0D0
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTLX2(HAMLSQ,DNILSS)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          HAMLSQ(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEDER/ CODERI(1:NDDERI,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COESCA/ COSCAL(1:NDSCAL,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF LX2
C=======================================================================
C        THE FORMULA USED IS:
C
C        LX2=Y*DY+Z*DZ-(Y*Y*DZ*DZ-Y*Z*DY*DZ)-(Z*Z*DY*DY-Z*Y*DZ*DY)
C           =Y*DY+Z*DZ-Y^2*DZ^2-Z^2*DY^2+2*(Y*DY)*(Z*DZ)
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            HAMLSQ(IBRA,IKET)=0.0D0
         END DO
      END DO
C
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            NX=NXVECT(IBRA,1)
            NY=NYVECT(IBRA,1)
            NZ=NZVECT(IBRA,1)
C
            MX=NXVECT(IKET,1)
            MY=NYVECT(IKET,1)
            MZ=NZVECT(IKET,1)
C
            HAMLSQ(IBRA,IKET) = DNILSS * IPHAPP(NY,MY,0) *
C           (Y*DY),(Z*DZ)
     *      (  COMULT(0,NX,MX,1)*COSCAL(1,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *      +  COMULT(0,NX,MX,1)*COMULT(0,NY,MY,2)*COSCAL(1,NZ,MZ,3)
C           Y^2*DZ^2,Z^2*DY^2
     *      -  COMULT(0,NX,MX,1)*COMULT(2,NY,MY,2)*CODERI(2,NZ,MZ,3)
     *      -  COMULT(0,NX,MX,1)*CODERI(2,NY,MY,2)*COMULT(2,NZ,MZ,3)
C           2*(Y*DY)(Z*DZ)
     *      +2*COMULT(0,NX,MX,1)*COSCAL(1,NY,MY,2)*COSCAL(1,NZ,MZ,3))
C
         END DO
C
C=======================================================================
C        HERE THE STANDARD AVERAGE VALUE OF L2 IS SUBTRACTED
C=======================================================================
C
C         NTOTAL=MX+MY+MZ
CC
C         HAMLSQ(IKET,IKET) = HAMLSQ(IKET,IKET)
C     *                     - DNILSS * NTOTAL*(NTOTAL+3)/2.0D0
C
      END DO
C
C=======================================================================
C
      RETURN
      END
CC=======================================================================
C
      SUBROUTINE INTLY2(HAMLSQ,DNILSS)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          HAMLSQ(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEDER/ CODERI(1:NDDERI,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COESCA/ COSCAL(1:NDSCAL,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF LX2
C=======================================================================
C        THE FORMULA USED IS:
C
C        LY2=X*DX+Z*DZ-(X*X*DZ*DZ-X*Z*DX*DZ)-(Z*Z*DX*DX-Z*X*DZ*DX)
C           =X*DX+Z*DZ-X^2*DZ^2-Z^2*DX^2+2*(X*DX)*(Z*DZ)
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            HAMLSQ(IBRA,IKET)=0.0D0
         END DO
      END DO
C
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            NX=NXVECT(IBRA,1)
            NY=NYVECT(IBRA,1)
            NZ=NZVECT(IBRA,1)
C
            MX=NXVECT(IKET,1)
            MY=NYVECT(IKET,1)
            MZ=NZVECT(IKET,1)
C
            HAMLSQ(IBRA,IKET) = DNILSS * IPHAPP(NY,MY,0) *
C           (X*DX),(Z*DZ)
     *      (  COSCAL(1,NX,MX,1)*COMULT(0,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *      +  COMULT(0,NX,MX,1)*COMULT(0,NY,MY,2)*COSCAL(1,NZ,MZ,3)
C           X^2*DZ^2,Z^2*DX^2
     *      -  COMULT(2,NX,MX,1)*COMULT(0,NY,MY,2)*CODERI(2,NZ,MZ,3)
     *      -  CODERI(2,NX,MX,1)*COMULT(0,NY,MY,2)*COMULT(2,NZ,MZ,3)
C           2*(X*DX)(Z*DZ)
     *      +2*COSCAL(1,NX,MX,1)*COMULT(0,NY,MY,2)*COSCAL(1,NZ,MZ,3))
C
         END DO
C
C=======================================================================
C        HERE THE STANDARD AVERAGE VALUE OF L2 IS SUBTRACTED
C=======================================================================
C
C         NTOTAL=MX+MY+MZ
CC
C         HAMLSQ(IKET,IKET) = HAMLSQ(IKET,IKET)
C     *                     - DNILSS * NTOTAL*(NTOTAL+3)/2.0D0
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTLZ2(HAMLSQ,DNILSS)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          HAMLSQ(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COEDER/ CODERI(1:NDDERI,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /COESCA/ COSCAL(1:NDSCAL,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF LX2
C=======================================================================
C        THE FORMULA USED IS:
C
C        LZ2=X*DX+Y*DY-(X*X*DY*DY-X*Y*DX*DY)-(Y*Y*DX*DX-Y*X*DY*DX)
C           =X*DX+Y*DY-X^2*DY^2-Y^2*DX^2+2*(X*DX)*(Y*DY)
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
            HAMLSQ(IBRA,IKET)=0.0D0
         END DO
      END DO
C
C=======================================================================
C
      DO IKET=1,LDBASE
         DO IBRA=1,LDBASE
C
            NX=NXVECT(IBRA,1)
            NY=NYVECT(IBRA,1)
            NZ=NZVECT(IBRA,1)
C
            MX=NXVECT(IKET,1)
            MY=NYVECT(IKET,1)
            MZ=NZVECT(IKET,1)
C
            HAMLSQ(IBRA,IKET) = DNILSS * IPHAPP(NY,MY,0) *
C           (X*DX),(Y*DY)
     *      (  COSCAL(1,NX,MX,1)*COMULT(0,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *      +  COMULT(0,NX,MX,1)*COSCAL(1,NY,MY,2)*COMULT(0,NZ,MZ,3)
C           X^2*DY^2,Y^2*DX^2
     *      -  COMULT(2,NX,MX,1)*CODERI(2,NY,MY,2)*COMULT(0,NZ,MZ,3)
     *      -  CODERI(2,NX,MX,1)*COMULT(2,NY,MY,2)*COMULT(0,NZ,MZ,3)
C           2*(X*DX)(Y*DY)
     *      +2*COSCAL(1,NX,MX,1)*COSCAL(1,NY,MY,2)*COMULT(0,NZ,MZ,3))
C
         END DO
C
C=======================================================================
C        HERE THE STANDARD AVERAGE VALUE OF L2 IS SUBTRACTED
C=======================================================================
C
C         NTOTAL=MX+MY+MZ
CC
C         HAMLSQ(IKET,IKET) = HAMLSQ(IKET,IKET)
C     *                     - DNILSS * NTOTAL*(NTOTAL+3)/2.0D0
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
C
      SUBROUTINE INT_SX(HAMANG,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          HAMANG(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF SX
C=======================================================================
C
      HAMANG(:,:)=0.0D0
C
      FACACT=FACTOR*0.5D0
C
      DO NY=0,NYMAXV(1)
         DO NZ=0,LZOFYV(NY,1)
            DO NX=0,LXOYZV(NY,NZ,1)
C
                  HAMANG(INDICE(NX,NY,NZ,1),INDICE(NX,NY,NZ,1))=
     *
     *            FACACT * IPHAPM(NY,NY,1)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_SY(HAMANG,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          HAMANG(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF SY
C=======================================================================
C
      HAMANG(:,:)=0.0D0
C
      FACACT=FACTOR*0.5D0
C
      DO NY=0,NYMAXV(1)
         DO NZ=0,LZOFYV(NY,1)
            DO NX=0,LXOYZV(NY,NZ,1)
C
                  HAMANG(INDICE(NX,NY,NZ,1),INDICE(NX,NY,NZ,1))=
     *
     *            FACACT * IPHAPP(NY,NY,2)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_SZ(HAMANG,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          HAMANG(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF SZ
C=======================================================================
C
      HAMANG(:,:)=0.0D0
C
      FACACT=FACTOR*0.5D0
C
      DO NY=0,NYMAXV(1)
         DO NZ=0,LZOFYV(NY,1)
            DO NX=0,LXOYZV(NY,NZ,1)
C
                  HAMANG(INDICE(NX,NY,NZ,1),INDICE(NX,NY,NZ,1))=
     *
     *            FACACT * IPHAPM(NY,NY,3)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_LX(IPHASE,HAMANG,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMANG(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF LX
C=======================================================================
C
      HAMANG(:,:)=0.0D0
C
      PI=4.0D0*ATAN(1.00D0)
      SQRTP2=SQRT(PI/2.0D0)
C
      FACACT= - SQRTP2/SQRT(HOMSCA(2,1)*HOMSCA(3,1))*FACTOR
C
      DO NX=0,NXMAXV(1)
         MX=NX
C
         DO NY=0,LYOFXV(NX,1)
            DO MY=MAX(0,NY-1),MIN(LYOFXV(MX,1),NY+1)
C
               DO NZ=0,LZOXYV(NX,NY,1)
                  DO MZ=MAX(0,NZ-1),MIN(LZOXYV(MX,MY,1),NZ+1)
C
                     HAMANG(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *               FACACT * IPHASE(NY,MY)
     *
     *                   * (COEF00(1,NY,MY,2)/HOMSCA(2,1)
     *                                               *COEF01(0,NZ,MZ,3)
     *                     -COEF00(1,NZ,MZ,3)/HOMSCA(3,1)
     *                                               *COEF01(0,NY,MY,2))
C
                  END DO
               END DO
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_LY(IPHASE,HAMANG,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMANG(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF LY
C=======================================================================
C
      HAMANG(:,:)=0.0D0
C
      PI=4.0D0*ATAN(1.00D0)
      SQRTP2=SQRT(PI/2.0D0)
C
      FACACT= - SQRTP2/SQRT(HOMSCA(1,1)*HOMSCA(3,1))*FACTOR
C
      DO NY=0,NYMAXV(1)
         MY=NY
C
         DO NZ=0,LZOFYV(NY,1)
            DO MZ=MAX(0,NZ-1),MIN(LZOFYV(MY,1),NZ+1)
C
               DO NX=0,LXOYZV(NY,NZ,1)
                  DO MX=MAX(0,NX-1),MIN(LXOYZV(MY,MZ,1),NX+1)
C
                     HAMANG(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *               FACACT * IPHASE(NY,MY)
     *
     *                   * (COEF00(1,NZ,MZ,3)/HOMSCA(3,1)
     *                                               *COEF01(0,NX,MX,1)
     *                     -COEF00(1,NX,MX,1)/HOMSCA(1,1)
     *                                               *COEF01(0,NZ,MZ,3))
C
                  END DO
               END DO
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_LZ(IPHASE,HAMANG,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMANG(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF LZ
C=======================================================================
C
      HAMANG(:,:)=0.0D0
C
      PI=4.0D0*ATAN(1.00D0)
      SQRTP2=SQRT(PI/2.0D0)
C
      FACACT= - SQRTP2/SQRT(HOMSCA(1,1)*HOMSCA(2,1))*FACTOR
C
      DO NZ=0,NZMAXV(1)
         MZ=NZ
C
         DO NX=0,LXOFZV(NZ,1)
            DO MX=MAX(0,NX-1),MIN(LXOFZV(MZ,1),NX+1)
C
               DO NY=0,LYOZXV(NZ,NX,1)
                  DO MY=MAX(0,NY-1),MIN(LYOZXV(MZ,MX,1),NY+1)
C
                     HAMANG(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *               FACACT * IPHASE(NY,MY)
     *
     *                   * (COEF00(1,NX,MX,1)/HOMSCA(1,1)
     *                                               *COEF01(0,NY,MY,2)
     *                     -COEF00(1,NY,MY,2)/HOMSCA(2,1)
     *                                               *COEF01(0,NX,MX,1))
C
                  END DO
               END DO
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_PX(IPHASE,HAMLIN,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMLIN(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF PX
C=======================================================================
C
      HAMLIN(:,:)=0.0D0
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
      FACACT= - SQ4_PI/SQRT(HOMSCA(1,1))*FACTOR
C
      DO NY=0,NYMAXV(1)
         MY=NY
C
         DO NZ=0,LZOFYV(NY,1)
            MZ=NZ
C
            DO NX=0,LXOYZV(NY,NZ,1)
               DO MX=MAX(0,NX-1),MIN(LXOYZV(MY,MZ,1),NX+1)
C
                  HAMLIN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *            FACACT * IPHASE(NY,MY) * COEF01(0,NX,MX,1)
C
               END DO
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_PY(IPHASE,HAMLIN,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMLIN(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF PY
C=======================================================================
C
      HAMLIN(:,:)=0.0D0
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
      FACACT= - SQ4_PI/SQRT(HOMSCA(2,1))*FACTOR
C
      DO NZ=0,NZMAXV(1)
         MZ=NZ
C
         DO NX=0,LXOFZV(NZ,1)
            MX=NX
C
            DO NY=0,LYOZXV(NZ,NX,1)
               DO MY=MAX(0,NY-1),MIN(LYOZXV(MZ,MX,1),NY+1)
C
                  HAMLIN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *            FACACT * IPHASE(NY,MY) * COEF01(0,NY,MY,2)
C
               END DO
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INT_PZ(IPHASE,HAMLIN,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMLIN(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF PZ
C=======================================================================
C
      HAMLIN(:,:)=0.0D0
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
      FACACT= - SQ4_PI/SQRT(HOMSCA(3,1))*FACTOR
C
      DO NX=0,NXMAXV(1)
         MX=NX
C
         DO NY=0,LYOFXV(NX,1)
            MY=NY
C
            DO NZ=0,LZOXYV(NX,NY,1)
               DO MZ=MAX(0,NZ-1),MIN(LZOXYV(MX,MY,1),NZ+1)
C
                  HAMLIN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *            FACACT * IPHASE(NY,MY) * COEF01(0,NZ,MZ,3)
C
               END DO
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTPX2(IPHASE,HAMLIN,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMLIN(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF PX SQUARED
C=======================================================================
C
      HAMLIN(:,:)=0.0D0
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
      FACACT= - SQ4_PI/SQRT(HOMSCA(1,1))*FACTOR
C
      DO NY=0,NYMAXV(1)
         MY=NY
C
         DO NZ=0,LZOFYV(NY,1)
            MZ=NZ
C
            DO NX=0,LXOYZV(NY,NZ,1)
               DO MX=MAX(0,NX-2),MIN(LXOYZV(MY,MZ,1),NX+2)
C
                  HAMLIN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *            FACACT * IPHASE(NY,MY) * COEF02(0,NX,MX,1)
C
               END DO
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTPY2(IPHASE,HAMLIN,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMLIN(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF PY SQUARED
C=======================================================================
C
      HAMLIN(:,:)=0.0D0
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
      FACACT= - SQ4_PI/SQRT(HOMSCA(2,1))*FACTOR
C
      DO NZ=0,NZMAXV(1)
         MZ=NZ
C
         DO NX=0,LXOFZV(NZ,1)
            MX=NX
C
            DO NY=0,LYOZXV(NZ,NX,1)
               DO MY=MAX(0,NY-2),MIN(LYOZXV(MZ,MX,1),NY+2)
C
                  HAMLIN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *            FACACT * IPHASE(NY,MY) * COEF02(0,NY,MY,2)
C
               END DO
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTPZ2(IPHASE,HAMLIN,FACTOR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          IPHASE(0:NDYMAX,0:NDYMAX)
      DIMENSION
     *          HAMLIN(1:NDBASE,1:NDBASE)
C
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
C
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
C
      COMMON
     *       /COEXYZ/ COEF00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF01(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF11(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COEF02(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES THE MATRIX ELEMENTS OF PZ SQUARED
C=======================================================================
C
      HAMLIN(:,:)=0.0D0
C
      SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
      FACACT= - SQ4_PI/SQRT(HOMSCA(3,1))*FACTOR
C
      DO NX=0,NXMAXV(1)
         MX=NX
C
         DO NY=0,LYOFXV(NX,1)
            MY=NY
C
            DO NZ=0,LZOXYV(NX,NY,1)
               DO MZ=MAX(0,NZ-2),MIN(LZOXYV(MX,MY,1),NZ+2)
C
                  HAMLIN(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *
     *            FACACT * IPHASE(NY,MY) * COEF02(0,NZ,MZ,3)
C
               END DO
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE READWS(INNUMB,IZNUMB,FCHOM0,R0PARM,HOMEGA,
     *                         NFIWOO,EPSHER,NOSCIL,NLIMIT,
     *                         ENECUT,LAMMAX,ISOTRO,CVOLFC,
     *                         CMSXFC,CMSYFC,CMSZFC,XMOMFC,
     *                         YMOMFC,ZMOMFC,GPAIRN,GPAIRP)
C=======================================================================
      USE SPINOR
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMEPN(0:NDISOS)*8
C
      COMPLEX
     *          ALPHAC(0:NDLAMB,-NDLAMB:+NDLAMB)
      COMPLEX
     *          BETBAS(0:NDLAMB,-NDLAMB:+NDLAMB)
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /REALPH/ ALPHAR(0:NDLAMB,0:NDLAMB)
      COMMON
     *       /SPE_WS/ ESINWS(1:NDBASE,0:NDISOS)
      COMMON
     *       /BASPAR/ HBAROX(1:NDTWCE),
     *                HBAROY(1:NDTWCE),
     *                HBAROZ(1:NDTWCE)
      COMMON
     *       /BASE_2/ BASEX2,BASEY2,BASEZ2
      COMMON
     *       /DEFORM/ ALPHAC,IREALA
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /PAIINI/ FERINI(0:NDISOS),DELINI(0:NDISOS),FE2INI(0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
C
      DATA
     *     NAMEPN /'NEUTRONS',' PROTONS'/
C
C=======================================================================
      IALLOC=0
      IF (.NOT.ALLOCATED(WSWAVE))
     *    ALLOCATE (WSWAVE(1:NDBASE,1:NDBASE,0:NDISOS),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WSWAVE','READWS')
C=======================================================================
C
      DO L=0,NDLAMB
         DO M=-L,L
            ALPHAC(L,M)=CMPLX(0.0D0,0.0D0)
         END DO
         DO M=0,L
            ALPHAR(L,M)=0.0D0
         END DO
      END DO
C
      READ(NFIWOO)IZNUMB,INNUMB,LAMMAX,
     *          ((BETBAS(L,M),M=-L,+L),L=0,LAMMAX),
     *          ((ALPHAC(L,M),M=-L,+L),L=0,LAMMAX),
     *            NOSCIL,IPARAM,NROTAT,
     *            NXHERM,NYHERM,NZHERM,NXPOIN,NYPOIN,
     *            NLIMIT,HBAROX(1),HBAROY(1),HBAROZ(1),HOMEGA,FCHOM0,
     *            CMSXFC,CMSYFC,CMSZFC,XMOMFC,YMOMFC,ZMOMFC,
     *            BASEX2,BASEY2,BASEZ2,CVOLFC,R0PARM,ENECUT,
     *            IARRAY,LDBASE,ISOTRO,EPSHER,
     *            EFERMN,EFERMP,GPAIRN,GPAIRP,DELTAN,DELTAP
C
      FERINI(0)=EFERMN
      FERINI(1)=EFERMP
C
      DELINI(0)=DELTAN
      DELINI(1)=DELTAP
C
      IF (LDBASE.GT.NDBASE) THEN
          WRITE(NFIPRI,'(//,''LDBASE='',I6,'' EXCEEEDS NDBASE='',I6)')
     *                   LDBASE,NDBASE
          STOP 'LDBASE.GT.NDBASE'
      END IF
C
      DO L=0,LAMMAX
         DO M=-L,L
            IF (ABS(AIMAG(BETBAS(L,M))).GT.1.0E-10) THEN
                STOP 'COMPLEX DEFORMATION IN READWS'
            ELSE
                IF (M.GE.0) ALPHAR(L,M)=REAL(BETBAS(L,M))
            END IF
         END DO
      END DO
C
      IREALA=1
C
      READ(NFIWOO)(ESINWS(I,0),I=1,LDBASE)
C
      READ(NFIWOO)(ESINWS(I,1),I=1,LDBASE)
C
      IF (IARRAY.EQ.1) THEN
          READ(NFIWOO) (((WSWAVE(I,J,ICHARG),I=1,LDBASE),
     *                                       J=1,LDBASE),
     *                                  ICHARG=0,NDISOS)
          READ(NFIWOO)( NXVECT(I,1),NYVECT(I,1),NZVECT(I,1), I=1,LDBASE)
      END IF
C
      CALL TABDEF(LAMMAX)
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *      1H*,2X,
     *      ''N ='',I3,     ''  Z ='',I3,8X,''  LDBASE ='',I5,
     *   ''    NMAX ='',I2,''  IPARAM ='',I2,''  NROTAT ='',I2,2X,1H*,/,
     *      1H*,39X,
     *   ''  NXHERM ='',I2,''  NYHERM ='',I2,''  NZHERM ='',I2,2X,1H*,/,
     *      1H*,39X,
     *   ''  NXPOIN ='',I2,''  NYPOIN ='',I2,''          '',2X,2X,1H*,/,
     *      1H*,77X,1H*)')
     *
     *      INNUMB,IZNUMB,LDBASE,NOSCIL,IPARAM,NROTAT,
     *                           NXHERM,NYHERM,NZHERM,
     *                           NXPOIN,NYPOIN
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,77X,1H*,/,
     *      1H*,24X,
     *      ''  HBAROX ='',F7.3,''  HBAROY ='',F7.3,''  HBAROZ ='',F7.3,
     *      2X,1H*,/,
     *      1H*,77X,1H*,/,
     *      1H*,24X,
     *      ''  XMOMFC ='',F7.3,''  YMOMFC ='',F7.3,''  ZMOMFC ='',F7.3,
     *      2X,1H*,/,
     *      1H*,77X,1H*,/,
     *      1H*,24X,
     *      ''  CMSXFC ='',F7.3,''  CMSYFC ='',F7.3,''  CMSZFC ='',F7.3,
     *      2X,1H*,/,
     *      1H*,77X,1H*,/,
     *      79(1H*),/)')
     *
     *      HBAROX(1),HBAROY(1),HBAROZ(1),
     *      XMOMFC,YMOMFC,ZMOMFC,
     *      CMSXFC,CMSYFC,CMSZFC
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AXISIQ(NLSIQR,MXALIB,ICHARG)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PARNAM(0:NDISOS)*7,AXINAM(1:NDKART)*1,PLUMIN(0:1)*1
      LOGICAL
     *          PRINIT
C
      DIMENSION
     *          NUALIB(0:NDPARI,0:NDISOS),
     *          KUALIB(0:NDPARI,0:NDISOS)
      DIMENSION
     *          SP_ALI(1:2*NDSTAT,0:NDISOS)
      DIMENSION
     *          KALDUM(-NDALIB:NDALIB,0:NDPARI,0:NDISOS)
      DIMENSION
     *          IFOUND(-NDALIB:NDALIB,0:NDPARI)
      DIMENSION
     *          N_PARI(0:NDPARI)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIQOCC/ K_OCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *                K_OCVA(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQOCA/ K_OCAL(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQALI/ KALSIQ(-NDALIB:NDALIB,0:NDPARI,0:NDISOS),
     *                MALSIQ(-NDALIB:NDALIB,0:NDPARI,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /PNHEAD/ I_HEAD
      COMMON
     *       /ALLAST/ LASTAL(0:NDISOS)
      COMMON
     *       /IPRITE/ PRINIT
C
      DATA
     *       PARNAM /'N','P'/,
     *       PLUMIN /'+','-'/
      DATA
     *       AXINAM /'x','y','z'/
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF THE  PARITY   SYMMETRY
C        AND HANDLES OCCUPATIONS OF PARTICLES IN ALIGNMENT BLOCKS
C
C=======================================================================
C
      IF (MXALIB.GT.NDALIB) STOP ' NDALIB TOO SMALL IN AXISIQ'
C
      IF (MOD(MXALIB,2).NE.1) STOP ' MXALIB NOT ODD IN AXISIQ'
C
C=======================================================================
C
C=======================================================================
C
      IF (NLSIQR.EQ.0) RETURN
C
      IF (ABS(NLSIQR).GT.3) STOP ' INCORRECT NLSIQR IN AXISIQ'
C
C=======================================================================
C
      IF (IABS(NLSIQR).EQ.1) SP_ALI=SPXALI
      IF (IABS(NLSIQR).EQ.2) SP_ALI=SPALIG
      IF (IABS(NLSIQR).EQ.3) SP_ALI=SPZALI
C
C=======================================================================
C        DETERMINING DISTRIBUTION OF PARTICLES IN ALIGNMENT BLOCKS
C=======================================================================
C
      N_PARI=0
C
      MALSIQ(:,:,ICHARG)=0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C        DEFINING A HALF-INTEGER SPIN CLOSEST TO THE AVERAGE VALUE
C=======================================================================
C
         IF (SP_ALI(ISTATE,ICHARG).GT.0.D0) THEN
C
             I_ALIB=2*INT(SP_ALI(ISTATE,ICHARG))+1
         ELSE
             I_ALIB=2*INT(SP_ALI(ISTATE,ICHARG))-1
C
         END IF
C
C=======================================================================
C
         IF (SPPARI(ISTATE,ICHARG).GT.0.0) THEN
C
             IPARIT=0
         ELSE
             IPARIT=1
C
         END IF
C
         N_PARI(IPARIT)=N_PARI(IPARIT)+1
C
         IF (K_OCCU(N_PARI(IPARIT),IPARIT,ICHARG).EQ.1.AND.
     *       IABS(I_ALIB).LE.MXALIB)
     *
     *       MALSIQ(I_ALIB,IPARIT,ICHARG)=MALSIQ(I_ALIB,IPARIT,ICHARG)+1
C
      END DO
C
C=======================================================================
C         DETERMINING NUMBERS OF PARTICLES IN PARITY-CHARGE BLOCKS
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
         KUALIB(IPARIT,ICHARG)=0
         NUALIB(IPARIT,ICHARG)=0
C
         DO I_ALIB=-MXALIB,MXALIB,2
C
            KUALIB(IPARIT,ICHARG)=
     *      KUALIB(IPARIT,ICHARG)+IABS(KALSIQ(I_ALIB,IPARIT,ICHARG))
            NUALIB(IPARIT,ICHARG)=
     *      NUALIB(IPARIT,ICHARG)+     MALSIQ(I_ALIB,IPARIT,ICHARG)
C
         END DO
C
      END DO
C
C=======================================================================
C        DEFINING DISTRIBUTION OF PARTICLES IN ALIGNMENT BLOCKS
C=======================================================================
C
      IF (NLSIQR.LT.0) GO TO 1
C
C=======================================================================
C        THIS IS PERFORMED ONLY FOR NLSIQR>0
C=======================================================================
C
      N_PARI=0
      IFOUND=0
      KALDUM=0
C
      K_OCAL(:,:,ICHARG)=0
      KUALIB(  :,ICHARG)=0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C        DEFINING A HALF-INTEGER SPIN CLOSEST TO THE AVERAGE VALUE
C=======================================================================
C
         IF (SP_ALI(ISTATE,ICHARG).GT.0.D0) THEN
C
             I_ALIB=2*INT(SP_ALI(ISTATE,ICHARG))+1
         ELSE
             I_ALIB=2*INT(SP_ALI(ISTATE,ICHARG))-1
C
         END IF
C
C=======================================================================
C        DEFINING PARITY
C=======================================================================
C
         IF (SPPARI(ISTATE,ICHARG).GT.0.0) THEN
C
             IPARIT=0
         ELSE
             IPARIT=1
C
         END IF
C
         N_PARI(IPARIT)=N_PARI(IPARIT)+1
C
         IF  (KALDUM(I_ALIB,IPARIT,ICHARG).LT.
     *   IABS(KALSIQ(I_ALIB,IPARIT,ICHARG)).AND.
     *   IABS(I_ALIB).LE.MXALIB) THEN
C
C            HERE THERE ARE STATES TO BE FILLED IN THE ALINGMENT BLOCK
C
             IF  (KALSIQ(I_ALIB,IPARIT,ICHARG).GT.0.OR.
     *            KALDUM(I_ALIB,IPARIT,ICHARG).NE.
     *       IABS(KALSIQ(I_ALIB,IPARIT,ICHARG))-1) THEN
C
C                HERE NO PARTICLE-HOLE EXCITATION IS TO BE PERFORMED
C
                 KALDUM(I_ALIB,IPARIT,ICHARG)=
     *           KALDUM(I_ALIB,IPARIT,ICHARG)+1
C
                 IF  (LASTAL(ICHARG).EQ.0.OR.
     *                KALDUM(I_ALIB,IPARIT,ICHARG).EQ.
     *           IABS(KALSIQ(I_ALIB,IPARIT,ICHARG))) THEN
C
C                    HERE STATES ARE ADDED
C
                     K_OCAL(N_PARI(IPARIT),IPARIT,ICHARG)=1
C
                     KUALIB(IPARIT,ICHARG)=
     *               KUALIB(IPARIT,ICHARG)+1
C
                 END IF
C
             ELSE
C
                 IF (IFOUND(I_ALIB,IPARIT).EQ.1) THEN
C
C                    HERE A PARTICLE EXCITED STATE IS FILLED
C
                     K_OCAL(N_PARI(IPARIT),IPARIT,ICHARG)=1
C
                     KALDUM(I_ALIB,IPARIT,ICHARG)=
     *               KALDUM(I_ALIB,IPARIT,ICHARG)+1
                     KUALIB(       IPARIT,ICHARG)=
     *               KUALIB(       IPARIT,ICHARG)+1
C
                 ELSE
C
C                    HERE A HOLE STATE IS OMITTED FROM FILLING
C
                     IFOUND(I_ALIB,IPARIT)=1
C
                 END IF
C
             END IF
C
         END IF
C
      END DO
C
    1 CONTINUE
C
C=======================================================================
C         PRINTING ARRAYS OF OCCUPATIONS
C=======================================================================
C
      IF (PRINIT)
     *
     *    WRITE(NFIPRI,'(1H*,77(1H*),1H*,/,1H*,77X,1H*,/,
     *                   1H*,1X,''NUMBERS OF STATES OCCUPIED IN '',
     *                          ''ALIGNMENT BLOCKS SPECIFIED IN '',
     *                          ''THE '',A1,'' DIRECTION'',1X,1H*,/,
     *                   1H*,77X,1H*)')
     *    AXINAM(IABS(NLSIQR))
C
      IF (ICHARG.EQ.0) I_HEAD=0
C
      IF (I_HEAD.EQ.0) THEN
C
          IF (NLSIQR.GT.0) THEN
C
              IF (LASTAL(ICHARG).EQ.1) THEN
C
                  WRITE(NFIPRI,'(1H*,77(1H*),1H*,/,
     *                           1H*,'' LAST  P SUM'',16I4,1X,1H*)')
     *                          (I_ALIB,I_ALIB=-15,15,2)
              ELSE
C
                  WRITE(NFIPRI,'(1H*,77(1H*),1H*,/,
     *                           1H*,'' BLCKD P SUM'',16I4,1X,1H*)')
     *                          (I_ALIB,I_ALIB=-15,15,2)
              END IF
C
          ELSE
C
              WRITE(NFIPRI,'(1H*,77(1H*),1H*,/,
     *                       1H*,'' INFO  P SUM'',16I4,1X,1H*)')
     *                      (I_ALIB,I_ALIB=-15,15,2)
C
          END IF
C
      END IF
C
      I_HEAD=1
C
      DO IPARIT=0,NDPARI
C
         WRITE(NFIPRI,'(1H*,'' CON '',A1,1X,A1,17I4,1X,1H*)')
     *
     *      PARNAM(ICHARG),PLUMIN(IPARIT),KUALIB(IPARIT,ICHARG),
     *     (0,I_ALIB=-15,-MXALIB-2,2),
     *     (KALSIQ(I_ALIB,IPARIT,ICHARG),I_ALIB=-MXALIB,MXALIB,2),
     *     (0,I_ALIB=MXALIB+2,15,2)
C
         WRITE(NFIPRI,'(1H*,'' VAC '',A1,1X,A1,17I4,1X,1H*)')
     *
     *      PARNAM(ICHARG),PLUMIN(IPARIT),NUALIB(IPARIT,ICHARG),
     *     (0,I_ALIB=-15,-MXALIB-2,2),
     *     (MALSIQ(I_ALIB,IPARIT,ICHARG),I_ALIB=-MXALIB,MXALIB,2),
     *     (0,I_ALIB=MXALIB+2,15,2)
C
      END DO
C
      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE AXISIZ(NLSIZR,MXALIB,ICHARG)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PARNAM(0:NDISOS)*3,AXINAM(1:NDKART)*1
C
      LOGICAL
     *          PRINIT
C
      DIMENSION
     *          NUALIB(0:NDISOS),
     *          KUALIB(0:NDISOS)
      DIMENSION
     *          SP_ALI(1:2*NDSTAT,0:NDISOS)
      DIMENSION
     *          KALDUM(-NDALIB:NDALIB,0:NDISOS)
      DIMENSION
     *          IFOUND(-NDALIB:NDALIB)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZOCC/ M_OCCU(1:2*NDSTAT,0:NDISOS),
     *                M_OCVA(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZOCA/ M_OCAL(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZALI/ KALSIZ(-NDALIB:NDALIB,0:NDISOS),
     *                MALSIZ(-NDALIB:NDALIB,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /PNHEAD/ I_HEAD
      COMMON
     *       /ALLAST/ LASTAL(0:NDISOS)
      COMMON
     *       /IPRITE/ PRINIT
C
      DATA
     *       PARNAM /'NEU','PRO'/
      DATA
     *       AXINAM /'x','y','z'/
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF THE  PARITY   SYMMETRY
C        AND HANDLES OCCUPATIONS OF PARTICLES IN ALIGNMENT BLOCKS
C
C=======================================================================
C
      IF (MXALIB.GT.NDALIB) STOP ' NDALIB TOO SMALL IN AXISIZ'
C
      IF (MOD(MXALIB,2).NE.1) STOP ' MXALIB NOT ODD IN AXISIZ'
C
C=======================================================================
C
C=======================================================================
C
      IF (NLSIZR.EQ.0) RETURN
C
      IF (ABS(NLSIZR).GT.3) STOP ' INCORRECT NLSIZR IN AXISIZ'
C
C=======================================================================
C
      IF (IABS(NLSIZR).EQ.1) SP_ALI=SPXALI
      IF (IABS(NLSIZR).EQ.2) SP_ALI=SPALIG
      IF (IABS(NLSIZR).EQ.3) SP_ALI=SPZALI
C
C=======================================================================
C        DETERMINING DISTRIBUTION OF PARTICLES IN ALIGNMENT BLOCKS
C=======================================================================
C
      MALSIZ(:,ICHARG)=0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C        DEFINING A HALF-INTEGER SPIN CLOSEST TO THE AVERAGE VALUE
C=======================================================================
C
         IF (SP_ALI(ISTATE,ICHARG).GT.0.D0) THEN
C
             I_ALIB=2*INT(SP_ALI(ISTATE,ICHARG))+1
         ELSE
             I_ALIB=2*INT(SP_ALI(ISTATE,ICHARG))-1
C
         END IF
C
C=======================================================================
C
         IF (M_OCCU(ISTATE,ICHARG).EQ.1.AND.
     *       IABS(I_ALIB).LE.MXALIB)
     *
     *       MALSIZ(I_ALIB,ICHARG)=MALSIZ(I_ALIB,ICHARG)+1
C
      END DO
C
C=======================================================================
C         DETERMINING NUMBERS OF PARTICLES IN CHARGE BLOCKS
C=======================================================================
C
      KUALIB(ICHARG)=0
      NUALIB(ICHARG)=0
C
      DO I_ALIB=-MXALIB,MXALIB,2
C
         KUALIB(ICHARG)=KUALIB(ICHARG)+IABS(KALSIZ(I_ALIB,ICHARG))
         NUALIB(ICHARG)=NUALIB(ICHARG)+     MALSIZ(I_ALIB,ICHARG)
C
      END DO
C
C=======================================================================
C        DEFINING DISTRIBUTION OF PARTICLES IN ALIGNMENT BLOCKS
C=======================================================================
C
      IF (NLSIZR.LT.0) GO TO 1
C
C=======================================================================
C        THIS IS PERFORMED ONLY FOR NLSIZR>0
C=======================================================================
C
      IFOUND=0
      KALDUM=0
C
      M_OCAL(:,ICHARG)=0
      KUALIB(  ICHARG)=0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C        DEFINING A HALF-INTEGER SPIN CLOSEST TO THE AVERAGE VALUE
C=======================================================================
C
         IF (SP_ALI(ISTATE,ICHARG).GT.0.D0) THEN
C
             I_ALIB=2*INT(SP_ALI(ISTATE,ICHARG))+1
         ELSE
             I_ALIB=2*INT(SP_ALI(ISTATE,ICHARG))-1
C
         END IF
C
         IF  (KALDUM(I_ALIB,ICHARG).LT.
     *   IABS(KALSIZ(I_ALIB,ICHARG)).AND.
     *   IABS(I_ALIB).LE.MXALIB) THEN
C
C            HERE THERE ARE STATES TO BE FILLED IN THE ALINGMENT BLOCK
C
             IF  (KALSIZ(I_ALIB,ICHARG).GT.0.OR.
     *            KALDUM(I_ALIB,ICHARG).NE.
     *       IABS(KALSIZ(I_ALIB,ICHARG))-1) THEN
C
C                HERE NO PARTICLE-HOLE EXCITATION IS TO BE PERFORMED
C
                 KALDUM(I_ALIB,ICHARG)=
     *           KALDUM(I_ALIB,ICHARG)+1
C
                 IF  (LASTAL(ICHARG).EQ.0.OR.
     *                KALDUM(I_ALIB,ICHARG).EQ.
     *           IABS(KALSIZ(I_ALIB,ICHARG))) THEN
C
C                    HERE STATES ARE ADDED
C
                     M_OCAL(ISTATE,ICHARG)=1
C
                     KUALIB(ICHARG)=
     *               KUALIB(ICHARG)+1
C
                 END IF
C
             ELSE
C
                 IF (IFOUND(I_ALIB).EQ.1) THEN
C
C                    HERE A PARTICLE EXCITED STATE IS FILLED
C
                     M_OCAL(ISTATE,ICHARG)=1
C
                     KALDUM(I_ALIB,ICHARG)=
     *               KALDUM(I_ALIB,ICHARG)+1
                     KUALIB(       ICHARG)=
     *               KUALIB(       ICHARG)+1
C
                 ELSE
C
C                    HERE A HOLE STATE IS OMITTED FROM FILLING
C
                     IFOUND(I_ALIB)=1
C
                 END IF
C
             END IF
C
         END IF
C
      END DO
C
    1 CONTINUE
C
C=======================================================================
C         PRINTING ARRAYS OF OCCUPATIONS
C=======================================================================
C
      IF (PRINIT)
     *
     *    WRITE(NFIPRI,'(1H*,77(1H*),1H*,/,1H*,77X,1H*,/,
     *                   1H*,1X,''NUMBERS OF STATES OCCUPIED IN '',
     *                          ''ALIGNMENT BLOCKS SPECIFIED IN '',
     *                          ''THE '',A1,'' DIRECTION'',1X,1H*,/,
     *                   1H*,77X,1H*)')
     *    AXINAM(IABS(NLSIZR))
C
      IF (ICHARG.EQ.0.OR.PRINIT) I_HEAD=0
C
      IF (I_HEAD.EQ.0) THEN
C
          IF (NLSIZR.GT.0) THEN
C
              IF (LASTAL(ICHARG).EQ.1) THEN
C
                  WRITE(NFIPRI,'(1H*,77(1H*),1H*,/,
     *                           1H*,'' LASTORB SUM'',16I4,1X,1H*)')
     *                          (I_ALIB,I_ALIB=-15,15,2)
              ELSE
C
                  WRITE(NFIPRI,'(1H*,77(1H*),1H*,/,
     *                           1H*,'' BLOCKED SUM'',16I4,1X,1H*)')
     *                          (I_ALIB,I_ALIB=-15,15,2)
              END IF
C
          ELSE
C
              WRITE(NFIPRI,'(1H*,77(1H*),1H*,/,
     *                       1H*,'' INFORM. SUM'',16I4,1X,1H*)')
     *                      (I_ALIB,I_ALIB=-15,15,2)
C
          END IF
C
      END IF
C
      I_HEAD=1
C
      WRITE(NFIPRI,'(1H*,'' CON '',A3,17I4,1X,1H*)')
     *
     *   PARNAM(ICHARG),KUALIB(ICHARG),
     *  (0,I_ALIB=-15,-MXALIB-2,2),
     *  (KALSIZ(I_ALIB,ICHARG),I_ALIB=-MXALIB,MXALIB,2),
     *  (0,I_ALIB=MXALIB+2,15,2)
C
      WRITE(NFIPRI,'(1H*,'' VAC '',A3,17I4,1X,1H*)')
     *
     *   PARNAM(ICHARG),NUALIB(ICHARG),
     *  (0,I_ALIB=-15,-MXALIB-2,2),
     *  (MALSIZ(I_ALIB,ICHARG),I_ALIB=-MXALIB,MXALIB,2),
     *  (0,I_ALIB=MXALIB+2,15,2)
C
      WRITE(NFIPRI,'(1H*,77X,1H*)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FLISIG(MREVER)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PARNAM(0:NDISOS)*4,PLUMIN(0:1)*1
C
      DIMENSION
     *          DIALIG(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS),
     *          DISPAL(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      DIMENSION
     *          DPALIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *          DPSPAL(0:NDPARI,0:NDREVE,0:NDISOS),
     *          DHALIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *          DHSPAL(0:NDPARI,0:NDREVE,0:NDISOS)
      DIMENSION
     *          IPALIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *          IPSPAL(0:NDPARI,0:NDREVE,0:NDISOS),
     *          IHALIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *          IHSPAL(0:NDPARI,0:NDREVE,0:NDISOS)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLOLD/ OLALIG(1:2*NDSTAT,0:NDISOS),
     *                OLSPAL(1:2*NDSTAT,0:NDISOS),
     *                OLPARI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIGOCC/ N_OCCU(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS),
     *                N_OCVA(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       PARNAM /'NEUT','PROT'/,
     *       PLUMIN /'+'   ,'-'   /
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF THE SIGNATURE SYMMETRY
C        AND FINDS THE SINGLE PARTICLE  STATES  WHICH  HAVE  ALTERNATING
C        PROPERTIES FROM ONE ITERATION TO ANOTHER.
C
C        ATTENTION: THIS SUBROUTINE MUST KNOW THE  SINGLE-PARTICLE
C                   PROPERTIES IN THE PREVIOUS ITERATION. THE USER
C                   IS RESPONSIBLE FOR NOT CALLING IT IN THE FIRST
C                   ITERATION.
C
C=======================================================================
C
C=======================================================================
C        RETRIEVING VALUES OF ALIGNMENTS OBTAINED IN THE PREVIOUS
C        ITERATION
C=======================================================================
C
      DO IREVER=0,MREVER
         DO ICHARG=0,NDISOS
C
            NPAPLU=0
            NPAMIN=0
C
            DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
               IF (OLPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG).GT.0.0)
     *                                                              THEN
C
                   NPAPLU=NPAPLU+1
C
                   DIALIG(NPAPLU,0,IREVER,ICHARG)=
     *               OLALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                   DISPAL(NPAPLU,0,IREVER,ICHARG)=
     *               OLSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
               ELSE
C
                   NPAMIN=NPAMIN+1
C
                   DIALIG(NPAMIN,1,IREVER,ICHARG)=
     *               OLALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                   DISPAL(NPAMIN,1,IREVER,ICHARG)=
     *               OLSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
               END IF
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C        DETERMINING ABSOLUTE VALUES OF DIFFERENCES OF ALIGNMENTS
C        BETWEEN THE PREVIOUS AND CURRENT ITERATIONS
C=======================================================================
C
      DO IREVER=0,MREVER
         DO ICHARG=0,NDISOS
C
            NPAPLU=0
            NPAMIN=0
C
            DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
               IF (SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG).GT.0.0)
     *                                                              THEN
C
                   NPAPLU=NPAPLU+1
C
                   DIALIG(NPAPLU,0,IREVER,ICHARG)=
     *                              ABS(DIALIG(NPAPLU,0,IREVER,ICHARG)-
     *                    SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG))
C
                   DISPAL(NPAPLU,0,IREVER,ICHARG)=
     *                              ABS(DISPAL(NPAPLU,0,IREVER,ICHARG)-
     *                    SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG))
C
               ELSE
C
                   NPAMIN=NPAMIN+1
C
                   DIALIG(NPAMIN,1,IREVER,ICHARG)=
     *                              ABS(DIALIG(NPAMIN,1,IREVER,ICHARG)-
     *                    SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG))
C
                   DISPAL(NPAMIN,1,IREVER,ICHARG)=
     *                              ABS(DISPAL(NPAMIN,1,IREVER,ICHARG)-
     *                    SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG))
C
               END IF
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         INITIALIZING ARRAYS OF MAXIMUM DIFFERENCES
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,MREVER
            DO ICHARG=0,NDISOS
C
               DPALIG(IPARIT,IREVER,ICHARG)=-1.0
               DPSPAL(IPARIT,IREVER,ICHARG)=-1.0
               DHALIG(IPARIT,IREVER,ICHARG)=-1.0
               DHSPAL(IPARIT,IREVER,ICHARG)=-1.0
C
               IPALIG(IPARIT,IREVER,ICHARG)=-1
               IPSPAL(IPARIT,IREVER,ICHARG)=-1
               IHALIG(IPARIT,IREVER,ICHARG)=-1
               IHSPAL(IPARIT,IREVER,ICHARG)=-1
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        DETERMINING MAXIMUM DIFFERENCES OF ALIGNMENTS IN THE
C        CHARGE-PARITY-SIGNATURE BLOCKS
C=======================================================================
C
      DO IREVER=0,MREVER
         DO ICHARG=0,NDISOS
C
            NPAPLU=0
            NPAMIN=0
C
            DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
               IF (SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG).GT.0.0)
     *                                                              THEN
C
                   NPAPLU=NPAPLU+1
C
C=======================================================================
C              ANGULAR MOMENTUM ALIGNMENT IN THE POSITIVE-PARITY BLOCK
C              FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                   IF (DIALIG(NPAPLU,0,IREVER,ICHARG).GE.
     *                 DPALIG(       0,IREVER,ICHARG).AND.
     *                 N_OCCU(NPAPLU,0,IREVER,ICHARG).EQ.0) THEN
C
                       DPALIG(       0,IREVER,ICHARG)=
     *                 DIALIG(NPAPLU,0,IREVER,ICHARG)
C
                       IPALIG(       0,IREVER,ICHARG)=NPAPLU
C
                   END IF
C
C=======================================================================
C              ANGULAR MOMENTUM ALIGNMENT IN THE POSITIVE-PARITY BLOCK
C              FOR HOLE (OCCUPIED) STATES
C=======================================================================
C
                   IF (DIALIG(NPAPLU,0,IREVER,ICHARG).GE.
     *                 DHALIG(       0,IREVER,ICHARG).AND.
     *                 N_OCCU(NPAPLU,0,IREVER,ICHARG).EQ.1) THEN
C
                       DHALIG(       0,IREVER,ICHARG)=
     *                 DIALIG(NPAPLU,0,IREVER,ICHARG)
C
                       IHALIG(       0,IREVER,ICHARG)=NPAPLU
C
                   END IF
C
C=======================================================================
C              INTRINSIC SPIN ALIGNMENT IN THE POSITIVE-PARITY BLOCK
C              FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                   IF (DISPAL(NPAPLU,0,IREVER,ICHARG).GE.
     *                 DPSPAL(       0,IREVER,ICHARG).AND.
     *                 N_OCCU(NPAPLU,0,IREVER,ICHARG).EQ.0) THEN
C
                       DPSPAL(       0,IREVER,ICHARG)=
     *                 DISPAL(NPAPLU,0,IREVER,ICHARG)
C
                       IPSPAL(       0,IREVER,ICHARG)=NPAPLU
C
                   END IF
C
C=======================================================================
C              INTRINSIC SPIN ALIGNMENT IN THE POSITIVE-PARITY BLOCK
C              FOR HOLE (OCCUPIED) STATES
C=======================================================================
C
                   IF (DISPAL(NPAPLU,0,IREVER,ICHARG).GE.
     *                 DHSPAL(       0,IREVER,ICHARG).AND.
     *                 N_OCCU(NPAPLU,0,IREVER,ICHARG).EQ.1) THEN
C
                       DHSPAL(       0,IREVER,ICHARG)=
     *                 DISPAL(NPAPLU,0,IREVER,ICHARG)
C
                       IHSPAL(       0,IREVER,ICHARG)=NPAPLU
C
                   END IF
C
               ELSE
C
                   NPAMIN=NPAMIN+1
C
C=======================================================================
C              ANGULAR MOMENTUM ALIGNMENT IN THE NEGATIVE-PARITY BLOCK
C              FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                   IF (DIALIG(NPAMIN,1,IREVER,ICHARG).GE.
     *                 DPALIG(       1,IREVER,ICHARG).AND.
     *                 N_OCCU(NPAMIN,1,IREVER,ICHARG).EQ.0) THEN
C
                       DPALIG(       1,IREVER,ICHARG)=
     *                 DIALIG(NPAMIN,1,IREVER,ICHARG)
C
                       IPALIG(       1,IREVER,ICHARG)=NPAMIN
C
                   END IF
C
C=======================================================================
C              ANGULAR MOMENTUM ALIGNMENT IN THE NEGATIVE-PARITY BLOCK
C              FOR HOLE (OCCUPIED) STATES
C=======================================================================
C
                   IF (DIALIG(NPAMIN,1,IREVER,ICHARG).GE.
     *                 DHALIG(       1,IREVER,ICHARG).AND.
     *                 N_OCCU(NPAMIN,1,IREVER,ICHARG).EQ.1) THEN
C
                       DHALIG(       1,IREVER,ICHARG)=
     *                 DIALIG(NPAMIN,1,IREVER,ICHARG)
C
                       IHALIG(       1,IREVER,ICHARG)=NPAMIN
C
                   END IF
C
C=======================================================================
C              INTRINSIC SPIN ALIGNMENT IN THE NEGATIVE-PARITY BLOCK
C              FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                   IF (DISPAL(NPAMIN,1,IREVER,ICHARG).GE.
     *                 DPSPAL(       1,IREVER,ICHARG).AND.
     *                 N_OCCU(NPAMIN,1,IREVER,ICHARG).EQ.0) THEN
C
                       DPSPAL(       1,IREVER,ICHARG)=
     *                 DISPAL(NPAMIN,1,IREVER,ICHARG)
C
                       IPSPAL(       1,IREVER,ICHARG)=NPAMIN
C
                   END IF
C
C=======================================================================
C              INTRINSIC SPIN ALIGNMENT IN THE NEGATIVE-PARITY BLOCK
C              FOR HOLE (OCCUPIED) STATES
C=======================================================================
C
                   IF (DISPAL(NPAMIN,1,IREVER,ICHARG).GE.
     *                 DHSPAL(       1,IREVER,ICHARG).AND.
     *                 N_OCCU(NPAMIN,1,IREVER,ICHARG).EQ.1) THEN
C
                       DHSPAL(       1,IREVER,ICHARG)=
     *                 DISPAL(NPAMIN,1,IREVER,ICHARG)
C
                       IHSPAL(       1,IREVER,ICHARG)=NPAMIN
C
                   END IF
C
               END IF
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         PRINTING THE MAXIMUM ALIGNMENTS
C=======================================================================
C
      WRITE(NFIPRI,'(
     *          1H*,1X,'' TABLE BELOW GIVES THE MAXIMUM ABSOLUT'',
     *                 ''E VALUES OF DIFFERENCES OF ALIGNMENT  '',1H*,/,
     *          1H*,1X,'' BETWEEN THE LAST TWO ITERATIONS. IT M'',
     *                 ''AY SERVE AS A GUIDE TO SELECT STATES  '',1H*,/,
     *          1H*,1X,'' WHICH EXCHANGE WAVE FUNCTIONS IN EVER'',
     *                 ''Y SECOND ITERATION.  SUCH STATES MAY  '',1H*,/,
     *          1H*,1X,'' BE CANDIDATES FOR A CALCULATION WITH '',
     *                 ''DIABATICALLY BLOCKED  CONFIGURATIONS  '',1H*,/,
     *          1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,18X,1H*,58X,1H*,/,
     *         1H*,1X,''     BLOCKS      * ANGULAR MOMENTUM AL'',
     *                ''IGNMENT    INTRINSIC SPIN  ALIGNMENT  '',1H*,/,
     *         1H*,1X,''     ------      * -------------------'',
     *                ''-------    -------------------------  '',1H*,/,
     *         1H*,1X,''                 *   PARTICLES       H'',
     *                ''OLES        PARTICLES       HOLES     '',1H*,/,
     *         1H*,1X,'' ISO. PAR. SIG.  *  INDEX VALUE   INDE'',
     *                ''X VALUE    INDEX VALUE   INDEX VALUE  '',1H*,/,
     *         1H*,18X,1H*,58X,1H*,/,79(1H*),/,
     *         1H*,18X,1H*,58X,1H*,
     *     8(/,1H*,1X,A4,1X,2(2X,A1,2X),2X,
     *         1H*,2(2(I5,F8.3,1X),1X),1H*))')
     *
     *       (((PARNAM(ICHARG),PLUMIN(IPARIT),
     *          PLUMIN(IREVER*(1-IPARIT)+(1-IREVER)*IPARIT),
     *
     *          IPALIG(IPARIT,IREVER,ICHARG),
     *          DPALIG(IPARIT,IREVER,ICHARG),
     *          IHALIG(IPARIT,IREVER,ICHARG),
     *          DHALIG(IPARIT,IREVER,ICHARG),
     *          IPSPAL(IPARIT,IREVER,ICHARG),
     *          DPSPAL(IPARIT,IREVER,ICHARG),
     *          IHSPAL(IPARIT,IREVER,ICHARG),
     *          DHSPAL(IPARIT,IREVER,ICHARG),IREVER=0,MREVER),
     *                                       IPARIT=0,NDPARI),
     *                                       ICHARG=0,NDISOS)
C
      WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
C=======================================================================
C        DETERMINING CANDIDATES FOR DIABATIC  BLOCKING  IN  ANY  OF  THE
C        CHARGE-PARITY-SIGNATURE BLOCKS.  A PAIR OF STATES IS CONSIDERED
C        TO BE A GOOD CANDIDATE FOR DIABATIC BLOCKING IF IT IS  COMPOSED
C        OF A PARTICLE AND A HOLE WITH ADJACENT INDICES.
C=======================================================================
C
      NUMCAN=0
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,MREVER
            DO ICHARG=0,NDISOS
C
               IF (ABS(IPALIG(IPARIT,IREVER,ICHARG)-
     *                 IHALIG(IPARIT,IREVER,ICHARG)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        ANGULAR MOMENTUM ALIGNMENT IS FOUND
C=======================================================================
C
                   NUMCAN=NUMCAN+1
C
                   IF (NUMCAN.EQ.1) THEN
C
                      WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                       ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *                1H*,/,
     *                1H*,77X,1H*,/,79(1H*),/,
     *                1H*,18X,1H*,58X,1H*)')
C
                   END IF
C
                   WRITE(NFIPRI,'(1H*,1X,A4,1X,2(2X,A1,2X),2X,
     *                            1H*,2(I5,F8.3,1X),1X,29X,1H*)')
     *
     *                   PARNAM(ICHARG),PLUMIN(IPARIT),
     *                   PLUMIN(IREVER*(1-IPARIT)+(1-IREVER)*IPARIT),
     *
     *                   IPALIG(IPARIT,IREVER,ICHARG),
     *                   DPALIG(IPARIT,IREVER,ICHARG),
     *                   IHALIG(IPARIT,IREVER,ICHARG),
     *                   DHALIG(IPARIT,IREVER,ICHARG)
C
               END IF
C
               IF (ABS(IPSPAL(IPARIT,IREVER,ICHARG)-
     *                 IHSPAL(IPARIT,IREVER,ICHARG)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        INTRINSIC SPIN ALIGNMENT IS FOUND
C=======================================================================
C
                   NUMCAN=NUMCAN+1
C
                   IF (NUMCAN.EQ.1) THEN
C
                      WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *                1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                       ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *                1H*,/,
     *                1H*,77X,1H*,/,79(1H*),/,
     *                1H*,18X,1H*,58X,1H*)')
C
                   END IF
C
                   WRITE(NFIPRI,'(1H*,1X,A4,1X,2(2X,A1,2X),2X,
     *                            1H*,29X,2(I5,F8.3,1X),1X,1H*)')
     *
     *                   PARNAM(ICHARG),PLUMIN(IPARIT),
     *                   PLUMIN(IREVER*(1-IPARIT)+(1-IREVER)*IPARIT),
     *
     *                   IPSPAL(IPARIT,IREVER,ICHARG),
     *                   DPSPAL(IPARIT,IREVER,ICHARG),
     *                   IHSPAL(IPARIT,IREVER,ICHARG),
     *                   DHSPAL(IPARIT,IREVER,ICHARG)
C
               END IF
C
            END DO
         END DO
      END DO
C
      IF (NUMCAN.EQ.0) THEN
C
C=======================================================================
C        NO CANDIDATE PAIRS OF STATES FOR DIABATIC BLOCKING WERE FOUND
C=======================================================================
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,1X,''   NO GOOD CANDIDATE CONFIGURATIONS FO'',
     *                ''R THE DIABATIC BLOCKING WERE FOUND    '',1H*,/,
     *         1H*,77X,1H*,/,79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,'(1X)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FLISIM(MREVER)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PARNAM(0:NDISOS)*7,PLUMIN(0:1)*1
C
      DIMENSION
     *          EIALIG(1:NDSTAT,0:NDREVE,0:NDISOS),
     *          EISPAL(1:NDSTAT,0:NDREVE,0:NDISOS)
      DIMENSION
     *          EPALIG(0:NDREVE,0:NDISOS),
     *          EPSPAL(0:NDREVE,0:NDISOS),
     *          EHALIG(0:NDREVE,0:NDISOS),
     *          EHSPAL(0:NDREVE,0:NDISOS)
      DIMENSION
     *          JPALIG(0:NDREVE,0:NDISOS),
     *          JPSPAL(0:NDREVE,0:NDISOS),
     *          JHALIG(0:NDREVE,0:NDISOS),
     *          JHSPAL(0:NDREVE,0:NDISOS)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLOLD/ OLALIG(1:2*NDSTAT,0:NDISOS),
     *                OLSPAL(1:2*NDSTAT,0:NDISOS),
     *                OLPARI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIMOCC/ L_OCCU(1:NDSTAT,0:NDREVE,0:NDISOS),
     *                L_OCVA(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       PARNAM /'NEUTRON','PROTON '/,
     *       PLUMIN /'+'      ,'-'      /
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF THE  SIMPLEX  SYMMETRY
C        AND FINDS THE SINGLE PARTICLE  STATES  WHICH  HAVE  ALTERNATING
C        PROPERTIES FROM ONE ITERATION TO ANOTHER.
C
C        ATTENTION: THIS SUBROUTINE MUST KNOW THE  SINGLE-PARTICLE
C                   PROPERTIES IN THE PREVIOUS ITERATION. THE USER
C                   IS RESPONSIBLE FOR NOT CALLING IT IN THE FIRST
C                   ITERATION.
C
C=======================================================================
C
C=======================================================================
C        DETERMINING ABSOLUTE VALUES OF DIFFERENCES OF ALIGNMENTS
C        BETWEEN THE PREVIOUS AND CURRENT ITERATIONS
C=======================================================================
C
      DO IREVER=0,MREVER
         DO ICHARG=0,NDISOS
            DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
               EIALIG(ISTATE,IREVER,ICHARG)=
     *                ABS(OLALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                  - SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG))
C
               EISPAL(ISTATE,IREVER,ICHARG)=
     *                ABS(OLSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                  - SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG))
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         INITIALIZONG ARRAYS OF MAXIMUM DIFFERENCES
C=======================================================================
C
      DO IREVER=0,MREVER
         DO ICHARG=0,NDISOS
C
            EPALIG(IREVER,ICHARG)=-1.0
            EPSPAL(IREVER,ICHARG)=-1.0
            EHALIG(IREVER,ICHARG)=-1.0
            EHSPAL(IREVER,ICHARG)=-1.0
C
            JPALIG(IREVER,ICHARG)=-1
            JPSPAL(IREVER,ICHARG)=-1
            JHALIG(IREVER,ICHARG)=-1
            JHSPAL(IREVER,ICHARG)=-1
C
         END DO
      END DO
C
C=======================================================================
C        DETERMINING MAXIMUM DIFFERENCES OF ALIGNMENTS IN THE
C        CHARGE-SIMPLEX BLOCKS
C=======================================================================
C
      DO IREVER=0,MREVER
         DO ICHARG=0,NDISOS
            DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
C=======================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
               IF (EIALIG(ISTATE,IREVER,ICHARG).GE.
     *             EPALIG(       IREVER,ICHARG).AND.
     *             L_OCCU(ISTATE,IREVER,ICHARG).EQ.0) THEN
C
                   EPALIG(       IREVER,ICHARG)=
     *             EIALIG(ISTATE,IREVER,ICHARG)
C
                   JPALIG(       IREVER,ICHARG)=ISTATE
C
               END IF
C
C===================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
               IF (EIALIG(ISTATE,IREVER,ICHARG).GE.
     *             EHALIG(       IREVER,ICHARG).AND.
     *             L_OCCU(ISTATE,IREVER,ICHARG).EQ.1) THEN
C
                   EHALIG(       IREVER,ICHARG)=
     *             EIALIG(ISTATE,IREVER,ICHARG)
C
                   JHALIG(       IREVER,ICHARG)=ISTATE
C
               END IF
C
C===================================================================
C          INTRINSIC SPIN ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C===================================================================
C
               IF (EISPAL(ISTATE,IREVER,ICHARG).GE.
     *             EPSPAL(       IREVER,ICHARG).AND.
     *             L_OCCU(ISTATE,IREVER,ICHARG).EQ.0) THEN
C
                   EPSPAL(       IREVER,ICHARG)=
     *             EISPAL(ISTATE,IREVER,ICHARG)
C
                   JPSPAL(       IREVER,ICHARG)=ISTATE
C
               END IF
C
C===================================================================
C           INTRINSIC SPIN ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
               IF (EISPAL(ISTATE,IREVER,ICHARG).GE.
     *             EHSPAL(       IREVER,ICHARG).AND.
     *             L_OCCU(ISTATE,IREVER,ICHARG).EQ.1) THEN
C
                   EHSPAL(       IREVER,ICHARG)=
     *             EISPAL(ISTATE,IREVER,ICHARG)
C
                   JHSPAL(       IREVER,ICHARG)=ISTATE
C
               END IF
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         PRINTING THE MAXIMUM ALIGNMENTS
C=======================================================================
C
      WRITE(NFIPRI,'(
     *          1H*,1X,'' TABLE BELOW GIVES THE MAXIMUM ABSOLUT'',
     *                 ''E VALUES OF DIFFERENCES OF ALIGNMENT  '',1H*,/,
     *          1H*,1X,'' BETWEEN THE LAST TWO ITERATIONS. IT M'',
     *                 ''AY SERVE AS A GUIDE TO SELECT STATES  '',1H*,/,
     *          1H*,1X,'' WHICH EXCHANGE WAVE FUNCTIONS IN EVER'',
     *                 ''Y SECOND ITERATION.  SUCH STATES MAY  '',1H*,/,
     *          1H*,1X,'' BE CANDIDATES FOR A CALCULATION WITH '',
     *                 ''DIABATICALLY BLOCKED  CONFIGURATIONS  '',1H*,/,
     *          1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,18X,1H*,58X,1H*,/,
     *         1H*,1X,''     BLOCKS      * ANGULAR MOMENTUM AL'',
     *                ''IGNMENT    INTRINSIC SPIN  ALIGNMENT  '',1H*,/,
     *         1H*,1X,''     ------      * -------------------'',
     *                ''-------    -------------------------  '',1H*,/,
     *         1H*,1X,''                 *   PARTICLES       H'',
     *                ''OLES        PARTICLES       HOLES     '',1H*,/,
     *         1H*,1X,'' ISOSPIN SIMPLEX *  INDEX VALUE   INDE'',
     *                ''X VALUE    INDEX VALUE   INDEX VALUE  '',1H*,/,
     *         1H*,18X,1H*,58X,1H*,/,79(1H*),/,
     *         1H*,18X,1H*,58X,1H*,
     *     4(/,1H*,1X,A7,4X,A1,''i'',4X,
     *         1H*,2(2(I5,F8.3,1X),1X),1H*))')
     *
     *        ((PARNAM(ICHARG),PLUMIN(IREVER),
     *
     *          JPALIG(IREVER,ICHARG),
     *          EPALIG(IREVER,ICHARG),
     *          JHALIG(IREVER,ICHARG),
     *          EHALIG(IREVER,ICHARG),
     *          JPSPAL(IREVER,ICHARG),
     *          EPSPAL(IREVER,ICHARG),
     *          JHSPAL(IREVER,ICHARG),
     *          EHSPAL(IREVER,ICHARG),IREVER=0,MREVER),
     *                                ICHARG=0,NDISOS)
C
      WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
C=======================================================================
C        DETERMINING CANDIDATES FOR DIABATIC BLOCKING IN ANY OF THE
C        CHARGE-SIMPLEX BLOCKS.   A  PAIR  OF  STATES IS CONSIDERED
C        TO BE A GOOD CANDIDATE FOR  DIABATIC  BLOCKING  IF  IT  IS
C        COMPOSED OF A PARTICLE AND A HOLE WITH ADJACENT INDICES.
C=======================================================================
C
      NUMCAN=0
C
      DO IREVER=0,MREVER
         DO ICHARG=0,NDISOS
C
            IF (ABS(JPALIG(IREVER,ICHARG)-
     *              JHALIG(IREVER,ICHARG)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        ANGULAR MOMENTUM ALIGNMENT IS FOUND
C=======================================================================
C
                NUMCAN=NUMCAN+1
C
                IF (NUMCAN.EQ.1) THEN
C
                   WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *             1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                    ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *             1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,
     *             1H*,18X,1H*,58X,1H*)')
C
                END IF
C
                WRITE(NFIPRI,'(1H*,1X,A7,4X,A1,''i'',4X,
     *                         1H*,2(I5,F8.3,1X),1X,29X,1H*)')
     *
     *                PARNAM(ICHARG),PLUMIN(IREVER),
     *
     *                JPALIG(IREVER,ICHARG),
     *                EPALIG(IREVER,ICHARG),
     *                JHALIG(IREVER,ICHARG),
     *                EHALIG(IREVER,ICHARG)
C
            END IF
C
            IF (ABS(JPSPAL(IREVER,ICHARG)-
     *              JHSPAL(IREVER,ICHARG)).EQ.1) THEN
C
C=======================================================================
C           A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C           INTRINSIC SPIN ALIGNMENT IS FOUND
C=======================================================================
C
                NUMCAN=NUMCAN+1
C
                IF (NUMCAN.EQ.1) THEN
C
                   WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *             1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                    ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *             1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,
     *             1H*,18X,1H*,58X,1H*)')
C
                END IF
C
                WRITE(NFIPRI,'(1H*,1X,A7,4X,A1,''i'',4X,
     *                         1H*,29X,2(I5,F8.3,1X),1X,1H*)')
     *
     *                PARNAM(ICHARG),PLUMIN(IREVER),
     *
     *                JPSPAL(IREVER,ICHARG),
     *                EPSPAL(IREVER,ICHARG),
     *                JHSPAL(IREVER,ICHARG),
     *                EHSPAL(IREVER,ICHARG)
C
            END IF
C
         END DO
      END DO
C
      IF (NUMCAN.EQ.0) THEN
C
C=======================================================================
C        NO CANDIDATE PAIRS OF STATES FOR DIABATIC BLOCKING WERE FOUND
C=======================================================================
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,1X,''   NO GOOD CANDIDATE CONFIGURATIONS FO'',
     *                ''R THE DIABATIC BLOCKING WERE FOUND    '',1H*,/,
     *         1H*,77X,1H*,/,79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,'(1X)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FLISIQ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PARNAM(0:NDISOS)*7,PLUMIN(0:1)*1
C
      DIMENSION
     *          EIALIG(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *          EISPAL(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      DIMENSION
     *          EPALIG(0:NDPARI,0:NDISOS),
     *          EPSPAL(0:NDPARI,0:NDISOS),
     *          EHALIG(0:NDPARI,0:NDISOS),
     *          EHSPAL(0:NDPARI,0:NDISOS)
      DIMENSION
     *          JPALIG(0:NDPARI,0:NDISOS),
     *          JPSPAL(0:NDPARI,0:NDISOS),
     *          JHALIG(0:NDPARI,0:NDISOS),
     *          JHSPAL(0:NDPARI,0:NDISOS)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLOLD/ OLALIG(1:2*NDSTAT,0:NDISOS),
     *                OLSPAL(1:2*NDSTAT,0:NDISOS),
     *                OLPARI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIQOCC/ K_OCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *                K_OCVA(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       PARNAM /'NEUTRON','PROTON '/,
     *       PLUMIN /'+'      ,'-'      /
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF THE  PARITY   SYMMETRY
C        AND FINDS THE SINGLE PARTICLE  STATES  WHICH  HAVE  ALTERNATING
C        PROPERTIES FROM ONE ITERATION TO ANOTHER.
C
C        ATTENTION: THIS SUBROUTINE MUST KNOW THE  SINGLE-PARTICLE
C                   PROPERTIES IN THE PREVIOUS ITERATION. THE USER
C                   IS RESPONSIBLE FOR NOT CALLING IT IN THE FIRST
C                   ITERATION.
C
C=======================================================================
C
C=======================================================================
C        DETERMINING ABSOLUTE VALUES OF DIFFERENCES OF ALIGNMENTS
C        BETWEEN THE PREVIOUS AND CURRENT ITERATIONS
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         NPAPLU=0
         NPAMIN=0
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            IF (SPPARI(ISTATE,ICHARG).GT.0.0) THEN
C
                NPAPLU=NPAPLU+1
C
                EIALIG(NPAPLU,0,ICHARG)=
     *             ABS(OLALIG(ISTATE,ICHARG) - SPALIG(ISTATE,ICHARG))
C
                EISPAL(NPAPLU,0,ICHARG)=
     *             ABS(OLSPAL(ISTATE,ICHARG) - SPSPAL(ISTATE,ICHARG))
C
            ELSE
C
                NPAMIN=NPAMIN+1
C
                EIALIG(NPAMIN,1,ICHARG)=
     *             ABS(OLALIG(ISTATE,ICHARG) - SPALIG(ISTATE,ICHARG))
C
                EISPAL(NPAMIN,1,ICHARG)=
     *             ABS(OLSPAL(ISTATE,ICHARG) - SPSPAL(ISTATE,ICHARG))
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         INITIALIZING ARRAYS OF MAXIMUM DIFFERENCES
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO ICHARG=0,NDISOS
C
            EPALIG(IPARIT,ICHARG)=-1.0
            EPSPAL(IPARIT,ICHARG)=-1.0
            EHALIG(IPARIT,ICHARG)=-1.0
            EHSPAL(IPARIT,ICHARG)=-1.0
C
            JPALIG(IPARIT,ICHARG)=-1
            JPSPAL(IPARIT,ICHARG)=-1
            JHALIG(IPARIT,ICHARG)=-1
            JHSPAL(IPARIT,ICHARG)=-1
C
         END DO
      END DO
C
C=======================================================================
C        DETERMINING MAXIMUM DIFFERENCES OF ALIGNMENTS IN THE
C        CHARGE-SIMPLEX BLOCKS
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         NPAPLU=0
         NPAMIN=0
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            IF (SPPARI(ISTATE,ICHARG).GT.0.0) THEN
C
                NPAPLU=NPAPLU+1
C
C=======================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                IF (EIALIG(NPAPLU,0,ICHARG).GE.
     *              EPALIG(       0,ICHARG).AND.
     *              K_OCCU(NPAPLU,0,ICHARG).EQ.0) THEN
C
                    EPALIG(       0,ICHARG)=
     *              EIALIG(NPAPLU,0,ICHARG)
C
                    JPALIG(       0,ICHARG)=NPAPLU
C
                END IF
C
C===================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
                IF (EIALIG(NPAPLU,0,ICHARG).GE.
     *              EHALIG(       0,ICHARG).AND.
     *              K_OCCU(NPAPLU,0,ICHARG).EQ.1) THEN
C
                    EHALIG(       0,ICHARG)=
     *              EIALIG(NPAPLU,0,ICHARG)
C
                    JHALIG(       0,ICHARG)=NPAPLU
C
                END IF
C
C===================================================================
C          INTRINSIC SPIN ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C===================================================================
C
                IF (EISPAL(NPAPLU,0,ICHARG).GE.
     *              EPSPAL(       0,ICHARG).AND.
     *              K_OCCU(NPAPLU,0,ICHARG).EQ.0) THEN
C
                    EPSPAL(       0,ICHARG)=
     *              EISPAL(NPAPLU,0,ICHARG)
C
                    JPSPAL(       0,ICHARG)=NPAPLU
C
                END IF
C
C===================================================================
C           INTRINSIC SPIN ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
                IF (EISPAL(NPAPLU,0,ICHARG).GE.
     *              EHSPAL(       0,ICHARG).AND.
     *              K_OCCU(NPAPLU,0,ICHARG).EQ.1) THEN
C
                    EHSPAL(       0,ICHARG)=
     *              EISPAL(NPAPLU,0,ICHARG)
C
                    JHSPAL(       0,ICHARG)=NPAPLU
C
                END IF
C
            ELSE
C
                NPAMIN=NPAMIN+1
C
C=======================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                IF (EIALIG(NPAMIN,1,ICHARG).GE.
     *              EPALIG(       1,ICHARG).AND.
     *              K_OCCU(NPAMIN,1,ICHARG).EQ.0) THEN
C
                    EPALIG(       1,ICHARG)=
     *              EIALIG(NPAMIN,1,ICHARG)
C
                    JPALIG(       1,ICHARG)=NPAMIN
C
                END IF
C
C===================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
                IF (EIALIG(NPAMIN,1,ICHARG).GE.
     *              EHALIG(       1,ICHARG).AND.
     *              K_OCCU(NPAMIN,1,ICHARG).EQ.1) THEN
C
                    EHALIG(       1,ICHARG)=
     *              EIALIG(NPAMIN,1,ICHARG)
C
                    JHALIG(       1,ICHARG)=NPAMIN
C
                END IF
C
C===================================================================
C          INTRINSIC SPIN ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C===================================================================
C
                IF (EISPAL(NPAMIN,1,ICHARG).GE.
     *              EPSPAL(       1,ICHARG).AND.
     *              K_OCCU(NPAMIN,1,ICHARG).EQ.0) THEN
C
                    EPSPAL(       1,ICHARG)=
     *              EISPAL(NPAMIN,1,ICHARG)
C
                    JPSPAL(       1,ICHARG)=NPAMIN
C
                END IF
C
C===================================================================
C           INTRINSIC SPIN ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
                IF (EISPAL(NPAMIN,1,ICHARG).GE.
     *              EHSPAL(       1,ICHARG).AND.
     *              K_OCCU(NPAMIN,1,ICHARG).EQ.1) THEN
C
                    EHSPAL(       1,ICHARG)=
     *              EISPAL(NPAMIN,1,ICHARG)
C
                    JHSPAL(       1,ICHARG)=NPAMIN
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         PRINTING THE MAXIMUM ALIGNMENTS
C=======================================================================
C
      WRITE(NFIPRI,'(
     *          1H*,1X,'' TABLE BELOW GIVES THE MAXIMUM ABSOLUT'',
     *                 ''E VALUES OF DIFFERENCES OF ALIGNMENT  '',1H*,/,
     *          1H*,1X,'' BETWEEN THE LAST TWO ITERATIONS. IT M'',
     *                 ''AY SERVE AS A GUIDE TO SELECT STATES  '',1H*,/,
     *          1H*,1X,'' WHICH EXCHANGE WAVE FUNCTIONS IN EVER'',
     *                 ''Y SECOND ITERATION.  SUCH STATES MAY  '',1H*,/,
     *          1H*,1X,'' BE CANDIDATES FOR A CALCULATION WITH '',
     *                 ''DIABATICALLY BLOCKED  CONFIGURATIONS  '',1H*,/,
     *          1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,18X,1H*,58X,1H*,/,
     *         1H*,1X,''     BLOCKS      * ANGULAR MOMENTUM AL'',
     *                ''IGNMENT    INTRINSIC SPIN  ALIGNMENT  '',1H*,/,
     *         1H*,1X,''     ------      * -------------------'',
     *                ''-------    -------------------------  '',1H*,/,
     *         1H*,1X,''                 *   PARTICLES       H'',
     *                ''OLES        PARTICLES       HOLES     '',1H*,/,
     *         1H*,1X,'' ISOSPIN  PARITY *  INDEX VALUE   INDE'',
     *                ''X VALUE    INDEX VALUE   INDEX VALUE  '',1H*,/,
     *         1H*,18X,1H*,58X,1H*,/,79(1H*),/,
     *         1H*,18X,1H*,58X,1H*,
     *     4(/,1H*,1X,A7,4X,''('',A1,'')'',3X,
     *         1H*,2(2(I5,F8.3,1X),1X),1H*))')
     *
     *        ((PARNAM(ICHARG),PLUMIN(IPARIT),
     *
     *          JPALIG(IPARIT,ICHARG),
     *          EPALIG(IPARIT,ICHARG),
     *          JHALIG(IPARIT,ICHARG),
     *          EHALIG(IPARIT,ICHARG),
     *          JPSPAL(IPARIT,ICHARG),
     *          EPSPAL(IPARIT,ICHARG),
     *          JHSPAL(IPARIT,ICHARG),
     *          EHSPAL(IPARIT,ICHARG),IPARIT=0,NDPARI),
     *                                ICHARG=0,NDISOS)
C
      WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
C=======================================================================
C        DETERMINING CANDIDATES FOR DIABATIC BLOCKING IN ANY OF THE
C        CHARGE-PARITY  BLOCKS.   A  PAIR  OF  STATES IS CONSIDERED
C        TO BE A GOOD CANDIDATE FOR  DIABATIC  BLOCKING  IF  IT  IS
C        COMPOSED OF A PARTICLE AND A HOLE WITH ADJACENT INDICES.
C=======================================================================
C
      NUMCAN=0
C
      DO IPARIT=0,NDPARI
         DO ICHARG=0,NDISOS
C
            IF (ABS(JPALIG(IPARIT,ICHARG)-
     *              JHALIG(IPARIT,ICHARG)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        ANGULAR MOMENTUM ALIGNMENT IS FOUND
C=======================================================================
C
                NUMCAN=NUMCAN+1
C
                IF (NUMCAN.EQ.1) THEN
C
                   WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *             1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                    ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *             1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,
     *             1H*,18X,1H*,58X,1H*)')
C
                END IF
C
                WRITE(NFIPRI,'(1H*,1X,A7,4X,A1,''1'',4X,
     *                         1H*,2(I5,F8.3,1X),1X,29X,1H*)')
     *
     *                PARNAM(ICHARG),PLUMIN(IPARIT),
     *
     *                JPALIG(IPARIT,ICHARG),
     *                EPALIG(IPARIT,ICHARG),
     *                JHALIG(IPARIT,ICHARG),
     *                EHALIG(IPARIT,ICHARG)
C
            END IF
C
            IF (ABS(JPSPAL(IPARIT,ICHARG)-
     *              JHSPAL(IPARIT,ICHARG)).EQ.1) THEN
C
C=======================================================================
C           A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C           INTRINSIC SPIN ALIGNMENT IS FOUND
C=======================================================================
C
                NUMCAN=NUMCAN+1
C
                IF (NUMCAN.EQ.1) THEN
C
                   WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *             1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                    ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *             1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,
     *             1H*,18X,1H*,58X,1H*)')
C
                END IF
C
                WRITE(NFIPRI,'(1H*,1X,A7,4X,A1,''1'',4X,
     *                         1H*,29X,2(I5,F8.3,1X),1X,1H*)')
     *
     *                PARNAM(ICHARG),PLUMIN(IPARIT),
     *
     *                JPSPAL(IPARIT,ICHARG),
     *                EPSPAL(IPARIT,ICHARG),
     *                JHSPAL(IPARIT,ICHARG),
     *                EHSPAL(IPARIT,ICHARG)
C
            END IF
C
         END DO
      END DO
C
      IF (NUMCAN.EQ.0) THEN
C
C=======================================================================
C        NO CANDIDATE PAIRS OF STATES FOR DIABATIC BLOCKING WERE FOUND
C=======================================================================
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,1X,''   NO GOOD CANDIDATE CONFIGURATIONS FO'',
     *                ''R THE DIABATIC BLOCKING WERE FOUND    '',1H*,/,
     *         1H*,77X,1H*,/,79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,'(1X)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FLISIZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PARNAM(0:NDISOS)*7
C
      DIMENSION
     *          EIALIG(1:2*NDSTAT,0:NDISOS),
     *          EISPAL(1:2*NDSTAT,0:NDISOS)
      DIMENSION
     *          EPALIG(0:NDISOS),
     *          EPSPAL(0:NDISOS),
     *          EHALIG(0:NDISOS),
     *          EHSPAL(0:NDISOS)
      DIMENSION
     *          JPALIG(0:NDISOS),
     *          JPSPAL(0:NDISOS),
     *          JHALIG(0:NDISOS),
     *          JHSPAL(0:NDISOS)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLOLD/ OLALIG(1:2*NDSTAT,0:NDISOS),
     *                OLSPAL(1:2*NDSTAT,0:NDISOS),
     *                OLPARI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZOCC/ M_OCCU(1:2*NDSTAT,0:NDISOS),
     *                M_OCVA(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       PARNAM /'NEUTRON','PROTON '/
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF NON-CONSERVED  SIMPLEX
C        AND FINDS THE SINGLE PARTICLE  STATES  WHICH  HAVE  ALTERNATING
C        PROPERTIES FROM ONE ITERATION TO ANOTHER.
C
C        ATTENTION: THIS SUBROUTINE MUST KNOW THE  SINGLE-PARTICLE
C                   PROPERTIES IN THE PREVIOUS ITERATION. THE USER
C                   IS RESPONSIBLE FOR NOT CALLING IT IN THE FIRST
C                   ITERATION.
C
C=======================================================================
C
C=======================================================================
C        DETERMINING ABSOLUTE VALUES OF DIFFERENCES OF ALIGNMENTS
C        BETWEEN THE PREVIOUS AND CURRENT ITERATIONS
C=======================================================================
C
      DO ICHARG=0,NDISOS
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            EIALIG(ISTATE,ICHARG)=
     *             ABS(OLALIG(ISTATE,ICHARG) - SPALIG(ISTATE,ICHARG))
C
            EISPAL(ISTATE,ICHARG)=
     *             ABS(OLSPAL(ISTATE,ICHARG) - SPSPAL(ISTATE,ICHARG))
C
         END DO
      END DO
C
C=======================================================================
C         INITIALIZING ARRAYS OF MAXIMUM DIFFERENCES
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         EPALIG(ICHARG)=-1.0
         EPSPAL(ICHARG)=-1.0
         EHALIG(ICHARG)=-1.0
         EHSPAL(ICHARG)=-1.0
C
         JPALIG(ICHARG)=-1
         JPSPAL(ICHARG)=-1
         JHALIG(ICHARG)=-1
         JHSPAL(ICHARG)=-1
C
      END DO
C
C=======================================================================
C        DETERMINING MAXIMUM DIFFERENCES OF ALIGNMENTS IN THE
C        CHARGE BLOCKS
C=======================================================================
C
      DO ICHARG=0,NDISOS
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
            IF (EIALIG(ISTATE,ICHARG).GE.
     *          EPALIG(       ICHARG).AND.
     *          M_OCCU(ISTATE,ICHARG).EQ.0) THEN
C
                EPALIG(       ICHARG)=
     *          EIALIG(ISTATE,ICHARG)
C
                JPALIG(       ICHARG)=ISTATE
C
            END IF
C
C===================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
            IF (EIALIG(ISTATE,ICHARG).GE.
     *          EHALIG(       ICHARG).AND.
     *          M_OCCU(ISTATE,ICHARG).EQ.1) THEN
C
                EHALIG(       ICHARG)=
     *          EIALIG(ISTATE,ICHARG)
C
                JHALIG(       ICHARG)=ISTATE
C
            END IF
C
C===================================================================
C          INTRINSIC SPIN ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C===================================================================
C
            IF (EISPAL(ISTATE,ICHARG).GE.
     *          EPSPAL(       ICHARG).AND.
     *          M_OCCU(ISTATE,ICHARG).EQ.0) THEN
C
                EPSPAL(       ICHARG)=
     *          EISPAL(ISTATE,ICHARG)
C
                JPSPAL(       ICHARG)=ISTATE
C
            END IF
C
C===================================================================
C           INTRINSIC SPIN ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
            IF (EISPAL(ISTATE,ICHARG).GE.
     *          EHSPAL(       ICHARG).AND.
     *          M_OCCU(ISTATE,ICHARG).EQ.1) THEN
C
                EHSPAL(       ICHARG)=
     *          EISPAL(ISTATE,ICHARG)
C
                JHSPAL(       ICHARG)=ISTATE
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         PRINTING THE MAXIMUM ALIGNMENTS
C=======================================================================
C
      WRITE(NFIPRI,'(
     *          1H*,1X,'' TABLE BELOW GIVES THE MAXIMUM ABSOLUT'',
     *                 ''E VALUES OF DIFFERENCES OF ALIGNMENT  '',1H*,/,
     *          1H*,1X,'' BETWEEN THE LAST TWO ITERATIONS. IT M'',
     *                 ''AY SERVE AS A GUIDE TO SELECT STATES  '',1H*,/,
     *          1H*,1X,'' WHICH EXCHANGE WAVE FUNCTIONS IN EVER'',
     *                 ''Y SECOND ITERATION.  SUCH STATES MAY  '',1H*,/,
     *          1H*,1X,'' BE CANDIDATES FOR A CALCULATION WITH '',
     *                 ''DIABATICALLY BLOCKED  CONFIGURATIONS  '',1H*,/,
     *          1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,18X,1H*,58X,1H*,/,
     *         1H*,1X,''     BLOCKS      * ANGULAR MOMENTUM AL'',
     *                ''IGNMENT    INTRINSIC SPIN  ALIGNMENT  '',1H*,/,
     *         1H*,1X,''     ------      * -------------------'',
     *                ''-------    -------------------------  '',1H*,/,
     *         1H*,1X,''                 *   PARTICLES       H'',
     *                ''OLES        PARTICLES       HOLES     '',1H*,/,
     *         1H*,1X,'' ISOSPIN SIMPLEX *  INDEX VALUE   INDE'',
     *                ''X VALUE    INDEX VALUE   INDEX VALUE  '',1H*,/,
     *         1H*,18X,1H*,58X,1H*,/,79(1H*),/,
     *         1H*,18X,1H*,58X,1H*,
     *     2(/,1H*,1X,A7,6X,4X,
     *         1H*,2(2(I5,F8.3,1X),1X),1H*))')
     *
     *         (PARNAM(ICHARG),
     *
     *          JPALIG(ICHARG),
     *          EPALIG(ICHARG),
     *          JHALIG(ICHARG),
     *          EHALIG(ICHARG),
     *          JPSPAL(ICHARG),
     *          EPSPAL(ICHARG),
     *          JHSPAL(ICHARG),
     *          EHSPAL(ICHARG),ICHARG=0,NDISOS)
C
      WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
C=======================================================================
C        DETERMINING CANDIDATES FOR DIABATIC BLOCKING IN ANY OF THE
C        CHARGE-SIMPLEX BLOCKS.   A  PAIR  OF  STATES IS CONSIDERED
C        TO BE A GOOD CANDIDATE FOR  DIABATIC  BLOCKING  IF  IT  IS
C        COMPOSED OF A PARTICLE AND A HOLE WITH ADJACENT INDICES.
C=======================================================================
C
      NUMCAN=0
C
      DO ICHARG=0,NDISOS
C
         IF (ABS(JPALIG(ICHARG)-
     *           JHALIG(ICHARG)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        ANGULAR MOMENTUM ALIGNMENT IS FOUND
C=======================================================================
C
             NUMCAN=NUMCAN+1
C
             IF (NUMCAN.EQ.1) THEN
C
                WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                 ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *          1H*,/,
     *          1H*,77X,1H*,/,79(1H*),/,
     *          1H*,18X,1H*,58X,1H*)')
C
             END IF
C
             WRITE(NFIPRI,'(1H*,1X,A7,6X,4X,
     *                      1H*,2(I5,F8.3,1X),1X,29X,1H*)')
     *
     *             PARNAM(ICHARG),
     *
     *             JPALIG(ICHARG),
     *             EPALIG(ICHARG),
     *             JHALIG(ICHARG),
     *             EHALIG(ICHARG)
C
         END IF
C
         IF (ABS(JPSPAL(ICHARG)-
     *           JHSPAL(ICHARG)).EQ.1) THEN
C
C=======================================================================
C           A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C           INTRINSIC SPIN ALIGNMENT IS FOUND
C=======================================================================
C
             NUMCAN=NUMCAN+1
C
             IF (NUMCAN.EQ.1) THEN
C
                WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                 ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *          1H*,/,
     *          1H*,77X,1H*,/,79(1H*),/,
     *          1H*,18X,1H*,58X,1H*)')
C
             END IF
C
             WRITE(NFIPRI,'(1H*,1X,A7,6X,4X,
     *                      1H*,29X,2(I5,F8.3,1X),1X,1H*)')
     *
     *             PARNAM(ICHARG),
     *
     *             JPSPAL(ICHARG),
     *             EPSPAL(ICHARG),
     *             JHSPAL(ICHARG),
     *             EHSPAL(ICHARG)
C
         END IF
C
      END DO
C
      IF (NUMCAN.EQ.0) THEN
C
C=======================================================================
C        NO CANDIDATE PAIRS OF STATES FOR DIABATIC BLOCKING WERE FOUND
C=======================================================================
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,1X,''   NO GOOD CANDIDATE CONFIGURATIONS FO'',
     *                ''R THE DIABATIC BLOCKING WERE FOUND    '',1H*,/,
     *         1H*,77X,1H*,/,79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,'(1X)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FLIMIG(MREVER)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PLUMIN(0:1)*1
C
      DIMENSION
     *          DIALIG(1:NDSTAT,0:NDPARI,0:NDREVE),
     *          DISPAL(1:NDSTAT,0:NDPARI,0:NDREVE)
      DIMENSION
     *          DPALIG(0:NDPARI,0:NDREVE),
     *          DPSPAL(0:NDPARI,0:NDREVE),
     *          DHALIG(0:NDPARI,0:NDREVE),
     *          DHSPAL(0:NDPARI,0:NDREVE)
      DIMENSION
     *          IPALIG(0:NDPARI,0:NDREVE),
     *          IPSPAL(0:NDPARI,0:NDREVE),
     *          IHALIG(0:NDPARI,0:NDREVE),
     *          IHSPAL(0:NDPARI,0:NDREVE)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
C
      COMMON
     *       /PNLOLD/ ONALIG(1:4*NDSTAT),
     *                ONSPAL(1:4*NDSTAT),
     *                ONPARI(1:4*NDSTAT)
      COMMON
     *       /MIGOCC/ NMOCCU(1:2*NDSTAT,0:NDPARI,0:NDREVE),
     *                NMOCVA(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       PLUMIN /'+'   ,'-'   /
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF THE SIGNATURE SYMMETRY
C        AND PROTON-NEUTRON MIXING INCLUDED.
C        IT FINDS THE SINGLE PARTICLE  STATES  WHICH  HAVE  ALTERNATING
C        PROPERTIES FROM ONE ITERATION TO ANOTHER.
C
C        ATTENTION: THIS SUBROUTINE MUST KNOW THE  SINGLE-PARTICLE
C                   PROPERTIES IN THE PREVIOUS ITERATION. THE USER
C                   IS RESPONSIBLE FOR NOT CALLING IT IN THE FIRST
C                   ITERATION.
C
C=======================================================================
C
C=======================================================================
C        RETRIEVING VALUES OF ALIGNMENTS OBTAINED IN THE PREVIOUS
C        ITERATION
C=======================================================================
C
      DO IREVER=0,MREVER
C
         NPAPLU=0
         NPAMIN=0
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF (ONPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))).GT.0.0)
     *                                                           THEN
C
                NPAPLU=NPAPLU+1
C
                DIALIG(NPAPLU,0,IREVER)=
     *            ONALIG(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                DISPAL(NPAPLU,0,IREVER)=
     *            ONSPAL(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
            ELSE
C
                NPAMIN=NPAMIN+1
C
                DIALIG(NPAMIN,1,IREVER)=
     *            ONALIG(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                DISPAL(NPAMIN,1,IREVER)=
     *            ONSPAL(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
            END IF
C
         END DO
C
      END DO
C
C=======================================================================
C        DETERMINING ABSOLUTE VALUES OF DIFFERENCES OF ALIGNMENTS
C        BETWEEN THE PREVIOUS AND CURRENT ITERATIONS
C=======================================================================
C
      DO IREVER=0,MREVER
C
         NPAPLU=0
         NPAMIN=0
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF (PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))).GT.0.0)
     *                                                           THEN
C
                NPAPLU=NPAPLU+1
C
                DIALIG(NPAPLU,0,IREVER)=
     *             ABS(DIALIG(NPAPLU,0,IREVER)-
     *                 PNALIG(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))))
C
                DISPAL(NPAPLU,0,IREVER)=
     *      ABS(DISPAL(NPAPLU,0,IREVER)-
     *          PNSPAL(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))))
C
            ELSE
C
                NPAMIN=NPAMIN+1
C
                DIALIG(NPAMIN,1,IREVER)=
     *      ABS(DIALIG(NPAMIN,1,IREVER)-
     *          PNALIG(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))))
C
                DISPAL(NPAMIN,1,IREVER)=
     *      ABS(DISPAL(NPAMIN,1,IREVER)-
     *          PNSPAL(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))))
C
            END IF
C
         END DO
C
      END DO
C
C=======================================================================
C         INITIALIZING ARRAYS OF MAXIMUM DIFFERENCES
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,MREVER
C
               DPALIG(IPARIT,IREVER)=-1.0
               DPSPAL(IPARIT,IREVER)=-1.0
               DHALIG(IPARIT,IREVER)=-1.0
               DHSPAL(IPARIT,IREVER)=-1.0
C
               IPALIG(IPARIT,IREVER)=-1
               IPSPAL(IPARIT,IREVER)=-1
               IHALIG(IPARIT,IREVER)=-1
               IHSPAL(IPARIT,IREVER)=-1
C
         END DO
      END DO
C
C=======================================================================
C        DETERMINING MAXIMUM DIFFERENCES OF ALIGNMENTS IN THE
C        CHARGE-PARITY-SIGNATURE BLOCKS
C=======================================================================
C
      DO IREVER=0,MREVER
C
         NPAPLU=0
         NPAMIN=0
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF (PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))).GT. 0.0)
     *                                                           THEN
C
                NPAPLU=NPAPLU+1
C
C=======================================================================
C              ANGULAR MOMENTUM ALIGNMENT IN THE POSITIVE-PARITY BLOCK
C              FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                IF (DIALIG(NPAPLU,0,IREVER).GE.
     *              DPALIG(       0,IREVER).AND.
     *              NMOCCU(NPAPLU,0,IREVER).EQ.0) THEN
C
                    DPALIG(       0,IREVER)=
     *              DIALIG(NPAPLU,0,IREVER)
C
                    IPALIG(       0,IREVER)=NPAPLU
C
                END IF
C
C=======================================================================
C              ANGULAR MOMENTUM ALIGNMENT IN THE POSITIVE-PARITY BLOCK
C              FOR HOLE (OCCUPIED) STATES
C=======================================================================
C
                IF (DIALIG(NPAPLU,0,IREVER).GE.
     *              DHALIG(       0,IREVER).AND.
     *              NMOCCU(NPAPLU,0,IREVER).EQ.1) THEN
C
                    DHALIG(       0,IREVER)=
     *              DIALIG(NPAPLU,0,IREVER)
C
                    IHALIG(       0,IREVER)=NPAPLU
C
                END IF
C
C=======================================================================
C              INTRINSIC SPIN ALIGNMENT IN THE POSITIVE-PARITY BLOCK
C              FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                IF (DISPAL(NPAPLU,0,IREVER).GE.
     *              DPSPAL(       0,IREVER).AND.
     *              NMOCCU(NPAPLU,0,IREVER).EQ.0) THEN
C
                    DPSPAL(       0,IREVER)=
     *              DISPAL(NPAPLU,0,IREVER)
C
                    IPSPAL(       0,IREVER)=NPAPLU
C
                END IF
C
C=======================================================================
C              INTRINSIC SPIN ALIGNMENT IN THE POSITIVE-PARITY BLOCK
C              FOR HOLE (OCCUPIED) STATES
C=======================================================================
C
                IF (DISPAL(NPAPLU,0,IREVER).GE.
     *              DHSPAL(       0,IREVER).AND.
     *              NMOCCU(NPAPLU,0,IREVER).EQ.1) THEN
C
                    DHSPAL(       0,IREVER)=
     *              DISPAL(NPAPLU,0,IREVER)
C
                    IHSPAL(       0,IREVER)=NPAPLU
C
                END IF
C
            ELSE
C
                NPAMIN=NPAMIN+1
C
C=======================================================================
C              ANGULAR MOMENTUM ALIGNMENT IN THE NEGATIVE-PARITY BLOCK
C              FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                IF (DIALIG(NPAMIN,1,IREVER).GE.
     *              DPALIG(       1,IREVER).AND.
     *              NMOCCU(NPAMIN,1,IREVER).EQ.0) THEN
C
                    DPALIG(       1,IREVER)=
     *              DIALIG(NPAMIN,1,IREVER)
C
                    IPALIG(       1,IREVER)=NPAMIN
C
                END IF
C
C=======================================================================
C              ANGULAR MOMENTUM ALIGNMENT IN THE NEGATIVE-PARITY BLOCK
C              FOR HOLE (OCCUPIED) STATES
C=======================================================================
C
                IF (DIALIG(NPAMIN,1,IREVER).GE.
     *              DHALIG(       1,IREVER).AND.
     *              NMOCCU(NPAMIN,1,IREVER).EQ.1) THEN
C
                    DHALIG(       1,IREVER)=
     *              DIALIG(NPAMIN,1,IREVER)
C
                    IHALIG(       1,IREVER)=NPAMIN
C
                END IF
C
C=======================================================================
C              INTRINSIC SPIN ALIGNMENT IN THE NEGATIVE-PARITY BLOCK
C              FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
                IF (DISPAL(NPAMIN,1,IREVER).GE.
     *              DPSPAL(       1,IREVER).AND.
     *              NMOCCU(NPAMIN,1,IREVER).EQ.0) THEN
C
                    DPSPAL(       1,IREVER)=
     *              DISPAL(NPAMIN,1,IREVER)
C
                    IPSPAL(       1,IREVER)=NPAMIN
C
                END IF
C
C=======================================================================
C              INTRINSIC SPIN ALIGNMENT IN THE NEGATIVE-PARITY BLOCK
C              FOR HOLE (OCCUPIED) STATES
C=======================================================================
C
                IF (DISPAL(NPAMIN,1,IREVER).GE.
     *              DHSPAL(       1,IREVER).AND.
     *              NMOCCU(NPAMIN,1,IREVER).EQ.1) THEN
C
                    DHSPAL(       1,IREVER)=
     *              DISPAL(NPAMIN,1,IREVER)
C
                    IHSPAL(       1,IREVER)=NPAMIN
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         PRINTING THE MAXIMUM ALIGNMENTS
C=======================================================================
C
      WRITE(NFIPRI,'(
     *          1H*,1X,'' TABLE BELOW GIVES THE MAXIMUM ABSOLUT'',
     *                 ''E VALUES OF DIFFERENCES OF ALIGNMENT  '',1H*,/,
     *          1H*,1X,'' BETWEEN THE LAST TWO ITERATIONS. IT M'',
     *                 ''AY SERVE AS A GUIDE TO SELECT STATES  '',1H*,/,
     *          1H*,1X,'' WHICH EXCHANGE WAVE FUNCTIONS IN EVER'',
     *                 ''Y SECOND ITERATION.  SUCH STATES MAY  '',1H*,/,
     *          1H*,1X,'' BE CANDIDATES FOR A CALCULATION WITH '',
     *                 ''DIABATICALLY BLOCKED  CONFIGURATIONS  '',1H*,/,
     *          1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,18X,1H*,58X,1H*,/,
     *         1H*,1X,''     BLOCKS      * ANGULAR MOMENTUM AL'',
     *                ''IGNMENT    INTRINSIC SPIN  ALIGNMENT  '',1H*,/,
     *         1H*,1X,''     ------      * -------------------'',
     *                ''-------    -------------------------  '',1H*,/,
     *         1H*,1X,''                 *   PARTICLES       H'',
     *                ''OLES        PARTICLES       HOLES     '',1H*,/,
     *         1H*,1X,''      PAR. SIG.  *  INDEX VALUE   INDE'',
     *                ''X VALUE    INDEX VALUE   INDEX VALUE  '',1H*,/,
     *         1H*,18X,1H*,58X,1H*,/,79(1H*),/,
     *         1H*,18X,1H*,58X,1H*,
     *     4(/,1H*,1X,4X,1X,2(2X,A1,2X),2X,
     *         1H*,2(2(I5,F8.3,1X),1X),1H*))')
     *
     *       ((PLUMIN(IPARIT),
     *          PLUMIN(IREVER*(1-IPARIT)+(1-IREVER)*IPARIT),
     *
     *          IPALIG(IPARIT,IREVER),
     *          DPALIG(IPARIT,IREVER),
     *          IHALIG(IPARIT,IREVER),
     *          DHALIG(IPARIT,IREVER),
     *          IPSPAL(IPARIT,IREVER),
     *          DPSPAL(IPARIT,IREVER),
     *          IHSPAL(IPARIT,IREVER),
     *          DHSPAL(IPARIT,IREVER),IREVER=0,MREVER),
     *                                       IPARIT=0,NDPARI)
C
      WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
C=======================================================================
C        DETERMINING CANDIDATES FOR DIABATIC  BLOCKING  IN  ANY  OF  THE
C        CHARGE-PARITY-SIGNATURE BLOCKS.  A PAIR OF STATES IS CONSIDERED
C        TO BE A GOOD CANDIDATE FOR DIABATIC BLOCKING IF IT IS  COMPOSED
C        OF A PARTICLE AND A HOLE WITH ADJACENT INDICES.
C=======================================================================
C
      NUMCAN=0
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,MREVER
C
            IF (ABS(IPALIG(IPARIT,IREVER)-
     *              IHALIG(IPARIT,IREVER)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        ANGULAR MOMENTUM ALIGNMENT IS FOUND
C=======================================================================
C
                NUMCAN=NUMCAN+1
C
                IF (NUMCAN.EQ.1) THEN
C
                   WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *             1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                    ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *             1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,
     *             1H*,18X,1H*,58X,1H*)')
C
                END IF
C
                WRITE(NFIPRI,'(1H*,1X,4X,1X,2(2X,A1,2X),2X,
     *                         1H*,2(I5,F8.3,1X),1X,29X,1H*)')
     *
     *                PLUMIN(IPARIT),
     *                PLUMIN(IREVER*(1-IPARIT)+(1-IREVER)*IPARIT),
     *
     *                IPALIG(IPARIT,IREVER),
     *                DPALIG(IPARIT,IREVER),
     *                IHALIG(IPARIT,IREVER),
     *                DHALIG(IPARIT,IREVER)
C
            END IF
C
            IF (ABS(IPSPAL(IPARIT,IREVER)-
     *              IHSPAL(IPARIT,IREVER)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        INTRINSIC SPIN ALIGNMENT IS FOUND
C=======================================================================
C
                NUMCAN=NUMCAN+1
C
                IF (NUMCAN.EQ.1) THEN
C
                   WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *             1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                    ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *             1H*,/,
     *             1H*,77X,1H*,/,79(1H*),/,
     *             1H*,18X,1H*,58X,1H*)')
C
                END IF
C
                WRITE(NFIPRI,'(1H*,1X,4X,1X,2(2X,A1,2X),2X,
     *                         1H*,29X,2(I5,F8.3,1X),1X,1H*)')
     *
     *                PLUMIN(IPARIT),
     *                PLUMIN(IREVER*(1-IPARIT)+(1-IREVER)*IPARIT),
     *
     *                IPSPAL(IPARIT,IREVER),
     *                DPSPAL(IPARIT,IREVER),
     *                IHSPAL(IPARIT,IREVER),
     *                DHSPAL(IPARIT,IREVER)
C
            END IF
C
         END DO
      END DO
C
      IF (NUMCAN.EQ.0) THEN
C
C=======================================================================
C        NO CANDIDATE PAIRS OF STATES FOR DIABATIC BLOCKING WERE FOUND
C=======================================================================
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,1X,''   NO GOOD CANDIDATE CONFIGURATIONS FO'',
     *                ''R THE DIABATIC BLOCKING WERE FOUND    '',1H*,/,
     *         1H*,77X,1H*,/,79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,'(1X)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FLIMIM(MREVER)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PLUMIN(0:1)*1
C
      DIMENSION
     *          EIALIG(1:NDSTAT,0:NDREVE),
     *          EISPAL(1:NDSTAT,0:NDREVE)
      DIMENSION
     *          EPALIG(0:NDREVE),
     *          EPSPAL(0:NDREVE),
     *          EHALIG(0:NDREVE),
     *          EHSPAL(0:NDREVE)
      DIMENSION
     *          JPALIG(0:NDREVE),
     *          JPSPAL(0:NDREVE),
     *          JHALIG(0:NDREVE),
     *          JHSPAL(0:NDREVE)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNLOLD/ ONALIG(1:4*NDSTAT),
     *                ONSPAL(1:4*NDSTAT),
     *                ONPARI(1:4*NDSTAT)
      COMMON
     *       /MIMOCC/ LMOCCU(1:2*NDSTAT,0:NDREVE),
     *                LMOCVA(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       PLUMIN /'+'      ,'-'      /
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF THE  SIMPLEX  SYMMETRY
C        AND PROTON-NEUTRON MIXING INCLUDED.
C        IT FINDS THE SINGLE PARTICLE  STATES  WHICH  HAVE  ALTERNATING
C        PROPERTIES FROM ONE ITERATION TO ANOTHER.
C
C        ATTENTION: THIS SUBROUTINE MUST KNOW THE  SINGLE-PARTICLE
C                   PROPERTIES IN THE PREVIOUS ITERATION. THE USER
C                   IS RESPONSIBLE FOR NOT CALLING IT IN THE FIRST
C                   ITERATION.
C
C=======================================================================
C
C=======================================================================
C        DETERMINING ABSOLUTE VALUES OF DIFFERENCES OF ALIGNMENTS
C        BETWEEN THE PREVIOUS AND CURRENT ITERATIONS
C=======================================================================
C
      DO IREVER=0,MREVER
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
               EIALIG(ISTATE,IREVER)=
     *               ABS(ONALIG(ISTATE+IREVER*NUMBSP(0,0)+NUMBSP(0,1))
     *                 - PNALIG(ISTATE+IREVER*NUMBSP(0,0)+NUMBSP(0,1)))
C
               EISPAL(ISTATE,IREVER)=
     *                ABS(ONSPAL(ISTATE+IREVER*NUMBSP(0,0)+NUMBSP(0,1))
     *                  - PNSPAL(ISTATE+IREVER*NUMBSP(0,0)+NUMBSP(0,1)))
C
         END DO
      END DO
C
C=======================================================================
C         INITIALIZONG ARRAYS OF MAXIMUM DIFFERENCES
C=======================================================================
C
      DO IREVER=0,MREVER
C
            EPALIG(IREVER)=-1.0
            EPSPAL(IREVER)=-1.0
            EHALIG(IREVER)=-1.0
            EHSPAL(IREVER)=-1.0
C
            JPALIG(IREVER)=-1
            JPSPAL(IREVER)=-1
            JHALIG(IREVER)=-1
            JHSPAL(IREVER)=-1
C
      END DO
C
C=======================================================================
C        DETERMINING MAXIMUM DIFFERENCES OF ALIGNMENTS IN THE
C        CHARGE-SIMPLEX BLOCKS
C=======================================================================
C
      DO IREVER=0,MREVER
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
C=======================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
            IF (EIALIG(ISTATE,IREVER).GE.
     *          EPALIG(       IREVER).AND.
     *          LMOCCU(ISTATE,IREVER).EQ.0) THEN
C
                EPALIG(       IREVER)=
     *          EIALIG(ISTATE,IREVER)
C
                JPALIG(       IREVER)=ISTATE
C
            END IF
C
C===================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
            IF (EIALIG(ISTATE,IREVER).GE.
     *          EHALIG(       IREVER).AND.
     *          LMOCCU(ISTATE,IREVER).EQ.1) THEN
C
                EHALIG(       IREVER)=
     *          EIALIG(ISTATE,IREVER)
C
                JHALIG(       IREVER)=ISTATE
C
            END IF
C
C===================================================================
C          INTRINSIC SPIN ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C===================================================================
C
            IF (EISPAL(ISTATE,IREVER).GE.
     *          EPSPAL(       IREVER).AND.
     *          LMOCCU(ISTATE,IREVER).EQ.0) THEN
C
                EPSPAL(       IREVER)=
     *          EISPAL(ISTATE,IREVER)
C
                JPSPAL(       IREVER)=ISTATE
C
            END IF
C
C===================================================================
C           INTRINSIC SPIN ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
            IF (EISPAL(ISTATE,IREVER).GE.
     *          EHSPAL(       IREVER).AND.
     *          LMOCCU(ISTATE,IREVER).EQ.1) THEN
C
                EHSPAL(       IREVER)=
     *          EISPAL(ISTATE,IREVER)
C
                JHSPAL(       IREVER)=ISTATE
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         PRINTING THE MAXIMUM ALIGNMENTS
C=======================================================================
C
      WRITE(NFIPRI,'(
     *          1H*,1X,'' TABLE BELOW GIVES THE MAXIMUM ABSOLUT'',
     *                 ''E VALUES OF DIFFERENCES OF ALIGNMENT  '',1H*,/,
     *          1H*,1X,'' BETWEEN THE LAST TWO ITERATIONS. IT M'',
     *                 ''AY SERVE AS A GUIDE TO SELECT STATES  '',1H*,/,
     *          1H*,1X,'' WHICH EXCHANGE WAVE FUNCTIONS IN EVER'',
     *                 ''Y SECOND ITERATION.  SUCH STATES MAY  '',1H*,/,
     *          1H*,1X,'' BE CANDIDATES FOR A CALCULATION WITH '',
     *                 ''DIABATICALLY BLOCKED  CONFIGURATIONS  '',1H*,/,
     *          1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,18X,1H*,58X,1H*,/,
     *         1H*,1X,''     BLOCKS      * ANGULAR MOMENTUM AL'',
     *                ''IGNMENT    INTRINSIC SPIN  ALIGNMENT  '',1H*,/,
     *         1H*,1X,''     ------      * -------------------'',
     *                ''-------    -------------------------  '',1H*,/,
     *         1H*,1X,''                 *   PARTICLES       H'',
     *                ''OLES        PARTICLES       HOLES     '',1H*,/,
     *         1H*,1X,''         SIMPLEX *  INDEX VALUE   INDE'',
     *                ''X VALUE    INDEX VALUE   INDEX VALUE  '',1H*,/,
     *         1H*,18X,1H*,58X,1H*,/,79(1H*),/,
     *         1H*,18X,1H*,58X,1H*,
     *     2(/,1H*,1X,7X,4X,A1,''i'',4X,
     *         1H*,2(2(I5,F8.3,1X),1X),1H*))')
     *
     *        ( PLUMIN(IREVER),
     *
     *          JPALIG(IREVER),
     *          EPALIG(IREVER),
     *          JHALIG(IREVER),
     *          EHALIG(IREVER),
     *          JPSPAL(IREVER),
     *          EPSPAL(IREVER),
     *          JHSPAL(IREVER),
     *          EHSPAL(IREVER),IREVER=0,MREVER)
C
      WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
C=======================================================================
C        DETERMINING CANDIDATES FOR DIABATIC BLOCKING IN ANY OF THE
C        CHARGE-SIMPLEX BLOCKS.   A  PAIR  OF  STATES IS CONSIDERED
C        TO BE A GOOD CANDIDATE FOR  DIABATIC  BLOCKING  IF  IT  IS
C        COMPOSED OF A PARTICLE AND A HOLE WITH ADJACENT INDICES.
C=======================================================================
C
      NUMCAN=0
C
      DO IREVER=0,MREVER
C
         IF (ABS(JPALIG(IREVER)-
     *           JHALIG(IREVER)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        ANGULAR MOMENTUM ALIGNMENT IS FOUND
C=======================================================================
C
             NUMCAN=NUMCAN+1
C
             IF (NUMCAN.EQ.1) THEN
C
                WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                 ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *          1H*,/,
     *          1H*,77X,1H*,/,79(1H*),/,
     *          1H*,18X,1H*,58X,1H*)')
C
             END IF
C
             WRITE(NFIPRI,'(1H*,1X,7X,4X,A1,''i'',4X,
     *                      1H*,2(I5,F8.3,1X),1X,29X,1H*)')
     *
     *             PLUMIN(IREVER),
     *
     *             JPALIG(IREVER),
     *             EPALIG(IREVER),
     *             JHALIG(IREVER),
     *             EHALIG(IREVER)
C
         END IF
C
         IF (ABS(JPSPAL(IREVER)-
     *           JHSPAL(IREVER)).EQ.1) THEN
C
C=======================================================================
C           A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C           INTRINSIC SPIN ALIGNMENT IS FOUND
C=======================================================================
C
             NUMCAN=NUMCAN+1
C
             IF (NUMCAN.EQ.1) THEN
C
                WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                 ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *          1H*,/,
     *          1H*,77X,1H*,/,79(1H*),/,
     *          1H*,18X,1H*,58X,1H*)')
C
             END IF
C
             WRITE(NFIPRI,'(1H*,1X,7X,4X,A1,''i'',4X,
     *                      1H*,29X,2(I5,F8.3,1X),1X,1H*)')
     *
     *             PLUMIN(IREVER),
     *
     *             JPSPAL(IREVER),
     *             EPSPAL(IREVER),
     *             JHSPAL(IREVER),
     *             EHSPAL(IREVER)
C
         END IF
C
      END DO
C
      IF (NUMCAN.EQ.0) THEN
C
C=======================================================================
C        NO CANDIDATE PAIRS OF STATES FOR DIABATIC BLOCKING WERE FOUND
C=======================================================================
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,1X,''   NO GOOD CANDIDATE CONFIGURATIONS FO'',
     *                ''R THE DIABATIC BLOCKING WERE FOUND    '',1H*,/,
     *         1H*,77X,1H*,/,79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,'(1X)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FLIMIQ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          PLUMIN(0:1)*1
C
      DIMENSION
     *          EIALIG(1:4*NDSTAT,0:NDPARI),
     *          EISPAL(1:4*NDSTAT,0:NDPARI)
      DIMENSION
     *          EPALIG(0:NDPARI),
     *          EPSPAL(0:NDPARI),
     *          EHALIG(0:NDPARI),
     *          EHSPAL(0:NDPARI)
      DIMENSION
     *          JPALIG(0:NDPARI),
     *          JPSPAL(0:NDPARI),
     *          JHALIG(0:NDPARI),
     *          JHSPAL(0:NDPARI)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNLOLD/ ONALIG(1:4*NDSTAT),
     *                ONSPAL(1:4*NDSTAT),
     *                ONPARI(1:4*NDSTAT)
      COMMON
     *       /MIQOCC/ KMOCCU(1:4*NDSTAT,0:NDPARI),
     *                KMOCVA(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       PLUMIN /'+'      ,'-'      /
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF THE  PARITY   SYMMETRY
C        AND PROTON-NEUTRON MIXING INCLUDED.
C        IT FINDS THE SINGLE PARTICLE  STATES  WHICH  HAVE  ALTERNATING
C        PROPERTIES FROM ONE ITERATION TO ANOTHER.
C
C        ATTENTION: THIS SUBROUTINE MUST KNOW THE  SINGLE-PARTICLE
C                   PROPERTIES IN THE PREVIOUS ITERATION. THE USER
C                   IS RESPONSIBLE FOR NOT CALLING IT IN THE FIRST
C                   ITERATION.
C
C=======================================================================
C
C=======================================================================
C        DETERMINING ABSOLUTE VALUES OF DIFFERENCES OF ALIGNMENTS
C        BETWEEN THE PREVIOUS AND CURRENT ITERATIONS
C=======================================================================
C
C
      NPAPLU=0
      NPAMIN=0
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         IF (PNPARI(ISTATE).GT.0.0) THEN
C
             NPAPLU=NPAPLU+1
C
             EIALIG(NPAPLU,0)=
     *          ABS(ONALIG(ISTATE) - PNALIG(ISTATE))
C
             EISPAL(NPAPLU,0)=
     *          ABS(ONSPAL(ISTATE) - PNSPAL(ISTATE))
C
         ELSE
C
             NPAMIN=NPAMIN+1
C
             EIALIG(NPAMIN,1)=
     *          ABS(ONALIG(ISTATE) - PNALIG(ISTATE))
C
             EISPAL(NPAMIN,1)=
     *          ABS(ONSPAL(ISTATE) - PNSPAL(ISTATE))
C
         END IF
C
      END DO
C
C=======================================================================
C         INITIALIZING ARRAYS OF MAXIMUM DIFFERENCES
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
            EPALIG(IPARIT)=-1.0
            EPSPAL(IPARIT)=-1.0
            EHALIG(IPARIT)=-1.0
            EHSPAL(IPARIT)=-1.0
C
            JPALIG(IPARIT)=-1
            JPSPAL(IPARIT)=-1
            JHALIG(IPARIT)=-1
            JHSPAL(IPARIT)=-1
C
      END DO
C
C=======================================================================
C        DETERMINING MAXIMUM DIFFERENCES OF ALIGNMENTS IN THE
C        CHARGE-SIMPLEX BLOCKS
C=======================================================================
C
      NPAPLU=0
      NPAMIN=0
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         IF (PNPARI(ISTATE).GT.0.0) THEN
C
             NPAPLU=NPAPLU+1
C
C=======================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
             IF (EIALIG(NPAPLU,0).GE.
     *           EPALIG(       0).AND.
     *           KMOCCU(NPAPLU,0).EQ.0) THEN
C
                 EPALIG(       0)=
     *           EIALIG(NPAPLU,0)
C
                 JPALIG(       0)=NPAPLU
C
             END IF
C
C===================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
             IF (EIALIG(NPAPLU,0).GE.
     *           EHALIG(       0).AND.
     *           KMOCCU(NPAPLU,0).EQ.1) THEN
C
                 EHALIG(       0)=
     *           EIALIG(NPAPLU,0)
C
                 JHALIG(       0)=NPAPLU
C
             END IF
C
C===================================================================
C          INTRINSIC SPIN ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C===================================================================
C
             IF (EISPAL(NPAPLU,0).GE.
     *           EPSPAL(       0).AND.
     *           KMOCCU(NPAPLU,0).EQ.0) THEN
C
                 EPSPAL(       0)=
     *           EISPAL(NPAPLU,0)
C
                 JPSPAL(       0)=NPAPLU
C
             END IF
C
C===================================================================
C           INTRINSIC SPIN ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
             IF (EISPAL(NPAPLU,0).GE.
     *           EHSPAL(       0).AND.
     *           KMOCCU(NPAPLU,0).EQ.1) THEN
C
                 EHSPAL(       0)=
     *           EISPAL(NPAPLU,0)
C
                 JHSPAL(       0)=NPAPLU
C
             END IF
C
         ELSE
C
             NPAMIN=NPAMIN+1
C
C=======================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
             IF (EIALIG(NPAMIN,1).GE.
     *           EPALIG(       1).AND.
     *           KMOCCU(NPAMIN,1).EQ.0) THEN
C
                 EPALIG(       1)=
     *           EIALIG(NPAMIN,1)
C
                 JPALIG(       1)=NPAMIN
C
             END IF
C
C===================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
             IF (EIALIG(NPAMIN,1).GE.
     *           EHALIG(       1).AND.
     *           KMOCCU(NPAMIN,1).EQ.1) THEN
C
                 EHALIG(       1)=
     *           EIALIG(NPAMIN,1)
C
                 JHALIG(       1)=NPAMIN
C
             END IF
C
C===================================================================
C          INTRINSIC SPIN ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C===================================================================
C
             IF (EISPAL(NPAMIN,1).GE.
     *           EPSPAL(       1).AND.
     *           KMOCCU(NPAMIN,1).EQ.0) THEN
C
                 EPSPAL(       1)=
     *           EISPAL(NPAMIN,1)
C
                 JPSPAL(       1)=NPAMIN
C
             END IF
C
C===================================================================
C           INTRINSIC SPIN ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
             IF (EISPAL(NPAMIN,1).GE.
     *           EHSPAL(       1).AND.
     *           KMOCCU(NPAMIN,1).EQ.1) THEN
C
                 EHSPAL(       1)=
     *           EISPAL(NPAMIN,1)
C
                 JHSPAL(       1)=NPAMIN
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C         PRINTING THE MAXIMUM ALIGNMENTS
C=======================================================================
C
      WRITE(NFIPRI,'(
     *          1H*,1X,'' TABLE BELOW GIVES THE MAXIMUM ABSOLUT'',
     *                 ''E VALUES OF DIFFERENCES OF ALIGNMENT  '',1H*,/,
     *          1H*,1X,'' BETWEEN THE LAST TWO ITERATIONS. IT M'',
     *                 ''AY SERVE AS A GUIDE TO SELECT STATES  '',1H*,/,
     *          1H*,1X,'' WHICH EXCHANGE WAVE FUNCTIONS IN EVER'',
     *                 ''Y SECOND ITERATION.  SUCH STATES MAY  '',1H*,/,
     *          1H*,1X,'' BE CANDIDATES FOR A CALCULATION WITH '',
     *                 ''DIABATICALLY BLOCKED  CONFIGURATIONS  '',1H*,/,
     *          1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,18X,1H*,58X,1H*,/,
     *         1H*,1X,''     BLOCKS      * ANGULAR MOMENTUM AL'',
     *                ''IGNMENT    INTRINSIC SPIN  ALIGNMENT  '',1H*,/,
     *         1H*,1X,''     ------      * -------------------'',
     *                ''-------    -------------------------  '',1H*,/,
     *         1H*,1X,''                 *   PARTICLES       H'',
     *                ''OLES        PARTICLES       HOLES     '',1H*,/,
     *         1H*,1X,''          PARITY *  INDEX VALUE   INDE'',
     *                ''X VALUE    INDEX VALUE   INDEX VALUE  '',1H*,/,
     *         1H*,18X,1H*,58X,1H*,/,79(1H*),/,
     *         1H*,18X,1H*,58X,1H*,
     *     2(/,1H*,1X,7X,4X,''('',A1,'')'',3X,
     *         1H*,2(2(I5,F8.3,1X),1X),1H*))')
     *
     *        (PLUMIN(IPARIT),
     *
     *          JPALIG(IPARIT),
     *          EPALIG(IPARIT),
     *          JHALIG(IPARIT),
     *          EHALIG(IPARIT),
     *          JPSPAL(IPARIT),
     *          EPSPAL(IPARIT),
     *          JHSPAL(IPARIT),
     *          EHSPAL(IPARIT),IPARIT=0,NDPARI)
C
      WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
C=======================================================================
C        DETERMINING CANDIDATES FOR DIABATIC BLOCKING IN ANY OF THE
C        CHARGE-PARITY  BLOCKS.   A  PAIR  OF  STATES IS CONSIDERED
C        TO BE A GOOD CANDIDATE FOR  DIABATIC  BLOCKING  IF  IT  IS
C        COMPOSED OF A PARTICLE AND A HOLE WITH ADJACENT INDICES.
C=======================================================================
C
      NUMCAN=0
C
      DO IPARIT=0,NDPARI
C
         IF (ABS(JPALIG(IPARIT)-
     *           JHALIG(IPARIT)).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        ANGULAR MOMENTUM ALIGNMENT IS FOUND
C=======================================================================
C
             NUMCAN=NUMCAN+1
C
             IF (NUMCAN.EQ.1) THEN
C
                WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                 ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *          1H*,/,
     *          1H*,77X,1H*,/,79(1H*),/,
     *          1H*,18X,1H*,58X,1H*)')
C
             END IF
C
             WRITE(NFIPRI,'(1H*,1X,7X,4X,A1,''1'',4X,
     *                      1H*,2(I5,F8.3,1X),1X,29X,1H*)')
     *
     *             PLUMIN(IPARIT),
     *
     *             JPALIG(IPARIT),
     *             EPALIG(IPARIT),
     *             JHALIG(IPARIT),
     *             EHALIG(IPARIT)
C
         END IF
C
         IF (ABS(JPSPAL(IPARIT)-
     *           JHSPAL(IPARIT)).EQ.1) THEN
C
C=======================================================================
C           A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C           INTRINSIC SPIN ALIGNMENT IS FOUND
C=======================================================================
C
             NUMCAN=NUMCAN+1
C
             IF (NUMCAN.EQ.1) THEN
C
                WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                 ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *          1H*,/,
     *          1H*,77X,1H*,/,79(1H*),/,
     *          1H*,18X,1H*,58X,1H*)')
C
             END IF
C
             WRITE(NFIPRI,'(1H*,1X,7X,4X,A1,''1'',4X,
     *                      1H*,29X,2(I5,F8.3,1X),1X,1H*)')
     *
     *             PLUMIN(IPARIT),
     *
     *             JPSPAL(IPARIT),
     *             EPSPAL(IPARIT),
     *             JHSPAL(IPARIT),
     *             EHSPAL(IPARIT)
C
         END IF
C
      END DO
C
      IF (NUMCAN.EQ.0) THEN
C
C=======================================================================
C        NO CANDIDATE PAIRS OF STATES FOR DIABATIC BLOCKING WERE FOUND
C=======================================================================
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,1X,''   NO GOOD CANDIDATE CONFIGURATIONS FO'',
     *                ''R THE DIABATIC BLOCKING WERE FOUND    '',1H*,/,
     *         1H*,77X,1H*,/,79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,'(1X)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE FLIMIZ
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      DIMENSION
     *          EIALIG(1:4*NDSTAT),
     *          EISPAL(1:4*NDSTAT)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNLOLD/ ONALIG(1:4*NDSTAT),
     *                ONSPAL(1:4*NDSTAT),
     *                ONPARI(1:4*NDSTAT)
      COMMON
     *       /MIZOCC/ MMOCCU(1:4*NDSTAT),
     *                MMOCVA(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF NON-CONSERVED  SIMPLEX
C        AND PROTON-NEUTRON MIXING INCLUDED.
C        IT FINDS THE SINGLE PARTICLE  STATES  WHICH  HAVE  ALTERNATING
C        PROPERTIES FROM ONE ITERATION TO ANOTHER.
C
C        ATTENTION: THIS SUBROUTINE MUST KNOW THE  SINGLE-PARTICLE
C                   PROPERTIES IN THE PREVIOUS ITERATION. THE USER
C                   IS RESPONSIBLE FOR NOT CALLING IT IN THE FIRST
C                   ITERATION.
C
C=======================================================================
C
C=======================================================================
C        DETERMINING ABSOLUTE VALUES OF DIFFERENCES OF ALIGNMENTS
C        BETWEEN THE PREVIOUS AND CURRENT ITERATIONS
C=======================================================================
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         EIALIG(ISTATE)=
     *          ABS(ONALIG(ISTATE) - PNALIG(ISTATE))
C
         EISPAL(ISTATE)=
     *          ABS(ONSPAL(ISTATE) - PNSPAL(ISTATE))
C
      END DO
C
C=======================================================================
C         INITIALIZING ARRAYS OF MAXIMUM DIFFERENCES
C=======================================================================
C
      EPALIG=-1.0
      EPSPAL=-1.0
      EHALIG=-1.0
      EHSPAL=-1.0
C
      JPALIG=-1
      JPSPAL=-1
      JHALIG=-1
      JHSPAL=-1
C
C=======================================================================
C        DETERMINING MAXIMUM DIFFERENCES OF ALIGNMENTS IN THE
C        CHARGE BLOCKS
C=======================================================================
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
C=======================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C=======================================================================
C
         IF (EIALIG(ISTATE).GE.EPALIG .AND.
     *       MMOCCU(ISTATE).EQ.0) THEN
C
             EPALIG=EIALIG(ISTATE)
C
             JPALIG=       ISTATE
C
         END IF
C
C===================================================================
C           ANGULAR MOMENTUM ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
         IF (EIALIG(ISTATE).GE.EHALIG .AND.
     *       MMOCCU(ISTATE).EQ.1) THEN
C
             EHALIG=EIALIG(ISTATE)
C
             JHALIG       =ISTATE
C
         END IF
C
C===================================================================
C          INTRINSIC SPIN ALIGNMENT FOR PARTICLE (UNOCCUPIED) STATES
C===================================================================
C
         IF (EISPAL(ISTATE).GE.EPSPAL .AND.
     *       MMOCCU(ISTATE).EQ.0) THEN
C
             EPSPAL=EISPAL(ISTATE)
C
             JPSPAL=       ISTATE
C
         END IF
C
C===================================================================
C           INTRINSIC SPIN ALIGNMENT FOR HOLE (OCCUPIED) STATES
C===================================================================
C
         IF (EISPAL(ISTATE).GE.EHSPAL .AND.
     *       MMOCCU(ISTATE).EQ.1) THEN
C
             EHSPAL=EISPAL(ISTATE)
C
             JHSPAL=       ISTATE
C
         END IF
C
      END DO
C
C=======================================================================
C         PRINTING THE MAXIMUM ALIGNMENTS
C=======================================================================
C
      WRITE(NFIPRI,'(
     *          1H*,1X,'' TABLE BELOW GIVES THE MAXIMUM ABSOLUT'',
     *                 ''E VALUES OF DIFFERENCES OF ALIGNMENT  '',1H*,/,
     *          1H*,1X,'' BETWEEN THE LAST TWO ITERATIONS. IT M'',
     *                 ''AY SERVE AS A GUIDE TO SELECT STATES  '',1H*,/,
     *          1H*,1X,'' WHICH EXCHANGE WAVE FUNCTIONS IN EVER'',
     *                 ''Y SECOND ITERATION.  SUCH STATES MAY  '',1H*,/,
     *          1H*,1X,'' BE CANDIDATES FOR A CALCULATION WITH '',
     *                 ''DIABATICALLY BLOCKED  CONFIGURATIONS  '',1H*,/,
     *          1H*,77X,1H*)')
C
      WRITE(NFIPRI,'(79(1H*),/,1H*,18X,1H*,58X,1H*,/,
     *         1H*,1X,''     BLOCKS      * ANGULAR MOMENTUM AL'',
     *                ''IGNMENT    INTRINSIC SPIN  ALIGNMENT  '',1H*,/,
     *         1H*,1X,''     ------      * -------------------'',
     *                ''-------    -------------------------  '',1H*,/,
     *         1H*,1X,''                 *   PARTICLES       H'',
     *                ''OLES        PARTICLES       HOLES     '',1H*,/,
     *         1H*,1X,''         SIMPLEX *  INDEX VALUE   INDE'',
     *                ''X VALUE    INDEX VALUE   INDEX VALUE  '',1H*,/,
     *         1H*,18X,1H*,58X,1H*,/,79(1H*),/,
     *         1H*,18X,1H*,58X,1H*,
     *       /,1H*,1X,7X,6X,4X,
     *         1H*,2(2(I5,F8.3,1X),1X),1H*)')
     *
     *          JPALIG,
     *          EPALIG,
     *          JHALIG,
     *          EHALIG,
     *          JPSPAL,
     *          EPSPAL,
     *          JHSPAL,
     *          EHSPAL
C
      WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
C=======================================================================
C        DETERMINING CANDIDATES FOR DIABATIC BLOCKING IN ANY OF THE
C        CHARGE-SIMPLEX BLOCKS.   A  PAIR  OF  STATES IS CONSIDERED
C        TO BE A GOOD CANDIDATE FOR  DIABATIC  BLOCKING  IF  IT  IS
C        COMPOSED OF A PARTICLE AND A HOLE WITH ADJACENT INDICES.
C=======================================================================
C
      NUMCAN=0
C
         IF (ABS(JPALIG-JHALIG).EQ.1) THEN
C
C=======================================================================
C        A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C        ANGULAR MOMENTUM ALIGNMENT IS FOUND
C=======================================================================
C
             NUMCAN=NUMCAN+1
C
             IF (NUMCAN.EQ.1) THEN
C
                WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *          1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *                 ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *          1H*,/,
     *          1H*,77X,1H*,/,79(1H*),/,
     *          1H*,18X,1H*,58X,1H*)')
C
             END IF
C
             WRITE(NFIPRI,'(1H*,1X,7X,6X,4X,
     *                      1H*,2(I5,F8.3,1X),1X,29X,1H*)')
     *
     *             JPALIG,
     *             EPALIG,
     *             JHALIG,
     *             EHALIG
C
         END IF
C
         IF (ABS(JPSPAL-JHSPAL).EQ.1) THEN
C
C=======================================================================
C           A CANDIDATE PAIR OF STATES FOR DIABATIC BLOCKING BASED ON
C           INTRINSIC SPIN ALIGNMENT IS FOUND
C=======================================================================
C
          NUMCAN=NUMCAN+1
C
          IF (NUMCAN.EQ.1) THEN
C
             WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *       1H*,1X,''   FOLLOWS THE LIST OF CANDIDATE CONFI'',
     *              ''GURATIONS FOR THE DIABATIC BLOCKING   '',
     *       1H*,/,
     *       1H*,77X,1H*,/,79(1H*),/,
     *       1H*,18X,1H*,58X,1H*)')
C
          END IF
C
          WRITE(NFIPRI,'(1H*,1X,7X,6X,4X,
     *                   1H*,29X,2(I5,F8.3,1X),1X,1H*)')
     *
     *          JPSPAL,
     *          EPSPAL,
     *          JHSPAL,
     *          EHSPAL
C
      END IF
C
      IF (NUMCAN.EQ.0) THEN
C
C=======================================================================
C        NO CANDIDATE PAIRS OF STATES FOR DIABATIC BLOCKING WERE FOUND
C=======================================================================
C
          WRITE(NFIPRI,'(1H*,77X,1H*,/,
     *         1H*,1X,''   NO GOOD CANDIDATE CONFIGURATIONS FO'',
     *                ''R THE DIABATIC BLOCKING WERE FOUND    '',1H*,/,
     *         1H*,77X,1H*,/,79(1H*))')
C
      ELSE
C
          WRITE(NFIPRI,'(1H*,18X,1H*,58X,1H*,/,79(1H*))')
C
      END IF
C
      WRITE(NFIPRI,'(1X)')
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CONSIG(MREVER,ICHARG,NUMNUC,EFERMI,
     *                         ICHFLI,IPAFLI,IREFLI,
     *                         ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          EORDER(1:2*NDBASE),NORDER(1:2*NDBASE)
      DIMENSION
     *          OCCFIL(0:NDPARI,0:NDREVE)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPMOME/ SPMO20(1:2*NDSTAT,0:NDISOS),
     *                SPMO22(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIGOCC/ N_OCCU(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS),
     *                N_OCVA(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGACT/ N_OCAC(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGFIL/ VFISIG(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FILG/ NPFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFILG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIG/ NPFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFLIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGNOC/ NOCSIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /VACCNF/ IVACUM
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF CONSERVATION OF THE
C        SIGNATURE SYMMETRY AND SETS THE OCCUPATION FACTORS ACCORDING
C        TO CHOSEN SIGNATURE CONFIGURATIONS ( IN CASE OF NO PAIRING ).
C        IT ALSO CALCULATES THE LOWEST SIGNATURE CONFIGURATIONS FOR A
C        GIVEN SINGLE-PARTICLE SPECTRUM.
C
C=======================================================================
C
C=======================================================================
C         ZEROING OCCUPATION FACTORS AND THE VACUUM CONFIGURATION DATA
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         OCCFIL(0,IREVER)=0.0D0
         OCCFIL(1,IREVER)=0.0D0
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=0.0
C
            N_OCVA(ISTATE,0,IREVER,ICHARG)=0
            N_OCVA(ISTATE,1,IREVER,ICHARG)=0
C
         END DO
C
      END DO
C
C=======================================================================
C         SETTING THE OCCUPATION FACTORS ACCORDING TO THE CONFIGURATION
C=======================================================================
C
      DO IREVER=0,MREVER
C
         NPAPLU=0
         NPAMIN=0
C
         OCCFIL(0,IREVER)=0.0D0
         OCCFIL(1,IREVER)=0.0D0
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            IF (SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG).GT.0.0)
     *                                                              THEN
C
                NPAPLU=NPAPLU+1
C
                V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=
     *                 N_OCCU(NPAPLU,0,IREVER,ICHARG)
C
                IF (NOFILG(0,IREVER,ICHARG).GE.1) THEN
C
                    IF (NPAPLU.GE.NHFILG(0,IREVER,ICHARG).AND.
     *                  NPAPLU.LE.NPFILG(0,IREVER,ICHARG))
     *
     *                  V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=
     *                         VFISIG(NPAPLU,0,IREVER,ICHARG)
C
                END IF
C
                OCCFIL(0,IREVER)=OCCFIL(0,IREVER)
     *                        +V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))**2
C
            ELSE
C
                NPAMIN=NPAMIN+1
C
                V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=
     *                 N_OCCU(NPAMIN,1,IREVER,ICHARG)
C
                IF (NOFILG(1,IREVER,ICHARG).GE.1) THEN
C
                    IF (NPAMIN.GE.NHFILG(1,IREVER,ICHARG).AND.
     *                  NPAMIN.LE.NPFILG(1,IREVER,ICHARG))
     *
     *                  V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=
     *                         VFISIG(NPAMIN,1,IREVER,ICHARG)
C
                END IF
C
                OCCFIL(1,IREVER)=OCCFIL(1,IREVER)
     *                        +V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))**2
C
            END IF
C
         END DO
C
C=======================================================================
C         THE TEST BELOW ENSURES THAT THE NUMBER OF STATES KEPT AFTER
C         THE DIAGONALIZATION IS SUFFICIENT TO ACCOMODATE ALL  STATES
C         OCCUPIED IN EACH OF THE PARITY BLOCKS. THE TEST CAN ONLY BE
C         PERFORMED IN THIS PLACE, BECAUSE THE NUMBER OF STATES  KEPT
C         AFTER THE DIAGONALIZATION DEPENDS ON THE  ENERGY  SPECTRUM,
C         AND THE NUMBERS OF STATES KEPT IN EACH PARITY ARE NOT KNOWN
C         BEFORE THE SPECTRUM IS CALCULATED.
C=======================================================================
C         THE TEST BELOW CAN  BE  PERFORMED  ONLY  WHEN  THE  FILLING
C         APPROXIMATION HAS NOT BEEN REQUESTED
C=======================================================================
C
         IF (((NOFILG(0,0,ICHARG).LT.1 .AND.
     *        NOFILG(0,1,ICHARG).LT.1.OR.MREVER.EQ.0).AND.
     *      ABS(OCCFIL(0,IREVER)
     *         -NOCSIG(0,IREVER,ICHARG)).GT.1.0D-12.OR.
     *       (NOFILG(1,0,ICHARG).LT.1 .AND.
     *        NOFILG(1,1,ICHARG).LT.1.OR.MREVER.EQ.0).AND.
     *      ABS(OCCFIL(1,IREVER)
     *         -NOCSIG(1,IREVER,ICHARG)).GT.1.0D-12).AND.
     *          IVACUM.NE.1) THEN
C
             WRITE(NFIPRI,'(
     *            1X,20(1H/),''  MESSAGE FROM CONSIG FOR IC'',
     *                       ''HARG = '',I1,1H:, 1X,20(1H/),/
     *            1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                       ''EAN-FIELD'',      1X,20(1H/),/
     *            1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                       ''IZATION 1'',      1X,20(1H/),/
     *            1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                       ''IX IN THE'',      1X,20(1H/),/
     *            1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                       ''         '',      1X,20(1H/),/)')
     *            ICHARG
C
             STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIG)1'
C
         END IF
C
      END DO
C
C=======================================================================
C         THE TEST BELOW CAN BE PERFORMED IN CASE  WHEN  THE  FILLING
C         APPROXIMATION HAS BEEN REQUESTED
C=======================================================================
C
      IF ((((NOFILG(0,0,ICHARG).GE.1.OR.NOFILG(0,1,ICHARG).GE.1).AND.
     *                                              MREVER.EQ.1).AND.
     *   ABS(OCCFIL(0,0)+OCCFIL(0,1)
     *      -NOCSIG(0,0,ICHARG)-NOCSIG(0,1,ICHARG)).GT.1.0D-12.OR.
     *     ((NOFILG(1,0,ICHARG).GE.1.OR.NOFILG(1,1,ICHARG).GE.1).AND.
     *                                              MREVER.EQ.1).AND.
     *   ABS(OCCFIL(1,0)+OCCFIL(1,1)
     *      -NOCSIG(1,0,ICHARG)-NOCSIG(1,1,ICHARG)).GT.1.0D-12).AND.
     *          IVACUM.NE.1) THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONSIG FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/
     *         1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                    ''EAN-FIELD'',      1X,20(1H/),/
     *         1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                    ''IZATION 4'',      1X,20(1H/),/
     *         1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                    ''IX IN THE'',      1X,20(1H/),/
     *         1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                    ''         '',      1X,20(1H/),/)')
     *            ICHARG
C
          STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIG)4'
C
      END IF
C
      N_OCAC(:,:,:,ICHARG)=N_OCCU(:,:,:,ICHARG)
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (SINGLE-PAIR CASE)
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          DO IREVER=0,MREVER
C
             NPAPLU=0
             NPAMIN=0
C
             JSPFLI=0
             JSHFLI=0
C
             OBPFLI=0.0D0
             OBHFLI=0.0D0
C
             DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "IFLIPI" CONTROL VARIABLE.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
                IF (ABS(IFLIPI).EQ. 1)
     *              OBSFLI=SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(IFLIPI).EQ. 2)
     *              OBSFLI=SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(IFLIPI).EQ. 9)
     *              OBSFLI=SPMO20(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(IFLIPI).EQ.10)
     *              OBSFLI=SPMO22(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(IFLIPI).GT.10.OR.
     *             (ABS(IFLIPI).GE. 3.AND.ABS(IFLIPI).LE.8))
     *              STOP ' IFLIPI OUT OF RANGE IN CONSIG'
C
                IF (SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                                     .GT.0.0) THEN
C
                    NPAPLU=NPAPLU+1
C
C=======================================================================
C                   SELECTING INDICES IN THE POSITIVE PARITY BLOCK
C=======================================================================
C
                    IF (IPAFLI.EQ.0.AND.IREVER.EQ.IREFLI.AND.
     *                                  ICHARG.EQ.ICHFLI) THEN
C
                        IF (NPAPLU.EQ.ISPFLI) THEN
                            OBPFLI=OBSFLI
                            JSPFLI=ISTATE
                        END IF
C
                        IF (NPAPLU.EQ.ISHFLI) THEN
                            OBHFLI=OBSFLI
                            JSHFLI=ISTATE
                        END IF
C
                    END IF
C
                ELSE
C
                    NPAMIN=NPAMIN+1
C
C=======================================================================
C                   SELECTING INDICES IN THE NEGATIVE PARITY BLOCK
C=======================================================================
C
                    IF (IPAFLI.EQ.1.AND.IREVER.EQ.IREFLI.AND.
     *                                  ICHARG.EQ.ICHFLI) THEN
C
                        IF (NPAMIN.EQ.ISPFLI) THEN
                            OBPFLI=OBSFLI
                            JSPFLI=ISTATE
                        END IF
C
                        IF (NPAMIN.EQ.ISHFLI) THEN
                            OBHFLI=OBSFLI
                            JSHFLI=ISTATE
                        END IF
C
                    END IF
C
                END IF
C
             END DO
C
             IF (ICHARG.EQ.ICHFLI.AND.IREVER.EQ.IREFLI) THEN
C
C=======================================================================
C            PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
                 IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                     WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONSIG'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ICHFLI='',I3,''   IPAFLI='',I3,''   IREFLI='',I3,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ISPFLI='',I3,''   ISHFLI='',I3,''   IFLIPI='',I3,
     *                                          2X,20(1H/))')
     *               ICHFLI,IPAFLI,IREFLI,
     *               ISPFLI,ISHFLI,IFLIPI
C
                     WRITE(NFIPRI,'(
     *                    1X,20(1H/),''  MESSAGE FROM CONSIG FOR IC'',
     *                               ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                    1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                               ''EAN-FIELD'',      1X,20(1H/),/
     *                    1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                               ''IZATION 2'',      1X,20(1H/),/
     *                    1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                               ''IX IN THE'',      1X,20(1H/),/
     *                    1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                               ''         '',      1X,20(1H/),/)')
     *                    ICHARG
C
                     STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIG)2'
C
                 ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "IFLIPI" CONTROL VARIABLE ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE
C=======================================================================
C
                     IF ((IFLIPI.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *                   (IFLIPI.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                         V_OCCU(JSPFLI+IREVER*NUMBSP(0,ICHARG))=
     *                               N_OCCU(ISHFLI,IPAFLI,IREVER,ICHARG)
                         V_OCCU(JSHFLI+IREVER*NUMBSP(0,ICHARG))=
     *                               N_OCCU(ISPFLI,IPAFLI,IREVER,ICHARG)
C
                         N_OCAC(ISHFLI,IPAFLI,IREVER,ICHARG)=
     *                   N_OCCU(ISPFLI,IPAFLI,IREVER,ICHARG)
                         N_OCAC(ISPFLI,IPAFLI,IREVER,ICHARG)=
     *                   N_OCCU(ISHFLI,IPAFLI,IREVER,ICHARG)
C
                     END IF
C
                 END IF
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (ALL-BLOCKS CASE)
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,MREVER
C
            NPARTY=0
C
            JSPFLI=0
            JSHFLI=0
C
            OBPFLI=0.0D0
            OBHFLI=0.0D0
C
            DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "NOFLIG"  MATRIX ELEMENTS.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
               IF ((IPARIT.EQ.0.AND.
     *              SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                                      .GT.0.0).OR.
     *             (IPARIT.EQ.1.AND.
     *              SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                                    .LT.0.0)) THEN
C
                   NPARTY=NPARTY+1
C
C=======================================================================
C                  SELECTING INDICES IN THE GIVEN
C                  PARITY/SIGNATURE/CHARGE  BLOCK
C=======================================================================
C
                   IF (NOFLIG(IPARIT,IREVER,ICHARG).NE.0) THEN
C
                       IF (ABS(NOFLIG(IPARIT,IREVER,ICHARG)).EQ. 1)
     *                     OBSFLI=SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),
     *                                                          ICHARG)
C
                       IF (ABS(NOFLIG(IPARIT,IREVER,ICHARG)).EQ. 2)
     *                     OBSFLI=SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),
     *                                                          ICHARG)
C
                       IF (ABS(NOFLIG(IPARIT,IREVER,ICHARG)).EQ. 9)
     *                     OBSFLI=SPMO20(ISTATE+IREVER*NUMBSP(0,ICHARG),
     *                                                          ICHARG)
C
                       IF (ABS(NOFLIG(IPARIT,IREVER,ICHARG)).EQ.10)
     *                     OBSFLI=SPMO22(ISTATE+IREVER*NUMBSP(0,ICHARG),
     *                                                          ICHARG)
C
                       IF (ABS(NOFLIG(IPARIT,IREVER,ICHARG)).GT.10.OR.
     *                    (ABS(NOFLIG(IPARIT,IREVER,ICHARG)).GE. 3.AND.
     *                     ABS(NOFLIG(IPARIT,IREVER,ICHARG)).LE. 8))
     *                     STOP ' NOFLIG OUT OF RANGE IN CONSIG'
C
                       IF (NPARTY.EQ.NPFLIG(IPARIT,IREVER,ICHARG))
     *                 THEN
                           OBPFLI=OBSFLI
                           JSPFLI=ISTATE
                       END IF
C
                       IF (NPARTY.EQ.NHFLIG(IPARIT,IREVER,ICHARG))
     *                 THEN
                           OBHFLI=OBSFLI
                           JSHFLI=ISTATE
                       END IF
C
                   END IF
C
               END IF
C
            END DO
C
            IF (NOFLIG(IPARIT,IREVER,ICHARG).NE.0) THEN
C
C=======================================================================
C               PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
                IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                    WRITE(NFIPRI,'(/,1X,20(1H/),
     *           '' ERROR IN DIABATIC BLOCKING IN CONSIG'',
     *                                       2X,20(1H/),/,1X,20(1H/),
     *           '' ICHARG='',I3,''   IPARIT='',I3,''   IREVER='',I3,
     *                                       2X,20(1H/),/,1X,20(1H/),
     *           '' NPFLIG='',I3,''   NHFLIG='',I3,''   NOFLIG='',I3,
     *                                       2X,20(1H/))')
     *              ICHARG,IPARIT,IREVER,
     *              NPFLIG(IPARIT,IREVER,ICHARG),
     *              NHFLIG(IPARIT,IREVER,ICHARG),
     *              NOFLIG(IPARIT,IREVER,ICHARG)
C
                    WRITE(NFIPRI,'(
     *                   1X,20(1H/),''  MESSAGE FROM CONSIG FOR IC'',
     *                              ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                   1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                              ''EAN-FIELD'',      1X,20(1H/),/
     *                   1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                              ''IZATION 3'',      1X,20(1H/),/
     *                   1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                              ''IX IN THE'',      1X,20(1H/),/
     *                   1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                              ''         '',      1X,20(1H/),/)')
     *                   ICHARG
C
                    STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIG)3'
C
                ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "NOFLIG" MATRIX ELEMENTS  ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE, AND VICE VERSA.
C=======================================================================
C
                    IF ((NOFLIG(IPARIT,IREVER,ICHARG).GT.0.AND.
     *                   OBPFLI.GT.OBHFLI).OR.
     *                  (NOFLIG(IPARIT,IREVER,ICHARG).LT.0.AND.
     *                   OBPFLI.LT.OBHFLI)) THEN
C
                         V_OCCU(JSPFLI+IREVER*NUMBSP(0,ICHARG))=
     *                            N_OCCU(NHFLIG(IPARIT,IREVER,ICHARG),
     *                                          IPARIT,IREVER,ICHARG)
                         V_OCCU(JSHFLI+IREVER*NUMBSP(0,ICHARG))=
     *                            N_OCCU(NPFLIG(IPARIT,IREVER,ICHARG),
     *                                          IPARIT,IREVER,ICHARG)
C
              N_OCAC(NHFLIG(IPARIT,IREVER,ICHARG),IPAFLI,IREVER,ICHARG)=
     *        N_OCCU(NPFLIG(IPARIT,IREVER,ICHARG),IPAFLI,IREVER,ICHARG)
              N_OCAC(NPFLIG(IPARIT,IREVER,ICHARG),IPAFLI,IREVER,ICHARG)=
     *        N_OCCU(NHFLIG(IPARIT,IREVER,ICHARG),IPAFLI,IREVER,ICHARG)
C
                    END IF
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         DETERMINING THE ORDERED SINGLE-PARTICLE SPECTRUM AND THE FERMI
C         ENERGY
C=======================================================================
C
      IORDER=0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            IORDER=IORDER+1
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
         END DO
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
      NUMACT=NUMNUC
C
      IF (MREVER.EQ.0) THEN
C
          IF (MOD(NUMNUC,2).NE.0) STOP ' ODD NUMNUC IN CONSIG'
          NUMACT=NUMNUC/2
C
      END IF
C
      EFERMI=0.5D0*(EORDER(NUMACT+1)+EORDER(NUMACT))
C
C=======================================================================
C         CALCULATING THE NUMBERS OF OCCUPIED STATES IN EVERY
C         PARITY/TIME-REVERSAL BLOCK
C=======================================================================
C
      IPARTI=0
C
      DO IREVER=0,MREVER
C
         NPAPLU=0
         NPAMIN=0
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            IF (SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG).LT.EFERMI)
     *                                                              THEN
C
                IPARTI=IPARTI+1
C
                IF (SPPARI(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                                                     .GT.0.0) THEN
C
                    NPAPLU=NPAPLU+1
                    N_OCVA(NPAPLU,0,IREVER,ICHARG)=1
C
                ELSE
C
                    NPAMIN=NPAMIN+1
                    N_OCVA(NPAMIN,1,IREVER,ICHARG)=1
C
                END IF
C
            END IF
C
         END DO
C
      END DO
C
C      In case of vacuum configuration, all lowest states up to the
C      Fermi level are occupied, all other states empty
C
      IF (IVACUM.EQ.1) THEN
C
          DO IREVER=0,MREVER
C
              DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                 IF (SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
     *                  .LT.EFERMI) THEN
                     V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=1.0D0
                 ELSE
                     V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=0.0D0
                 END IF
C
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C        IN CASE OF DEGENERATE STATES AT THE FERMI  ENERGY  THE
C        CONFIGURATION DATA ARE SET TO 100 TO OBTAIN  ASTERISKS
C        ON THE OUTPUT. A BETTER TREATMENT OF SUCH A DEGENERACY
C        IS STILL TO BE FOUND.
C=======================================================================
C        ATTENTION:  IN THE PREVIOUS VERSIONS OF THE CODE, STARTING FROM
C                    VERSION 1.96G AND UP TO  VERSION  2.08H,  THE  LOOP
C                    BELOW WAS PERFORMED UP TO "NDBASE",  I.E.,  FURTHER
C                    THAN THE VALUE OF "NDSTAT", WHICH WAS THE  DECLARED
C                    DIMENSION OF ARRAY "N_OCVA".
C                    THIS BUG WAS CORRECTED IN VERSION 2.08I (10/02/04).
C=======================================================================
C
      IF (IPARTI.NE.NUMACT) THEN
C
          DO IREVER=0,MREVER
C
             DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                N_OCVA(ISTATE,0,IREVER,ICHARG)=100
                N_OCVA(ISTATE,1,IREVER,ICHARG)=100
C
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CONSIM(MREVER,ICHARG,NUMNUC,EFERMI,
     *                         ICHFLI,       IREFLI,
     *                         ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          EORDER(1:2*NDBASE),NORDER(1:2*NDBASE)
      DIMENSION
     *          NOCCUP(0:NDREVE)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPMOME/ SPMO20(1:2*NDSTAT,0:NDISOS),
     *                SPMO22(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIMOCC/ L_OCCU(1:NDSTAT,0:NDREVE,0:NDISOS),
     *                L_OCVA(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMACT/ L_OCAC(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMNVA/ NVASIM(0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIM/ NPFLIM(0:NDREVE,0:NDISOS),
     *                NHFLIM(0:NDREVE,0:NDISOS),
     *                NOFLIM(0:NDREVE,0:NDISOS)
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /VACCNF/ IVACUM
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C         THIS SUBROUTINE IS CALLED IN THE CASE OF CONSERVATION OF THE
C         SIMPLEX SYMMETRY AND SETS THE OCCUPATION  FACTORS  ACCORDING
C         TO THE CHOSEN SIMPLEX CONFIGURATIONS (IN CASE OF NO PAIRING).
C         IT ALSO CALCULATES THE LOWEST - SIMPLEX  CONFIGURATION FOR A
C         GIVEN SINGLE-PARTICLE SPECTRUM.
C
C=======================================================================
C
C=======================================================================
C         ZEROING OCCUPATION FACTORS AND THE VACUUM CONFIGURATION DATA
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=0.0
C
            L_OCVA(ISTATE,IREVER,ICHARG)=0
C
         END DO
C
      END DO
C
C=======================================================================
C         SETTING THE OCCUPATION FACTORS ACCORDING TO THE CONFIGURATION
C=======================================================================
C
      DO IREVER=0,MREVER
C
         NOCCUP(IREVER)=0
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            NOCCUP(IREVER)=NOCCUP(IREVER)+
     *               L_OCCU(ISTATE,IREVER,ICHARG)
C
            V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))=
     *               L_OCCU(ISTATE,IREVER,ICHARG)
C
         END DO
C
      END DO
C
C=======================================================================
C         THE TEST BELOW ENSURES THAT THE NUMBER OF STATES KEPT AFTER
C         THE DIAGONALIZATION IS SUFFICIENT TO ACCOMODATE ALL  STATES
C         OCCUPIED IN EACH OF THE SIMPLEX BLOCKS. THE TEST COULD HAVE
C         BEEN PERFORMED IN ANOTHER PLACE, HOWEVER, IT  IS  PERFORMED
C         HERE TO KEEP CONSISTENCY WITH OTHER SYMMETRIES.
C=======================================================================
C
      DO IREVER=0,MREVER
C
         IF (NOCCUP(IREVER).NE.NVASIM(IREVER,ICHARG).AND.
     *       IVACUM.NE.1) THEN
C
             WRITE(NFIPRI,'(
     *            1X,20(1H/),''  MESSAGE FROM CONSIM FOR IC'',
     *                       ''HARG = '',I1,1H:, 1X,20(1H/),/
     *            1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                       ''EAN-FIELD'',      1X,20(1H/),/
     *            1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                       ''IZATION 1'',      1X,20(1H/),/
     *            1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                       ''IX IN THE'',      1X,20(1H/),/
     *            1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                       ''         '',      1X,20(1H/),/)')
     *            ICHARG
C
             STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIM)1'
C
         END IF
C
      END DO
C
      L_OCAC(:,:,ICHARG)=L_OCCU(:,:,ICHARG)
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          DO IREVER=0,MREVER
C
             JSPFLI=0
             JSHFLI=0
C
             OBPFLI=0.0D0
             OBHFLI=0.0D0
C
             DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "IFLIPI" CONTROL VARIABLE.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
                IF (ABS(IFLIPI).EQ. 1)
     *              OBSFLI=SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(IFLIPI).EQ. 2)
     *              OBSFLI=SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(IFLIPI).EQ. 9)
     *              OBSFLI=SPMO20(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(IFLIPI).EQ.10)
     *              OBSFLI=SPMO22(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(IFLIPI).GT.10.OR.
     *             (ABS(IFLIPI).GE. 3.AND.ABS(IFLIPI).LE.8))
     *              STOP ' IFLIPI OUT OF RANGE IN CONSIM'
C
C=======================================================================
C               SELECTING INDICES
C=======================================================================
C
                IF (IREVER.EQ.IREFLI.AND.ICHARG.EQ.ICHFLI) THEN
C
                    IF (ISTATE.EQ.ISPFLI) THEN
                        OBPFLI=OBSFLI
                        JSPFLI=ISTATE
                    END IF
C
                    IF (ISTATE.EQ.ISHFLI) THEN
                        OBHFLI=OBSFLI
                        JSHFLI=ISTATE
                    END IF
C
                END IF
C
             END DO
C
             IF (ICHARG.EQ.ICHFLI.AND.IREVER.EQ.IREFLI) THEN
C
C=======================================================================
C            A WARNING IS ISSUED IF THE INDICES HAVE NOT BEEN SELECTED
C=======================================================================
C
                 IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                     WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONSIM'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              ''   ICHFLI='',I3,''        '',3X,''   IREFLI='',I3,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ISPFLI='',I3,''   ISHFLI='',I3,''   IFLIPI='',I3,
     *                                          2X,20(1H/))')
     *               ICHFLI,       IREFLI,
     *               ISPFLI,ISHFLI,IFLIPI
C
                     WRITE(NFIPRI,'(
     *                    1X,20(1H/),''  MESSAGE FROM CONSIM FOR IC'',
     *                               ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                    1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                               ''EAN-FIELD'',      1X,20(1H/),/
     *                    1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                               ''IZATION 2'',      1X,20(1H/),/
     *                    1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                               ''IX IN THE'',      1X,20(1H/),/
     *                    1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                               ''         '',      1X,20(1H/),/)')
     *                    ICHARG
C
                     STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIM)2'
C
                 ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "IFLIPI" CONTROL VARIABLE ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE
C=======================================================================
C
                     IF ((IFLIPI.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *                   (IFLIPI.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                         V_OCCU(JSPFLI+IREVER*NUMBSP(0,ICHARG))=
     *                               L_OCCU(ISHFLI,IREVER,ICHARG)
                         V_OCCU(JSHFLI+IREVER*NUMBSP(0,ICHARG))=
     *                               L_OCCU(ISPFLI,IREVER,ICHARG)
C
               L_OCAC(ISHFLI,IREVER,ICHARG)=L_OCCU(ISPFLI,IREVER,ICHARG)
               L_OCAC(ISPFLI,IREVER,ICHARG)=L_OCCU(ISHFLI,IREVER,ICHARG)
C
                     END IF
C
                 END IF
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (ALL-BLOCKS CASE)
C=======================================================================
C
      DO IREVER=0,MREVER
C
         JSPFLI=0
         JSHFLI=0
C
         OBPFLI=0.0D0
         OBHFLI=0.0D0
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "NOFLIM"  MATRIX ELEMENTS.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
C=======================================================================
C                   SELECTING INDICES IN THE GIVEN
C                   SIMPLEX/CHARGE  BLOCK
C=======================================================================
C
            IF (NOFLIM(IREVER,ICHARG).NE.0) THEN
C
                IF (ABS(NOFLIM(IREVER,ICHARG)).EQ. 1)
     *              OBSFLI=SPALIG(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(NOFLIM(IREVER,ICHARG)).EQ. 2)
     *              OBSFLI=SPSPAL(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(NOFLIM(IREVER,ICHARG)).EQ. 9)
     *              OBSFLI=SPMO20(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(NOFLIM(IREVER,ICHARG)).EQ.10)
     *              OBSFLI=SPMO22(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
                IF (ABS(NOFLIM(IREVER,ICHARG)).GT.10.OR.
     *             (ABS(NOFLIM(IREVER,ICHARG)).GE. 3.AND.
     *              ABS(NOFLIM(IREVER,ICHARG)).LE. 8))
     *              STOP ' NOFLIM OUT OF RANGE IN CONSIM'
C
                IF (ISTATE.EQ.NPFLIM(IREVER,ICHARG)) THEN
                    OBPFLI=OBSFLI
                    JSPFLI=ISTATE
                END IF
C
                IF (ISTATE.EQ.NHFLIM(IREVER,ICHARG)) THEN
                    OBHFLI=OBSFLI
                    JSHFLI=ISTATE
                END IF
C
            END IF
C
         END DO
C
         IF (NOFLIM(IREVER,ICHARG).NE.0) THEN
C
C=======================================================================
C              A WARNING IS ISSUED IF THE INDICES HAVE NOT BEEN SELECTED
C=======================================================================
C
             IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                 WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONSIM'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ICHARG='',I3,''          '',3X,''   IREVER='',I3,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' NPFLIM='',I3,''   NHFLIM='',I3,''   NOFLIM='',I3,
     *                                          2X,20(1H/))')
     *           ICHARG,IREVER,
     *           NPFLIM(IREVER,ICHARG),
     *           NHFLIM(IREVER,ICHARG),
     *           NOFLIM(IREVER,ICHARG)
C
                 WRITE(NFIPRI,'(
     *                1X,20(1H/),''  MESSAGE FROM CONSIM FOR IC'',
     *                           ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                           ''EAN-FIELD'',      1X,20(1H/),/
     *                1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                           ''IZATION 3'',      1X,20(1H/),/
     *                1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                           ''IX IN THE'',      1X,20(1H/),/
     *                1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                           ''         '',      1X,20(1H/),/)')
     *                ICHARG
C
                 STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIM)3'
C
             ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "NOFLIM" MATRIX ELEMENTS  ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE, AND VICE VERSA.
C=======================================================================
C
                 IF ((NOFLIM(IREVER,ICHARG).GT.0.AND.
     *                OBPFLI.GT.OBHFLI).OR.
     *               (NOFLIM(IREVER,ICHARG).LT.0.AND.
     *                OBPFLI.LT.OBHFLI)) THEN
C
                     V_OCCU(JSPFLI+IREVER*NUMBSP(0,ICHARG))=
     *                    L_OCCU(NHFLIM(IREVER,ICHARG),IREVER,ICHARG)
                     V_OCCU(JSHFLI+IREVER*NUMBSP(0,ICHARG))=
     *                    L_OCCU(NPFLIM(IREVER,ICHARG),IREVER,ICHARG)
C
                     L_OCAC(NHFLIM(IREVER,ICHARG),IREVER,ICHARG)=
     *               L_OCCU(NPFLIM(IREVER,ICHARG),IREVER,ICHARG)
                     L_OCAC(NPFLIM(IREVER,ICHARG),IREVER,ICHARG)=
     *               L_OCCU(NHFLIM(IREVER,ICHARG),IREVER,ICHARG)
C
                 END IF
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C        DETERMINING THE ORDERED SINGLE-PARTICLE SPECTRUM AND
C        THE FERMI ENERGY
C=======================================================================
C
      IORDER=0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            IORDER=IORDER+1
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG)
C
         END DO
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
      NUMACT=NUMNUC
C
      IF (MREVER.EQ.0) THEN
C
          IF (MOD(NUMNUC,2).NE.0) STOP ' ODD NUMNUC IN CONSIM'
          NUMACT=NUMNUC/2
C
      END IF
C
      EFERMI=0.5D0*(EORDER(NUMACT+1)+EORDER(NUMACT))
C
C=======================================================================
C         CALCULATING THE NUMBERS OF OCCUPIED STATES IN EVERY
C         SIMPLEX BLOCK
C=======================================================================
C
      IPARTI=0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
            IF (SPENER(ISTATE+IREVER*NUMBSP(0,ICHARG),ICHARG).LT.EFERMI)
     *                                                              THEN
C
                IPARTI=IPARTI+1
C
                L_OCVA(ISTATE,IREVER,ICHARG)=1
C
            END IF
C
         END DO
C
      END DO
C
C      In case of vacuum configuration, all lowest states up to the
C      Fermi level are occupied, all other states empty
C
      IF (IVACUM.EQ.1) THEN
C
          DO IREVER=0,MREVER
C
             DO ISTATE=1,NUMBSP(IREVER,ICHARG)
                V_OCCU(ISTATE+IREVER*NUMBSP(0,ICHARG))
     *         =REAL(L_OCVA(ISTATE,IREVER,ICHARG))
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C        IN CASE OF DEGENERATE STATES AT THE FERMI  ENERGY  THE
C        CONFIGURATION DATA ARE SET TO 100 TO OBTAIN  ASTERISKS
C        ON THE OUTPUT. A BETTER TREATMENT OF SUCH A DEGENERACY
C        IS STILL TO BE FOUND.
C=======================================================================
C
      IF (IPARTI.NE.NUMACT) THEN
C
          DO IREVER=0,MREVER
C
             DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                L_OCVA(ISTATE,IREVER,ICHARG)=100
C
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CONSIQ(ICHARG,NUMNUC,EFERMI,ICHFLI,IPAFLI,
     *                                INSIQB,IPSIQB,IDSIQB,
     *                                       IFIBLB,ISABLB,
     *                                ISPFLI,ISHFLI,IFLIPI,
     *                                       NLSIQR,MXALIB)
C=======================================================================
      USE hfodd_sizes
      USE ALLWAV
C=======================================================================
      COMPLEX
     *          OVRLAP,QOVERL,WAVACT,WAVBLO,C_ZERO
      CHARACTER
     *          SPKART*10,SPNILS*15,SPORDE*13
      CHARACTER
     *          NIBLOL*15
C
      DIMENSION
     *          OVRLAP(1:2*NDSTAT)
      DIMENSION
     *          WAVACT(1:NDBASE,0:NDREVE)
      DIMENSION
     *          INSIQB(1:NDBLOC),IPSIQB(1:NDBLOC),IDSIQB(1:NDBLOC)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPMOME/ SPMO20(1:2*NDSTAT,0:NDISOS),
     *                SPMO22(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLABS/ SPKART(1:2*NDSTAT,0:NDISOS),
     *                SPNILS(1:2*NDSTAT,0:NDISOS),
     *                SPORDE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIQNOC/ NOCSIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /SIQOCC/ K_OCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *                K_OCVA(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQACT/ K_OCAC(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQOCA/ K_OCAL(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /N_FLIQ/ NPFLIQ(0:NDPARI,         0:NDISOS),
     *                NHFLIQ(0:NDPARI,         0:NDISOS),
     *                NOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /VACCNF/ IVACUM
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /BLOCNI/ NIBLOC(       0:NDISOS),NIBLOM(NDBLOC,0:NDISOS),
     *                NIBLOE(NDBLOC,0:NDISOS),NIBLOL(NDBLOC,0:NDISOS)
      COMMON
     *       /BLOWAV/ WAVBLO(1:2*NDBASE,0:NDISOS,0:NDREVE,1:NDBLOC)
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /SIQSTA/ ISTSIQ(1:2*NDSTAT,0:NDPARI)
      COMMON
     *       /SPBNUM/ INUSPB(1:NDBLOC,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C         THIS SUBROUTINE IS CALLED IN THE CASE OF CONSERVATION OF THE
C         PARITY SYMMETRY AND SETS THE OCCUPATION  FACTORS  ACCORDING
C         TO THE CHOSEN PARITY CONFIGURATIONS (IN CASE OF NO PAIRING).
C         IT ALSO CALCULATES THE LOWEST - PARITY  CONFIGURATION FOR A
C         GIVEN SINGLE-PARTICLE SPECTRUM.
C
C=======================================================================
C         ZEROING OCCUPATION FACTORS AND THE VACUUM CONFIGURATION DATA
C=======================================================================
C
      V_OCCU(:)=0.0D0
C
      DO IPARIT=0,NDPARI
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            K_OCVA(ISTATE,IPARIT,ICHARG)=0
C
         END DO
      END DO
C
C=======================================================================
C         DETERMINING THE FERMI ENERGY
C=======================================================================
C
      EFERMI=0.5D0*(SPENER(NUMNUC+1,ICHARG)+SPENER(NUMNUC,ICHARG))
C
C=======================================================================
C         DETERMINING OCCUPATIONS OF AXIAL STATES
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.80B) AND (3.07C), ARRAY  K_OCCU
C                    WAS OVERWRITEN IN CONSIQ AFTER THE CALL TO  AXISIQ.
C                    THIS COULD HAVE CAUSED  PROBLEMS  WHEN  K_OCCU  WAS
C                    USED AGAIN IN AXISIQ IN THE NEXT ITERATION. THE BUG
C                    WAS CORRECTED ON 19/10/2021 IN VERSION (3.07D).
C=======================================================================
C
      K_OCAL(:,:,ICHARG)=K_OCCU(:,:,ICHARG)
C
      IF (IABS(NLSIQR).GE.1) THEN
C
          CALL AXISIQ(NLSIQR,MXALIB,ICHARG)
C
      END IF
C
C=======================================================================
C         BLOCKING BASED ON THE NILSSON LABELS
C=======================================================================
C
      NIBLOP=0
      NIBLOH=0
C
      IF (NIBLOC(ICHARG).GE.1.AND.IDSIQB(1).LE.1) THEN
C
          DO NUBLOC=1,NIBLOC(ICHARG)
C
             IF (NIBLOE(NUBLOC,ICHARG).EQ.+1) NIBLOP=NIBLOP+1
             IF (NIBLOE(NUBLOC,ICHARG).EQ.-1) NIBLOH=NIBLOH+1
C
             NPAPLU=0
             NPAMIN=0
C
             IFOUND=0
C
             DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
                IF (SPNILS(ISTATE,ICHARG).EQ.NIBLOL(NUBLOC,ICHARG).AND.
     *              SPALIG(ISTATE,ICHARG)*NIBLOM(NUBLOC,ICHARG).GT.0.0)
     *                                                              THEN
                    IF (SPPARI(ISTATE,ICHARG).GT.0.0) THEN
C
                        NPAPLU=NPAPLU+1
                        IF (K_OCAL(NPAPLU,0,ICHARG).EQ.+1.AND.
     *                      NIBLOE(NUBLOC,  ICHARG).EQ.-1) THEN
C
                            IFOUND=IFOUND+1
                            K_OCAL(NPAPLU,0,ICHARG)=0
C
                        END IF
C
                        IF (K_OCAL(NPAPLU,0,ICHARG).EQ. 0.AND.
     *                      NIBLOE(NUBLOC,  ICHARG).EQ.+1) THEN
C
                            IFOUND=IFOUND+1
                            K_OCAL(NPAPLU,0,ICHARG)=1
C
                        END IF
C
                    ELSE
C
                        NPAMIN=NPAMIN+ 1
                        IF (K_OCAL(NPAMIN,1,ICHARG).EQ.+1.AND.
     *                      NIBLOE(NUBLOC,  ICHARG).EQ.-1) THEN
C
                            IFOUND=IFOUND+1
                            K_OCAL(NPAMIN,1,ICHARG)=0
C
                        END IF
C
                        IF (K_OCAL(NPAMIN,1,ICHARG).EQ. 0.AND.
     *                      NIBLOE(NUBLOC,  ICHARG).EQ.+1) THEN
C
                            IFOUND=IFOUND+1
                            K_OCAL(NPAMIN,1,ICHARG)=1
C
                        END IF
C
                    END IF
C
                END IF
C
             END DO
C
             IF (IABS(NIBLOM(NUBLOC,ICHARG)).EQ.1.AND.
     *           IABS(NIBLOE(NUBLOC,ICHARG)).EQ.1.AND.
     *           IFOUND.NE.1)
     *
     *           WRITE(NFIPRI,'(
     *                 1X,20(1H/),''  INCORRECT NUMBER OF NILSSO'',
     *                            ''N STATES:'',      1X,20(1H/),/,
     *                 1X,20(1H/),''  AFTER BLOCKING BASED ON NI'',
     *                            ''LSSON LBS'',      1X,20(1H/),/,
     *                 1X,20(1H/),''  NUBLOC='',I3,''  IFOUND='',I3,
     *                            ''  ICHARG='',I3,   2X,20(1H/),/,
     *                 1X,20(1H/),''  NIBLOM='',I3,''  NIBLOE='',I3,
     *                            ''  NIBLOC='',I3,   2X,20(1H/),/,
     *                 1X,20(1H/),''  NIBLOL='',A15,
     *                            ''         '',3X,   2X,20(1H/),/)')
     *            NUBLOC,IFOUND,ICHARG,
     *            NIBLOM(NUBLOC,ICHARG),NIBLOE(NUBLOC,ICHARG),
     *            NIBLOC(ICHARG),
     *            NIBLOL(NUBLOC,ICHARG)
C
          END DO
C
      END IF
C
C=======================================================================
C         SINGLE-PARTICLE BLOCKING
C=======================================================================
C
      IF (IDSIQB(1).EQ.2.AND.NIBLOC(ICHARG).LT.1) THEN
C
          C_ZERO=CMPLX(0.0D0,0.0D0)
C
          JSTATE=ISTSIQ(INSIQB(1),IPSIQB(1))
C
C=======================================================================
C         SAVING THE SINGLE-PARTICLE WAVE FUNCTION. FLAGS IDEBLO ARE
C         USED TO PASS INFORMATION TO  THE  SUBROUTINE  "RECORD"  ON
C         WHETHER THE MATRIX "WAVBLO" HAS BEEN INITIALISED.
C=======================================================================
C
          IF (ISABLB.EQ.1) THEN
C
              IDEBLO(ICHARG)=1
C
              DO IREVER=0,NDREVE
                 DO IBASE=1,LDBASE
C
                   WAVBLO(IBASE,ICHARG,IREVER,1)=
     *             WAVOCC(IBASE,JSTATE,IREVER)
C
                 END DO
              END DO
C
          END IF
C
C=======================================================================
C         DEFINING THE SINGLE-PARTICLE WAVE FUNCTION, WHICH WILL BE USED
C         TO CALCULATE THE OVERLAP
C=======================================================================
C
          IF (IFIBLB.EQ.1) THEN
C
              DO IREVER=0,NDREVE
                 DO IBASE=1,LDBASE
C
                    WAVACT(IBASE,IREVER)=WAVBLO(IBASE,ICHARG,IREVER,1)
C
                 END DO
              END DO
          ELSE
              DO IREVER=0,NDREVE
                 DO IBASE=1,LDBASE
C
                    WAVACT(IBASE,IREVER)=WAVOCC(IBASE,JSTATE,IREVER)
C
                 END DO
              END DO
C
          END IF
C
C=======================================================================
C        CALCULATING OVERLAPS OF SINGLE-PARTICLE STATES
C=======================================================================
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
             QOVERL=C_ZERO
C
             DO IREVER=0,NDREVE
C
                DO IBASE=1,LDBASE
C
                   QOVERL=QOVERL+CONJG(WAVACT(IBASE,       IREVER))
     *                                *WAVOCC(IBASE,ISTATE,IREVER)
                END DO
C
             END DO
C
             OVRLAP(ISTATE)=QOVERL
C
          END DO
C
C=======================================================================
C        SELECTING SINGLE-PARTICLE STATE THAT HAS THE LARGEST OVERLAP
C        WITH THE BLOCKED SINGLE-PARTICLE STATE
C=======================================================================
C
          INUSPB(1,ICHARG)=1
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
             IF(ABS(OVRLAP(ISTATE)).GT.
     *          ABS(OVRLAP(INUSPB(1,ICHARG)))) INUSPB(1,ICHARG)=ISTATE
C
          END DO
C
C=======================================================================
C        CHANGING THE OCCUPATIONS
C=======================================================================
C
         NIBLOP=0
         NIBLOH=0
C
         NPAPLU=0
         NPAMIN=0
C
         IFOUND=0
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            IF (SPPARI(ISTATE,ICHARG).GT.0.0) THEN
C
                NPAPLU=NPAPLU+1
C
                IF (ISTATE.EQ.INUSPB(1,ICHARG)) THEN
C
                    IFOUND=IFOUND+1
C
                    IF (K_OCAL(NPAPLU,0,ICHARG).EQ.1) THEN
C
                        NIBLOH=NIBLOH+1
                        K_OCAL(NPAPLU,0,ICHARG)=0
C
                    ELSE
C
                        NIBLOP=NIBLOP+1
                        K_OCAL(NPAPLU,0,ICHARG)=1
C
                    END IF
C
                END IF
C
            ELSE
C
                NPAMIN=NPAMIN+1
C
                IF (ISTATE.EQ.INUSPB(1,ICHARG)) THEN
C
                    IFOUND=IFOUND+1
C
                    IF (K_OCAL(NPAMIN,1,ICHARG).EQ.1) THEN
C
                        NIBLOH=NIBLOH+1
                        K_OCAL(NPAMIN,1,ICHARG)=0
C
                    ELSE
C
                        NIBLOP=NIBLOP+1
                        K_OCAL(NPAMIN,1,ICHARG)=1
C
                    END IF
C
                END IF
C
            END IF
C
         END DO
C
         IF (IFOUND.NE.1)
     *
     *       WRITE(NFIPRI,'(
     *             1X,20(1H/),''  INCORRECT NUMBER OF SING-P'',
     *                        ''  STATES:'',      1X,20(1H/),/,
     *             1X,20(1H/),''  AFTER SINGLE-PARTICLE BLOC'',
     *                        ''KING     '',      1X,20(1H/),/,
     *             1X,20(1H/),''  INUSPB='',I3,''  IFOUND='',I3,
     *                        ''  ICHARG='',I3,   2X,20(1H/),/,
     *             1X,20(1H/),''  NPAPLU='',I3,''  NPAMIN='',I3,
     *                        ''  JSTATE='',I3,   2X,20(1H/),/,
     *             1X,20(1H/),''  INSIQB='',I3,''  IPSIQB='',I3,
     *                        ''  IDSIQB='',I3,   2X,20(1H/),/,
     *             1X,20(1H/),''  IFIBLB='',I3,''  ISABLB='',I3,
     *                        ''         '',3X,   2X,20(1H/),/)')
     *        INUSPB(1,ICHARG),
     *        IFOUND,ICHARG,
     *        NPAPLU,NPAMIN,JSTATE,
     *        INSIQB(1),IPSIQB(1),IDSIQB(1),
     *        IFIBLB,ISABLB
C
      END IF
C
C=======================================================================
C         SETTING THE OCCUPATION FACTORS ACCORDING TO THE CONFIGURATION
C         AND CALCULATING THE VACUUM CONFIGURATION  TOGETHER  WITH  THE
C         NUMBERS OF OCCUPIED STATES IN EACH PARITY
C=======================================================================
C
      NPAPLU=0
      NPAMIN=0
C
      NOCPLU=0
      NOCMIN=0
C
      IPARTI=0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
         IF (SPPARI(ISTATE,ICHARG).GT.0.0) THEN
C
             NPAPLU=NPAPLU+ 1
             NOCPLU=NOCPLU+ K_OCAL(NPAPLU,0,ICHARG)
C
             V_OCCU(ISTATE)=K_OCAL(NPAPLU,0,ICHARG)
C
             IF (SPENER(ISTATE,ICHARG).LT.EFERMI) THEN
C
                 K_OCVA(NPAPLU,0,ICHARG)=1
                 IPARTI=IPARTI+1
C
             END IF
C
         ELSE
C
             NPAMIN=NPAMIN+ 1
             NOCMIN=NOCMIN+ K_OCAL(NPAMIN,1,ICHARG)
C
             V_OCCU(ISTATE)=K_OCAL(NPAMIN,1,ICHARG)
C
             IF (SPENER(ISTATE,ICHARG).LT.EFERMI) THEN
C
                 K_OCVA(NPAMIN,1,ICHARG)=1
                 IPARTI=IPARTI+1
C
             END IF
C
         END IF
C
      END DO
C
C      In case of vacuum configuration, all lowest states up to the
C      Fermi level are occupied, all other states empty
C
      IF (IVACUM.EQ.1) THEN
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
             IF (SPENER(ISTATE,ICHARG).LT.EFERMI) THEN
                 V_OCCU(ISTATE)=1.0D0
             ELSE
                 V_OCCU(ISTATE)=0.0D0
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C         THE TEST BELOW ENSURES THAT THE NUMBER OF STATES KEPT AFTER
C         THE DIAGONALIZATION IS SUFFICIENT TO ACCOMODATE ALL  STATES
C         OCCUPIED IN EACH OF THE PARITY BLOCKS. THE TEST CAN ONLY BE
C         PERFORMED IN THIS PLACE, BECAUSE THE NUMBER OF STATES  KEPT
C         AFTER THE DIAGONALIZATION DEPENDS ON THE  ENERGY  SPECTRUM,
C         AND THE NUMBERS OF STATES KEPT IN EACH PARITY ARE NOT KNOWN
C         BEFORE THE SPECTRUM IS CALCULATED.
C=======================================================================
C         THE TEST BELOW CAN BE PERFORMED ONLY WHEN  THE SINGLE-PARTICLE
C         BLOCKING HAS NOT BEEN REQUESTED, BECAUSE FOR THE  PARITY  CASE
C         THE TOTAL NUMBERS OF OCCUPIED STATES IN PARITY BLOCS  "NOCSIQ"
C         MUST BE SET TO THE NUMBERS OF STATES OCCUPIED IN THE CORE.
C=======================================================================
C
      IF ((NOCPLU.NE.NOCSIQ(0,ICHARG).OR.NOCMIN.NE.NOCSIQ(1,ICHARG))
     *    .AND.IVACUM.NE.1.AND.NIBLOC(ICHARG).LT.1.AND.IDSIQB(1).LE.1)
     *                                                              THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONSIQ FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/
     *         1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                    ''EAN-FIELD'',      1X,20(1H/),/
     *         1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                    ''IZATION 1'',      1X,20(1H/),/
     *         1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                    ''IX IN THE'',      1X,20(1H/),/
     *         1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                    ''         '',      1X,20(1H/),/)')
     *         ICHARG
C
          STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIQ)1'
C
      END IF
C
      IF (NOCPLU+NOCMIN.NE.NOCSIQ(0,ICHARG)+NOCSIQ(1,ICHARG)
     *                    +NIBLOP-NIBLOH.AND.
     *    IVACUM.NE.1.AND.
     *   (NIBLOC(ICHARG).GE.1.OR.IDSIQB(1).EQ.2)) THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONSIQ FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/,
     *         1X,20(1H/),''  INCONSISTENT NUMBERS OF PA'',
     *                    ''RTICLES  '',      1X,20(1H/),/,
     *         1X,20(1H/),''  AFTER BLOCKING BASED ON NI'',
     *                    ''LSSON LBS'',      1X,20(1H/),/,
     *         1X,20(1H/),''  NOCPLU='',I3,''  NOCMIN='',I3,
     *                    ''  ICHARG='',I3,   2X,20(1H/),/,
     *         1X,20(1H/),'' NOCSIQ0='',I3,'' NOCSIQ1='',I3,
     *                    ''         '',3X,   2X,20(1H/),/,
     *         1X,20(1H/),''  NIBLOP='',I3,''  NIBLOH='',I3,
     *                    ''  NIBLOC='',I3,   2X,20(1H/),/)')
     *    ICHARG,NOCPLU,NOCMIN,ICHARG,
     *    NOCSIQ(0,ICHARG),NOCSIQ(1,ICHARG),
     *    NIBLOP,NIBLOH,NIBLOC(ICHARG)
C
          STOP ' INCONSISTENT NUMBERS OF PARTICLES IN CONSIQ'
C
      END IF
C
C=======================================================================
C        IN CASE OF DEGENERATE STATES AT THE FERMI  ENERGY  THE
C        CONFIGURATION DATA ARE SET TO 100 TO OBTAIN  ASTERISKS
C        ON THE OUTPUT. A BETTER TREATMENT OF SUCH A DEGENERACY
C        IS STILL TO BE FOUND.
C=======================================================================
C
      IF (IPARTI.NE.NUMNUC) THEN
C
          DO IPARIT=0,NDPARI
             DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
                K_OCVA(ISTATE,IPARIT,ICHARG)=100
C
             END DO
          END DO
C
      END IF
C
      K_OCAC(:,:,ICHARG)=K_OCAL(:,:,ICHARG)
C
C=======================================================================
C         IF  THE  BLOCKING  BASED  ON  THE  NILSSON  LABELS,   OR   THE
C         SINGLE-PARTICLE  BLOCKING  IS  REQUESTED,  THE   FLIPPING   OF
C         OCCUPATIONS TO CONSTRUCT THE DIABATIC CONFIGURATIONS BECOMES A
C         FRAGILE PROCEDURE.
C=======================================================================
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (SINGLE-PAIR CASE)
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          NPAPLU=0
          NPAMIN=0
C
          JSPFLI=0
          JSHFLI=0
C
          OBPFLI=0.0D0
          OBHFLI=0.0D0
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "IFLIPI" CONTROL VARIABLE.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
             IF (ABS(IFLIPI).EQ. 1) OBSFLI=SPALIG(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 2) OBSFLI=SPSPAL(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 3) OBSFLI=SPXALI(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 4) OBSFLI=SPXSPI(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 5) OBSFLI=SPZALI(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 6) OBSFLI=SPZSPI(ISTATE,ICHARG)
C
             IF (ABS(IFLIPI).EQ. 7) OBSFLI=SPXALI(ISTATE,ICHARG)*OMOVAX
     *                                    +SPALIG(ISTATE,ICHARG)*OMOVAY
     *                                    +SPZALI(ISTATE,ICHARG)*OMOVAZ
C
             IF (ABS(IFLIPI).EQ. 8) OBSFLI=SPXSPI(ISTATE,ICHARG)*OMOVAX
     *                                    +SPSPAL(ISTATE,ICHARG)*OMOVAY
     *                                    +SPZSPI(ISTATE,ICHARG)*OMOVAZ
C
             IF (ABS(IFLIPI).EQ. 9) OBSFLI=SPMO20(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ.10) OBSFLI=SPMO22(ISTATE,ICHARG)
C
             IF (ABS(IFLIPI).GT.10) STOP ' IFLIPI TOO LARGE IN CONSIQ'
C
C=======================================================================
C
             IF (SPPARI(ISTATE,ICHARG).GT.0.0) THEN
C
                 NPAPLU=NPAPLU+1
C
C=======================================================================
C                   SELECTING INDICES IN THE POSITIVE PARITY BLOCK
C=======================================================================
C
                 IF (IPAFLI.EQ.0.AND.ICHARG.EQ.ICHFLI) THEN
C
                     IF (NPAPLU.EQ.ISPFLI) THEN
                         OBPFLI=OBSFLI
                         JSPFLI=ISTATE
                     END IF
C
                     IF (NPAPLU.EQ.ISHFLI) THEN
                         OBHFLI=OBSFLI
                         JSHFLI=ISTATE
                     END IF
C
                 END IF
C
             ELSE
C
                 NPAMIN=NPAMIN+1
C
C=======================================================================
C                   SELECTING INDICES IN THE NEGATIVE PARITY BLOCK
C=======================================================================
C
                 IF (IPAFLI.EQ.1.AND.ICHARG.EQ.ICHFLI) THEN
C
                     IF (NPAMIN.EQ.ISPFLI) THEN
                         OBPFLI=OBSFLI
                         JSPFLI=ISTATE
                     END IF
C
                     IF (NPAMIN.EQ.ISHFLI) THEN
                         OBHFLI=OBSFLI
                         JSHFLI=ISTATE
                     END IF
C
                 END IF
C
             END IF
C
          END DO
C
          IF (ICHARG.EQ.ICHFLI) THEN
C
C=======================================================================
C            PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
              IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONSIQ'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ICHFLI='',I3,''   IPAFLI='',I3,''          '',3X,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ISPFLI='',I3,''   ISHFLI='',I3,''   IFLIPI='',I3,
     *                                          2X,20(1H/))')
     *            ICHFLI,IPAFLI,
     *            ISPFLI,ISHFLI,IFLIPI
C
                  WRITE(NFIPRI,'(
     *                 1X,20(1H/),''  MESSAGE FROM CONSIQ FOR IC'',
     *                            ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                 1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                            ''EAN-FIELD'',      1X,20(1H/),/
     *                 1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                            ''IZATION 2'',      1X,20(1H/),/
     *                 1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                            ''IX IN THE'',      1X,20(1H/),/
     *                 1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                            ''         '',      1X,20(1H/),/)')
     *                 ICHARG
C
                  STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIQ)2'
C
              ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "IFLIPI" CONTROL VARIABLE ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE
C=======================================================================
C
                  IF ((IFLIPI.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *                (IFLIPI.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                      V_OCCU(JSPFLI)=K_OCAL(ISHFLI,IPAFLI,ICHARG)
                      V_OCCU(JSHFLI)=K_OCAL(ISPFLI,IPAFLI,ICHARG)
C
                      K_OCAC(ISHFLI,IPAFLI,ICHARG)=
     *                K_OCAL(ISPFLI,IPAFLI,ICHARG)
                      K_OCAC(ISPFLI,IPAFLI,ICHARG)=
     *                K_OCAL(ISHFLI,IPAFLI,ICHARG)
C
                  END IF
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (ALL-BLOCKS CASE)
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
         NPARTY=0
C
         JSPFLI=0
         JSHFLI=0
C
         OBPFLI=0.0D0
         OBHFLI=0.0D0
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C           FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C           BY THE ABSOLUTE VALUE OF THE  "NOFLIQ"  MATRIX ELEMENTS.
C           SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
            IF ((IPARIT.EQ.0.AND.SPPARI(ISTATE,ICHARG).GT.0.0).OR.
     *          (IPARIT.EQ.1.AND.SPPARI(ISTATE,ICHARG).LT.0.0)) THEN
C
                NPARTY=NPARTY+1
C
C=======================================================================
C               SELECTING INDICES IN THE GIVEN PARITY/CHARGE  BLOCK
C=======================================================================
C
                IF (NOFLIQ(IPARIT,ICHARG).NE.0) THEN
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 1)
     *                  OBSFLI=SPALIG(ISTATE,ICHARG)
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 2)
     *                  OBSFLI=SPSPAL(ISTATE,ICHARG)
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 3)
     *                  OBSFLI=SPXALI(ISTATE,ICHARG)
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 4)
     *                  OBSFLI=SPXSPI(ISTATE,ICHARG)
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 5)
     *                  OBSFLI=SPZALI(ISTATE,ICHARG)
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 6)
     *                  OBSFLI=SPZSPI(ISTATE,ICHARG)
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 7)
     *                  OBSFLI=SPXALI(ISTATE,ICHARG)*OMOVAX
     *                        +SPALIG(ISTATE,ICHARG)*OMOVAY
     *                        +SPZALI(ISTATE,ICHARG)*OMOVAZ
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 8)
     *                  OBSFLI=SPXSPI(ISTATE,ICHARG)*OMOVAX
     *                        +SPSPAL(ISTATE,ICHARG)*OMOVAY
     *                        +SPZSPI(ISTATE,ICHARG)*OMOVAZ
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ. 9)
     *                  OBSFLI=SPMO20(ISTATE,ICHARG)
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).EQ.10)
     *                  OBSFLI=SPMO22(ISTATE,ICHARG)
C
                    IF (ABS(NOFLIQ(IPARIT,ICHARG)).GT.10)
     *                  STOP ' NOFLIQ TOO LARGE IN CONSIQ'
C
C=======================================================================
C
                    IF (NPARTY.EQ.NPFLIQ(IPARIT,ICHARG)) THEN
                        OBPFLI=OBSFLI
                        JSPFLI=ISTATE
                    END IF
C
                    IF (NPARTY.EQ.NHFLIQ(IPARIT,ICHARG)) THEN
                        OBHFLI=OBSFLI
                        JSHFLI=ISTATE
                    END IF
C
                END IF
C
            END IF
C
         END DO
C
         IF (NOFLIQ(IPARIT,ICHARG).NE.0) THEN
C
C=======================================================================
C            PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
             IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                 WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONSIQ'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ICHARG='',I3,''   IPARIT='',I3,''          '',3X,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' NPFLIG='',I3,''   NHFLIG='',I3,''   NOFLIG='',I3,
     *                                          2X,20(1H/))')
     *           ICHARG,IPARIT,
     *           NPFLIQ(IPARIT,ICHARG),
     *           NHFLIQ(IPARIT,ICHARG),
     *           NOFLIQ(IPARIT,ICHARG)
C
                 WRITE(NFIPRI,'(
     *                1X,20(1H/),''  MESSAGE FROM CONSIQ FOR IC'',
     *                           ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                           ''EAN-FIELD'',      1X,20(1H/),/
     *                1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                           ''IZATION 3'',      1X,20(1H/),/
     *                1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                           ''IX IN THE'',      1X,20(1H/),/
     *                1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                           ''         '',      1X,20(1H/),/)')
     *                ICHARG
C
                 STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIQ)3'
C
             ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "NOFLIQ" MATRIX ELEMENTS  ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE, AND VICE VERSA.
C=======================================================================
C
                 IF ((NOFLIQ(IPARIT,ICHARG).GT.0.AND.
     *                OBPFLI.GT.OBHFLI).OR.
     *               (NOFLIQ(IPARIT,ICHARG).LT.0.AND.
     *                OBPFLI.LT.OBHFLI)) THEN
C
                     V_OCCU(JSPFLI)=K_OCAL(NHFLIQ(IPARIT,ICHARG),
     *                                            IPARIT,ICHARG)
                     V_OCCU(JSHFLI)=K_OCAL(NPFLIQ(IPARIT,ICHARG),
     *                                            IPARIT,ICHARG)
C
                     K_OCAC(NHFLIQ(IPARIT,ICHARG),IPARIT,ICHARG)=
     *               K_OCAL(NPFLIQ(IPARIT,ICHARG),IPARIT,ICHARG)
                     K_OCAC(NPFLIQ(IPARIT,ICHARG),IPARIT,ICHARG)=
     *               K_OCAL(NHFLIQ(IPARIT,ICHARG),IPARIT,ICHARG)
C
                 END IF
C
             END IF
C
         END IF
C
      END DO
C
C     IF (IABS(NLSIQR).GE.1) THEN
C
C         DO IPARIT=0,NDPARI
C
C            WRITE (*,'(100I2)') (K_OCAC(ISTATE,IPARIT,ICHARG),
C    *                           ISTATE=1,80)
C            WRITE (*,'(100I2)') (K_OCAL(ISTATE,IPARIT,ICHARG),
C    *                           ISTATE=1,80)
C
C         END DO
C
C     END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CONSIZ(ICHARG,NUMNUC,EFERMI,
     *                  ICHFLI,INSIZB,IDSIZB,
     *                         IFIBLB,ISABLB,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                         NLSIZR,MXALIB,
     *                                ISAOCC,
     *                                ITWCEN)
C=======================================================================
      USE hfodd_sizes
      USE ALLWAV
      USE TWCWAV
      USE BIGOVE
C=======================================================================
      CHARACTER
     *          NIBLOL*15
C
      COMPLEX
     *          OVRLAP,QOVERL,WAVACT,WAVBLO,C_ZERO
C
      DIMENSION
     *          EORDER(1:2*NDBASE),NORDER(1:2*NDBASE)
      DIMENSION
     *          INSIZB(1:NDBLOC),IDSIZB(1:NDBLOC)
      DIMENSION
     *          OVRLAP(1:2*NDSTAT)
      DIMENSION
     *          WAVACT(1:NDBASE,0:NDREVE)
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPMOME/ SPMO20(1:2*NDSTAT,0:NDISOS),
     *                SPMO22(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZNOC/ NOCSIZ(0:NDISOS)
      COMMON
     *       /SIZOCC/ M_OCCU(1:2*NDSTAT,0:NDISOS),
     *                M_OCVA(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZACT/ M_OCAC(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZOCA/ M_OCAL(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZNVA/ NVASIZ(0:NDISOS)
      COMMON
     *       /N_FLIZ/ NPFLIZ(                  0:NDISOS),
     *                NHFLIZ(                  0:NDISOS),
     *                NOFLIZ(                  0:NDISOS)
      COMMON
     *       /N_FILZ/ NPFILZ(                  0:NDISOS),
     *                NHFILZ(                  0:NDISOS),
     *                NOFILZ(                  0:NDISOS)
      COMMON
     *       /SIZFIL/ VFISIZ(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /VACCNF/ IVACUM
      COMMON
     *       /BLOWAV/ WAVBLO(1:2*NDBASE,0:NDISOS,0:NDREVE,1:NDBLOC)
      COMMON
     *       /BLODEF/ IDEBLO(0:NDISOS)
      COMMON
     *       /BLOCNI/ NIBLOC(       0:NDISOS),NIBLOM(NDBLOC,0:NDISOS),
     *                NIBLOE(NDBLOC,0:NDISOS),NIBLOL(NDBLOC,0:NDISOS)
      COMMON
     *       /SPBNUM/ INUSPB(1:NDBLOC,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /CFIPRI/ NFIPRI
      COMMON
     *       /SVOCCU/ SV_OCC(1:4*NDSTAT,NDISOS)
      COMMON
     *       /TWCDIA/ TWCSPE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /DIMTWC/ LDBATW(1:NDTWCE),LDBTOT
C
C=======================================================================
C         THIS SUBROUTINE IS CALLED IN THE CASE OF  NO SYMMETRY  AND
C         SETS THE OCCUPATION FACTORS ACCORDING TO THE CHOSEN GLOBAL
C         CONFIGURATIONS (IN CASE OF NO PAIRING).
C=======================================================================
C
C=======================================================================
C         ZEROING OCCUPATION FACTORS AND THE VACUUM CONFIGURATION DATA
C=======================================================================
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
         V_OCCU(ISTATE)=0.0D0
C
         M_OCVA(ISTATE,ICHARG)=0
C
      END DO
C
C=======================================================================
C         DETERMINING OCCUPATIONS OF AXIAL STATES
C=======================================================================
C         ATTENTION: BETWEEN VERSIONS (2.83G) AND (3.07C), ARRAY  M_OCCU
C                    WAS OVERWRITEN IN CONSIZ AFTER THE CALL TO  AXISIZ.
C                    THIS COULD HAVE CAUSED  PROBLEMS  WHEN  M_OCCU  WAS
C                    USED AGAIN IN AXISIZ IN THE NEXT ITERATION. THE BUG
C                    WAS CORRECTED ON 19/10/2021 IN VERSION (3.07D).
C=======================================================================
C
      M_OCAL(:,ICHARG)=M_OCCU(:,ICHARG)
C
      IF (IABS(NLSIZR).GE.1) THEN
C
          CALL AXISIZ(NLSIZR,MXALIB,ICHARG)
C
      END IF
C
C=======================================================================
C         SINGLE-PARTICLE BLOCKING
C=======================================================================
C
      IF (IDSIZB(1).EQ.2.AND.NIBLOC(ICHARG).LT.1) THEN
C
          C_ZERO=CMPLX(0.0D0,0.0D0)
C
          JSTATE=INSIZB(1)
C
C=======================================================================
C         SAVING THE SINGLE-PARTICLE WAVE FUNCTION. FLAGS IDEBLO ARE
C         USED TO PASS INFORMATION TO  THE  SUBROUTINE  "RECORD"  ON
C         WHETHER THE MATRIX "WAVBLO" HAS BEEN INITIALISED.
C=======================================================================
C
          IF (ISABLB.EQ.1) THEN
C
              IDEBLO(ICHARG)=1
C
              DO IREVER=0,NDREVE
C
                 IF (ITWCEN.EQ.1) THEN
                     DO IBASE=1,LDBASE
                        WAVBLO(IBASE,ICHARG,IREVER,1)=
     *                  WAVOCC(IBASE,JSTATE,IREVER)
                     END DO
                 ELSEIF (ITWCEN.EQ.2) THEN
                     DO IBASE=1,LDBTOT
                        WAVBLO(IBASE,ICHARG,IREVER,1)=
     *                  TWCOCC(IBASE,JSTATE,IREVER,ICHARG)
                     END DO
                 END IF
C
              END DO
C
          END IF
C
C=======================================================================
C         DEFINING THE SINGLE-PARTICLE WAVE FUNCTION, WHICH WILL BE USED
C         TO CALCULATE THE OVERLAP
C=======================================================================
C
          IF (IFIBLB.EQ.1) THEN
C
              DO IREVER=0,NDREVE
                 DO IBASE=1,LDBTOT
C
                    WAVACT(IBASE,IREVER)=WAVBLO(IBASE,ICHARG,IREVER,1)
C
                 END DO
              END DO
          ELSE
              DO IREVER=0,NDREVE
C
                 IF (ITWCEN.EQ.1) THEN
                     DO IBASE=1,LDBASE
                        WAVACT(IBASE,IREVER)=WAVOCC(IBASE,JSTATE,IREVER)
                     END DO
                 ELSEIF (ITWCEN.EQ.2) THEN
                     DO IBASE=1,LDBTOT
                        WAVACT(IBASE,IREVER)=
     *                  TWCOCC(IBASE,JSTATE,IREVER,ICHARG)
                     END DO
                 END IF
              END DO
C
          END IF
C
C=======================================================================
C        CALCULATING OVERLAPS OF SINGLE-PARTICLE STATES
C=======================================================================
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
             QOVERL=C_ZERO
C
             IF (ITWCEN.EQ.1) THEN
C
                 DO IREVER=0,NDREVE
C
                    DO IBASE=1,LDBASE
C
                       QOVERL=QOVERL+CONJG(WAVACT(IBASE,       IREVER))
     *                                    *WAVOCC(IBASE,ISTATE,IREVER)
                    END DO
C
                 END DO
C
             ELSEIF (ITWCEN.EQ.2) THEN
C
                 DO IBRA=1,2*LDBTOT
                    DO IKET=1,2*LDBTOT
C
                       IF (IBRA.LE.LDBTOT) IREBRA=0
                       IF (IBRA.GT.LDBTOT) IREBRA=1
                       IF (IKET.LE.LDBTOT) IREKET=0
                       IF (IKET.GT.LDBTOT) IREKET=1

                       QOVERL=QOVERL
     *              +  CONJG(WAVACT(IBRA-IREBRA*LDBTOT,IREBRA))
     *              *  BIGNOR(IBRA,IKET)
     *              *  TWCOCC(IKET-IREKET*LDBTOT,ISTATE,IREKET,ICHARG)

                    END DO
                 END DO
C
             END IF
C
             OVRLAP(ISTATE)=QOVERL
C
          END DO
C
C=======================================================================
C        SELECTING SINGLE-PARTICLE STATE THAT HAS THE LARGEST OVERLAP
C        WITH THE BLOCKED SINGLE-PARTICLE STATE
C=======================================================================
C
          INUSPB(1,ICHARG)=1
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
             IF(ABS(OVRLAP(ISTATE)).GT.
     *          ABS(OVRLAP(INUSPB(1,ICHARG)))) INUSPB(1,ICHARG)=ISTATE
C
          END DO
C
C=======================================================================
C        CHANGING THE OCCUPATIONS
C=======================================================================
C
         NIBLOP=0
         NIBLOH=0
C
         IFOUND=0
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            IF (ISTATE.EQ.INUSPB(1,ICHARG)) THEN
C
                IFOUND=IFOUND+1
C
                IF (M_OCAL(ISTATE,ICHARG).EQ.1) THEN
C
                    NIBLOH=NIBLOH+1
                    M_OCAL(ISTATE,ICHARG)=0
C
                ELSE
C
                    NIBLOP=NIBLOP+1
                    M_OCAL(ISTATE,ICHARG)=1
C
                END IF
C
            END IF
C
         END DO
C
         IF (IFOUND.NE.1)
     *
     *       WRITE(NFIPRI,'(
     *             1X,20(1H/),''  INCORRECT NUMBER OF SING-P'',
     *                        ''  STATES:'',      1X,20(1H/),/,
     *             1X,20(1H/),''  AFTER SINGLE-PARTICLE BLOC'',
     *                        ''KING     '',      1X,20(1H/),/,
     *             1X,20(1H/),''  INUSPB='',I3,''  IFOUND='',I3,
     *                        ''  ICHARG='',I3,   2X,20(1H/),/,
     *             1X,20(1H/),''  INSIZB='',I3,''  IDSIZB='',I3,
     *                        ''         '',3X,   2X,20(1H/),/,
     *             1X,20(1H/),''  IFIBLB='',I3,''  ISABLB='',I3,
     *                        ''         '',3X,   2X,20(1H/),/)')
     *        INUSPB(1,ICHARG),
     *        IFOUND,ICHARG,
     *        INSIZB(1),IDSIZB(1),
     *        IFIBLB,ISABLB
C
      END IF
C
C=======================================================================
C         SETTING THE OCCUPATION FACTORS ACCORDING TO THE CONFIGURATION
C=======================================================================
C
      NOCCUP=0
      OCCFIL=0.0D0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
         NOCCUP=NOCCUP+ M_OCAL(ISTATE,ICHARG)
         V_OCCU(ISTATE)=M_OCAL(ISTATE,ICHARG)
C
         IF (NOFILZ(ICHARG).GE.1) THEN
C
             IF (ISTATE.GE.NHFILZ(ICHARG).AND.
     *           ISTATE.LE.NPFILZ(ICHARG))
     *
     *           V_OCCU(ISTATE)=VFISIZ(ISTATE,ICHARG)
C
         END IF
C
         OCCFIL=OCCFIL+V_OCCU(ISTATE)**2
C
      END DO
C
C=======================================================================
C         THE TEST BELOW ENSURES THAT THE NUMBER OF STATES KEPT AFTER
C         THE DIAGONALIZATION IS SUFFICIENT TO ACCOMODATE ALL  STATES
C         OCCUPIED IN EACH OF THE CHARGE BLOCKS. THE TEST  COULD HAVE
C         BEEN PERFORMED IN ANOTHER PLACE, HOWEVER, IT  IS  PERFORMED
C         HERE TO KEEP CONSISTENCY WITH OTHER SYMMETRIES.
C=======================================================================
C         THE TEST BELOW CAN  BE  PERFORMED  ONLY  WHEN  THE  FILLING
C         APPROXIMATION HAS NOT BEEN REQUESTED.
C=======================================================================
C         THE TEST BELOW CAN BE PERFORMED ONLY WHEN  THE SINGLE-PARTICLE
C         BLOCKING HAS NOT BEEN REQUESTED, BECAUSE FOR  THE  NO-SYMMETRY
C         CASE THE TOTAL NUMBER OF OCCUPIED STATES "NVASIZ" MUST BE  SET
C         TO THE NUMBER  OF STATES OCCUPIED IN THE CORE.
C=======================================================================
C
      IF (NOFILZ(ICHARG).LT.1.AND.NOCCUP.NE.NVASIZ(ICHARG)
     *    .AND.IVACUM.NE.1.AND.NIBLOC(ICHARG).LT.1.AND.IDSIZB(1).LE.1)
     *                                                              THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONSIZ FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/
     *         1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                    ''EAN-FIELD'',      1X,20(1H/),/
     *         1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                    ''IZATION 1'',      1X,20(1H/),/
     *         1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                    ''IX IN THE'',      1X,20(1H/),/
     *         1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                    ''         '',      1X,20(1H/),/)')
     *         ICHARG
C
          STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIZ)1'
C
      END IF
C
C=======================================================================
C         THE TEST BELOW CAN BE PERFORMED IN CASE  WHEN  THE  FILLING
C         APPROXIMATION HAS BEEN REQUESTED
C=======================================================================
C
      IF (NOFILZ(ICHARG).GE.1.AND.
     *    ABS(OCCFIL-NOCSIZ(ICHARG)).GT.1.0D-12) THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONSIZ FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/
     *         1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                    ''EAN-FIELD'',      1X,20(1H/),/
     *         1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                    ''IZATION 4'',      1X,20(1H/),/
     *         1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                    ''IX IN THE'',      1X,20(1H/),/
     *         1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                    ''         '',      1X,20(1H/),/)')
     *         ICHARG
C
          STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIZ)4'
C
      END IF
C
      M_OCAC(:,ICHARG)=M_OCAL(:,ICHARG)
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (SINGLE-BLOCK CASE)
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          JSPFLI=0
          JSHFLI=0
C
          OBPFLI=0.0D0
          OBHFLI=0.0D0
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "IFLIPI" CONTROL VARIABLE.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
             IF (ABS(IFLIPI).EQ. 1) OBSFLI=SPALIG(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 2) OBSFLI=SPSPAL(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 3) OBSFLI=SPXALI(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 4) OBSFLI=SPXSPI(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 5) OBSFLI=SPZALI(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ. 6) OBSFLI=SPZSPI(ISTATE,ICHARG)
C
             IF (ABS(IFLIPI).EQ. 7) OBSFLI=SPXALI(ISTATE,ICHARG)*OMOVAX
     *                                    +SPALIG(ISTATE,ICHARG)*OMOVAY
     *                                    +SPZALI(ISTATE,ICHARG)*OMOVAZ
C
             IF (ABS(IFLIPI).EQ. 8) OBSFLI=SPXSPI(ISTATE,ICHARG)*OMOVAX
     *                                    +SPSPAL(ISTATE,ICHARG)*OMOVAY
     *                                    +SPZSPI(ISTATE,ICHARG)*OMOVAZ
C
             IF (ABS(IFLIPI).EQ. 9) OBSFLI=SPMO20(ISTATE,ICHARG)
             IF (ABS(IFLIPI).EQ.10) OBSFLI=SPMO22(ISTATE,ICHARG)
C
             IF (ABS(IFLIPI).GT.10) STOP ' IFLIPI TOO LARGE IN CONSIZ'
C
C=======================================================================
C               SELECTING INDICES
C=======================================================================
C
             IF (ICHARG.EQ.ICHFLI) THEN
C
                 IF (ISTATE.EQ.ISPFLI) THEN
                     OBPFLI=OBSFLI
                     JSPFLI=ISTATE
                 END IF
C
                 IF (ISTATE.EQ.ISHFLI) THEN
                     OBHFLI=OBSFLI
                     JSHFLI=ISTATE
                 END IF
C
             END IF
C
          END DO
C
          IF (ICHARG.EQ.ICHFLI) THEN
C
C=======================================================================
C            A WARNING IS ISSUED IF THE INDICES HAVE NOT BEEN SELECTED
C=======================================================================
C
              IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                  WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONSIZ'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              ''   ICHFLI='',I3,''        '',3X,''          '',3X,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ISPFLI='',I3,''   ISHFLI='',I3,''   IFLIPI='',I3,
     *                                          2X,20(1H/))')
     *            ICHFLI,
     *            ISPFLI,ISHFLI,IFLIPI
C
                  WRITE(NFIPRI,'(
     *                 1X,20(1H/),''  MESSAGE FROM CONSIZ FOR IC'',
     *                            ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                 1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                            ''EAN-FIELD'',      1X,20(1H/),/
     *                 1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                            ''IZATION 2'',      1X,20(1H/),/
     *                 1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                            ''IX IN THE'',      1X,20(1H/),/
     *                 1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                            ''         '',      1X,20(1H/),/)')
     *                 ICHARG
C
                  STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIZ)2'
C
              ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "IFLIPI" CONTROL VARIABLE ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE
C=======================================================================
C
                  IF ((IFLIPI.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *                (IFLIPI.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                      V_OCCU(JSPFLI)=M_OCAL(ISHFLI,ICHARG)
                      V_OCCU(JSHFLI)=M_OCAL(ISPFLI,ICHARG)
C
                      M_OCAC(ISHFLI,ICHARG)=M_OCAL(ISPFLI,ICHARG)
                      M_OCAC(ISPFLI,ICHARG)=M_OCAL(ISHFLI,ICHARG)
C
                  END IF
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (ALL-BLOCKS CASE)
C=======================================================================
C
      NPARTY=0
C
      JSPFLI=0
      JSHFLI=0
C
      OBPFLI=0.0D0
      OBHFLI=0.0D0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
C=======================================================================
C        FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C        BY THE ABSOLUTE VALUE OF THE  "NOFLIZ"  MATRIX ELEMENTS.
C        SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
         NPARTY=NPARTY+1
C
C=======================================================================
C        SELECTING INDICES IN THE GIVEN CHARGE  BLOCK
C=======================================================================
C
         IF (NOFLIZ(ICHARG).NE.0) THEN
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 1) OBSFLI=SPALIG(ISTATE,ICHARG)
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 2) OBSFLI=SPSPAL(ISTATE,ICHARG)
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 3) OBSFLI=SPXALI(ISTATE,ICHARG)
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 4) OBSFLI=SPXSPI(ISTATE,ICHARG)
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 5) OBSFLI=SPZALI(ISTATE,ICHARG)
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 6) OBSFLI=SPZSPI(ISTATE,ICHARG)
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 7)
     *           OBSFLI=SPXALI(ISTATE,ICHARG)*OMOVAX
     *                 +SPALIG(ISTATE,ICHARG)*OMOVAY
     *                 +SPZALI(ISTATE,ICHARG)*OMOVAZ
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 8)
     *           OBSFLI=SPXSPI(ISTATE,ICHARG)*OMOVAX
     *                 +SPSPAL(ISTATE,ICHARG)*OMOVAY
     *                 +SPZSPI(ISTATE,ICHARG)*OMOVAZ
C
             IF (ABS(NOFLIZ(ICHARG)).EQ. 9) OBSFLI=SPMO20(ISTATE,ICHARG)
C
             IF (ABS(NOFLIZ(ICHARG)).EQ.10) OBSFLI=SPMO22(ISTATE,ICHARG)
C
             IF (ABS(NOFLIZ(ICHARG)).GT.10)
     *           STOP ' NOFLIZ TOO LARGE IN CONSIZ'
C
C=======================================================================
C
             IF (NPARTY.EQ.NPFLIZ(ICHARG)) THEN
                 OBPFLI=OBSFLI
                 JSPFLI=ISTATE
             END IF
C
             IF (NPARTY.EQ.NHFLIZ(ICHARG)) THEN
                 OBHFLI=OBSFLI
                 JSHFLI=ISTATE
             END IF
C
         END IF
C
      END DO
C
      IF (NOFLIZ(ICHARG).NE.0) THEN
C
C=======================================================================
C         PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
          IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
              WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONSIZ'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ICHARG='',I3,''          '',3X,''          '',3X,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' NPFLIZ='',I3,''   NHFLIZ='',I3,''   NOFLIZ='',I3,
     *                                          2X,20(1H/))')
     *        ICHARG,
     *        NPFLIZ(ICHARG),
     *        NHFLIZ(ICHARG),
     *        NOFLIZ(ICHARG)
C
              WRITE(NFIPRI,'(
     *             1X,20(1H/),''  MESSAGE FROM CONSIZ FOR IC'',
     *                        ''HARG = '',I1,1H:, 1X,20(1H/),/
     *             1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                        ''EAN-FIELD'',      1X,20(1H/),/
     *             1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                        ''IZATION 3'',      1X,20(1H/),/
     *             1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                        ''IX IN THE'',      1X,20(1H/),/
     *             1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                        ''         '',      1X,20(1H/),/)')
     *             ICHARG
C
              STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONSIZ)3'
C
          ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "NOFLIZ" MATRIX ELEMENTS  ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE, AND VICE VERSA.
C=======================================================================
C
              IF ((NOFLIZ(ICHARG).GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *            (NOFLIZ(ICHARG).LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                  V_OCCU(JSPFLI)=M_OCAL(NHFLIZ(ICHARG),ICHARG)
                  V_OCCU(JSHFLI)=M_OCAL(NPFLIZ(ICHARG),ICHARG)
C
             M_OCAC(NHFLIZ(ICHARG),ICHARG)=M_OCAL(NPFLIZ(ICHARG),ICHARG)
             M_OCAC(NPFLIZ(ICHARG),ICHARG)=M_OCAL(NHFLIZ(ICHARG),ICHARG)
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C        DETERMINING THE ORDERED SINGLE-PARTICLE SPECTRUM AND
C        THE FERMI ENERGY
C=======================================================================
C
      IORDER=0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
         IORDER=IORDER+1
         NORDER(IORDER)=IORDER
         IF (ITWCEN.EQ.1) EORDER(IORDER)=SPENER(ISTATE,ICHARG)
         IF (ITWCEN.EQ.2) EORDER(IORDER)=TWCSPE(ISTATE,ICHARG)
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
      NUMACT=NUMNUC
C
      EFERMI=0.5D0*(EORDER(NUMACT+1)+EORDER(NUMACT))
C
C=======================================================================
C         DETERMINING THE VACUUM CONFIGURATION
C=======================================================================
C
      IPARTI=0
C
      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
             IF (ITWCEN.EQ.1) THEN
C
                 IF (SPENER(ISTATE,ICHARG).LT.EFERMI) THEN
C
                     IPARTI=IPARTI+1
C
                     M_OCVA(ISTATE,ICHARG)=1
C
                 END IF
C
             ELSEIF (ITWCEN.EQ.2) THEN
C
                 IF (TWCSPE(ISTATE,ICHARG).LT.EFERMI) THEN
C
                     IPARTI=IPARTI+1
C
                     M_OCVA(ISTATE,ICHARG)=1
C
                 END IF
C
             END IF
C
      END DO
C
C      In case of vacuum configuration, all lowest states up to the
C      Fermi level are occupied, all other states empty
C
      IF (IVACUM.EQ.1) THEN
C
          DO ISTATE=1,NUMACT
             V_OCCU(ISTATE)=1.0D0
          END DO
C
          DO ISTATE=NUMACT+1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
             V_OCCU(ISTATE)=0.0D0
          END DO
C
      END IF
C
C=======================================================================
C
      IF (ISAOCC.EQ.1) THEN
C
          DO IALLST=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
             SV_OCC(IALLST,ICHARG)=V_OCCU(IALLST)
          END DO
C
      END IF
C
C=======================================================================
C        IN CASE OF DEGENERATE STATES AT THE FERMI  ENERGY  THE
C        CONFIGURATION DATA ARE SET TO 100 TO OBTAIN  ASTERISKS
C        ON THE OUTPUT. A BETTER TREATMENT OF SUCH A DEGENERACY
C        IS STILL TO BE FOUND.
C=======================================================================
C
      IF (IPARTI.NE.NUMACT) THEN
C
          DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
             M_OCVA(ISTATE,ICHARG)=100
C
          END DO
C
      END IF
C
C=======================================================================
C            PRINTING CONFIGURATIONS.
C=======================================================================
C
C     IF (IABS(NLSIZR).GE.1) THEN
C
C         WRITE (*,'(100I2)') (M_OCAC(ISTATE,ICHARG),ISTATE=1,80)
C
C     END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CONMIG(MREVER,IN_FIX,IZ_FIX,EFERMI,
     *                                IPAFLI,IREFLI,
     *                         ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          EORDER(1:4*NDBASE),NORDER(1:4*NDBASE)
      DIMENSION
     *          OCCFIL(0:NDPARI,0:NDREVE)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNMOME/ PNMO20(1:4*NDSTAT),
     *                PNMO22(1:4*NDSTAT)
      COMMON
     *       /MIGOCC/ NMOCCU(1:2*NDSTAT,0:NDPARI,0:NDREVE),
     *                NMOCVA(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGFIL/ VFIMIG(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MILG/ NPMILG(0:NDPARI,0:NDREVE),
     *                NHMILG(0:NDPARI,0:NDREVE),
     *                NOMILG(0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MLIG/ NPMLIG(0:NDPARI,0:NDREVE),
     *                NHMLIG(0:NDPARI,0:NDREVE),
     *                NOMLIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGNOC/ NOCMIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /MIOCCU/ VMOCCU(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C        THIS SUBROUTINE IS CALLED IN THE CASE OF CONSERVATION OF THE
C        SIGNATURE SYMMETRY AND PROTON-NEUTRON MIXING INCLUDED.
C        IT SETS THE OCCUPATION FACTORS ACCORDING
C        TO CHOSEN SIGNATURE CONFIGURATIONS ( IN CASE OF NO PAIRING ).
C        IT ALSO CALCULATES THE LOWEST SIGNATURE CONFIGURATIONS FOR A
C        GIVEN SINGLE-PARTICLE SPECTRUM.
C
C=======================================================================
C
C=======================================================================
C         ZEROING OCCUPATION FACTORS AND THE VACUUM CONFIGURATION DATA
C=======================================================================
C
C
      DO IREVER=0,NDREVE
C
         OCCFIL(0,IREVER)=0.0D0
         OCCFIL(1,IREVER)=0.0D0
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=0.0
C
            NMOCVA(ISTATE,0,IREVER)=0
            NMOCVA(ISTATE,1,IREVER)=0
C
         END DO
C
      END DO
C
C=======================================================================
C         SETTING THE OCCUPATION FACTORS ACCORDING TO THE CONFIGURATION
C=======================================================================
C
      DO IREVER=0,MREVER
C
         NPAPLU=0
         NPAMIN=0
C
         OCCFIL(0,IREVER)=0.0D0
         OCCFIL(1,IREVER)=0.0D0
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF (PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1))).GT.0.0)
     *                                                              THEN
C
                NPAPLU=NPAPLU+1
C
                VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *                 NMOCCU(NPAPLU,0,IREVER)
C
                IF (NOMILG(0,IREVER).GE.1) THEN
C
                    IF (NPAPLU.GE.NHMILG(0,IREVER).AND.
     *                  NPAPLU.LE.NPMILG(0,IREVER))
     *
     *                  VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *                         VFIMIG(NPAPLU,0,IREVER)
C
                END IF
C
                OCCFIL(0,IREVER)=OCCFIL(0,IREVER)
     *             +VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))**2
C
            ELSE
C
                NPAMIN=NPAMIN+1
C
                VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *                 NMOCCU(NPAMIN,1,IREVER)
C
                IF (NOMILG(1,IREVER).GE.1) THEN
C
                    IF (NPAMIN.GE.NHMILG(1,IREVER).AND.
     *                  NPAMIN.LE.NPMILG(1,IREVER))
     *
     *                  VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *                         VFIMIG(NPAMIN,1,IREVER)
C
                END IF
C
                OCCFIL(1,IREVER)=OCCFIL(1,IREVER)
     *             +VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))**2
C
            END IF
C
         END DO
C
C=======================================================================
C         THE TEST BELOW ENSURES THAT THE NUMBER OF STATES KEPT AFTER
C         THE DIAGONALIZATION IS SUFFICIENT TO ACCOMODATE ALL  STATES
C         OCCUPIED IN EACH OF THE PARITY BLOCKS. THE TEST CAN ONLY BE
C         PERFORMED IN THIS PLACE, BECAUSE THE NUMBER OF STATES  KEPT
C         AFTER THE DIAGONALIZATION DEPENDS ON THE  ENERGY  SPECTRUM,
C         AND THE NUMBERS OF STATES KEPT IN EACH PARITY ARE NOT KNOWN
C         BEFORE THE SPECTRUM IS CALCULATED.
C=======================================================================
C         THE TEST BELOW CAN  BE  PERFORMED  ONLY  WHEN  THE  FILLING
C         APPROXIMATION HAS NOT BEEN REQUESTED
C=======================================================================
C
         IF ((NOMILG(0,0).LT.1 .AND.
     *        NOMILG(0,1).LT.1.OR.MREVER.EQ.0).AND.
     *      ABS(OCCFIL(0,IREVER)
     *         -NOCMIG(0,IREVER)).GT.1.0E-12.OR.
     *       (NOMILG(1,0).LT.1 .AND.
     *        NOMILG(1,1).LT.1.OR.MREVER.EQ.0).AND.
     *      ABS(OCCFIL(1,IREVER)
     *         -NOCMIG(1,IREVER)).GT.1.0E-12) THEN
C
             WRITE(NFIPRI,'(
     *            1X,20(1H/),''  MESSAGE FROM CONMIG FOR IC'',
     *                       ''HARG = '',I1,1H:, 1X,20(1H/),/
     *            1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                       ''EAN-FIELD'',      1X,20(1H/),/
     *            1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                       ''IZATION 1'',      1X,20(1H/),/
     *            1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                       ''IX IN THE'',      1X,20(1H/),/
     *            1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                       ''         '',      1X,20(1H/),/)')
     *            ICHARG
C
             STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIG)1'
C
         END IF
C
      END DO
C
C=======================================================================
C         THE TEST BELOW CAN BE PERFORMED IN CASE  WHEN  THE  FILLING
C         APPROXIMATION HAS BEEN REQUESTED
C=======================================================================
C
C     DO IPARIT=0,NDPARI
C        DO IREVER=0,MREVER
C
C           PRINT '(3I5,F7.3)',IPARIT,IREVER,
C    *                  NOFILG(IPARIT,IREVER,ICHARG),
C    *                  OCCFIL(IPARIT,IREVER)
C
C        END DO
C     END DO
C
      IF ( ((NOMILG(0,0).GE.1.OR.NOMILG(0,1).GE.1).AND.
     *                                              MREVER.EQ.1).AND.
     *   ABS(OCCFIL(0,0)+OCCFIL(0,1)
     *      -NOCMIG(0,0)-NOCMIG(0,1)).GT.1.0E-12.OR.
     *     ((NOMILG(1,0).GE.1.OR.NOMILG(1,1).GE.1).AND.
     *                                              MREVER.EQ.1).AND.
     *   ABS(OCCFIL(1,0)+OCCFIL(1,1)
     *      -NOCMIG(1,0)-NOCMIG(1,1)).GT.1.0E-12) THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONMIG FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/
     *         1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                    ''EAN-FIELD'',      1X,20(1H/),/
     *         1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                    ''IZATION 4'',      1X,20(1H/),/
     *         1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                    ''IX IN THE'',      1X,20(1H/),/
     *         1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                    ''         '',      1X,20(1H/),/)')
     *         ICHARG
C
          STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIG)4'
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (SINGLE-PAIR CASE)
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          DO IREVER=0,MREVER
C
             NPAPLU=0
             NPAMIN=0
C
             JSPFLI=0
             JSHFLI=0
C
             OBPFLI=0.0D0
             OBHFLI=0.0D0
C
             DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "IFLIPI" CONTROL VARIABLE.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
                IF (ABS(IFLIPI).EQ. 1)
     *              OBSFLI=PNALIG(ISTATE
     *                           +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).EQ. 2)
     *              OBSFLI=PNSPAL(ISTATE
     *                           +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).EQ. 9)
     *              OBSFLI=PNMO20(ISTATE
     *                           +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).EQ.10)
     *              OBSFLI=PNMO22(ISTATE
     *                           +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).EQ.11)
     *              OBSFLI=PNISOS(ISTATE
     *                           +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).GT.11.OR.
     *             (ABS(IFLIPI).GE. 3.AND.ABS(IFLIPI).LE.8))
     *              STOP ' IFLIPI OUT OF RANGE IN CONMIG'
C
                IF (PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                     .GT.0.0) THEN
C
                    NPAPLU=NPAPLU+1
C
C=======================================================================
C                   SELECTING INDICES IN THE POSITIVE PARITY BLOCK
C=======================================================================
C
                    IF (IPAFLI.EQ.0.AND.IREVER.EQ.IREFLI) THEN
C
                        IF (NPAPLU.EQ.ISPFLI) THEN
                            OBPFLI=OBSFLI
                            JSPFLI=ISTATE
                        END IF
C
                        IF (NPAPLU.EQ.ISHFLI) THEN
                            OBHFLI=OBSFLI
                            JSHFLI=ISTATE
                        END IF
C
                    END IF
C
                ELSE
C
                    NPAMIN=NPAMIN+1
C
C=======================================================================
C                   SELECTING INDICES IN THE NEGATIVE PARITY BLOCK
C=======================================================================
C
                    IF (IPAFLI.EQ.1.AND.IREVER.EQ.IREFLI) THEN
C
                        IF (NPAMIN.EQ.ISPFLI) THEN
                            OBPFLI=OBSFLI
                            JSPFLI=ISTATE
                        END IF
C
                        IF (NPAMIN.EQ.ISHFLI) THEN
                            OBHFLI=OBSFLI
                            JSHFLI=ISTATE
                        END IF
C
                    END IF
C
                END IF
C
             END DO
C
             IF (IREVER.EQ.IREFLI) THEN
C
C=======================================================================
C            PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
                 IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                     WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONMIG'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              ''        '',3X,''   IPAFLI='',I3,''   IREFLI='',I3,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ISPFLI='',I3,''   ISHFLI='',I3,''   IFLIPI='',I3,
     *                                          2X,20(1H/))')
     *                      IPAFLI,IREFLI,
     *               ISPFLI,ISHFLI,IFLIPI
C
                     WRITE(NFIPRI,'(
     *                    1X,20(1H/),''  MESSAGE FROM CONMIG FOR IC'',
     *                               ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                    1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                               ''EAN-FIELD'',      1X,20(1H/),/
     *                    1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                               ''IZATION 2'',      1X,20(1H/),/
     *                    1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                               ''IX IN THE'',      1X,20(1H/),/
     *                    1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                               ''         '',      1X,20(1H/),/)')
     *                    ICHARG
C
                     STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIG)2'
C
                 ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "IFLIPI" CONTROL VARIABLE ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE
C=======================================================================
C
                     IF ((IFLIPI.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *                   (IFLIPI.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                         VMOCCU(JSPFLI+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                  =NMOCCU(ISHFLI,IPAFLI,IREVER)
C
                         VMOCCU(JSHFLI+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                  =NMOCCU(ISPFLI,IPAFLI,IREVER)
C
                     END IF
C
                 END IF
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (ALL-BLOCKS CASE)
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,MREVER
C
            NPARTY=0
C
            JSPFLI=0
            JSHFLI=0
C
            OBPFLI=0.0D0
            OBHFLI=0.0D0
C
            DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "NOFLIG"  MATRIX ELEMENTS.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
               IF ((IPARIT.EQ.0.AND.
     *              PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                      .GT.0.0).OR.
     *             (IPARIT.EQ.1.AND.
     *              PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                    .LT.0.0)) THEN
C
                   NPARTY=NPARTY+1
C
C=======================================================================
C                  SELECTING INDICES IN THE GIVEN
C                  PARITY/SIGNATURE/CHARGE  BLOCK
C=======================================================================
C
                   IF (NOMLIG(IPARIT,IREVER).NE.0) THEN
C
                       IF (ABS(NOMLIG(IPARIT,IREVER)).EQ. 1)
     *                     OBSFLI=PNALIG(ISTATE
     *                            +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                       IF (ABS(NOMLIG(IPARIT,IREVER)).EQ. 2)
     *                     OBSFLI=PNSPAL(ISTATE
     *                            +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                       IF (ABS(NOMLIG(IPARIT,IREVER)).EQ. 9)
     *                     OBSFLI=PNMO20(ISTATE
     *                            +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                       IF (ABS(NOMLIG(IPARIT,IREVER)).EQ.10)
     *                     OBSFLI=PNMO22(ISTATE
     *                            +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                       IF (ABS(NOMLIG(IPARIT,IREVER)).EQ.11)
     *                     OBSFLI=PNISOS(ISTATE
     *                            +IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                       IF (ABS(NOMLIG(IPARIT,IREVER)).GT.11.OR.
     *                    (ABS(NOMLIG(IPARIT,IREVER)).GE. 3.AND.
     *                     ABS(NOMLIG(IPARIT,IREVER)).LE. 8))
     *                     STOP ' NOMLIG OUT OF RANGE IN CONMIG'
C
                       IF (NPARTY.EQ.NPMLIG(IPARIT,IREVER))
     *                 THEN
                           OBPFLI=OBSFLI
                           JSPFLI=ISTATE
                       END IF
C
                       IF (NPARTY.EQ.NHMLIG(IPARIT,IREVER))
     *                 THEN
                           OBHFLI=OBSFLI
                           JSHFLI=ISTATE
                       END IF
C
                   END IF
C
               END IF
C
            END DO
C
            IF (NOMLIG(IPARIT,IREVER).NE.0) THEN
C
C=======================================================================
C               PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
                IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                    WRITE(NFIPRI,'(/,1X,20(1H/),
     *           '' ERROR IN DIABATIC BLOCKING IN CONMIG'',
     *                                       2X,20(1H/),/,1X,20(1H/),
     *           ''        '',3X,''   IPARIT='',I3,''   IREVER='',I3,
     *                                       2X,20(1H/),/,1X,20(1H/),
     *           '' NPMLIG='',I3,''   NHMLIG='',I3,''   NOMLIG='',I3,
     *                                       2X,20(1H/))')
     *              IPARIT,IREVER,
     *              NPMLIG(IPARIT,IREVER),
     *              NHMLIG(IPARIT,IREVER),
     *              NOMLIG(IPARIT,IREVER)
C
                    WRITE(NFIPRI,'(
     *                   1X,20(1H/),''  MESSAGE FROM CONMIG FOR IC'',
     *                              ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                   1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                              ''EAN-FIELD'',      1X,20(1H/),/
     *                   1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                              ''IZATION 3'',      1X,20(1H/),/
     *                   1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                              ''IX IN THE'',      1X,20(1H/),/
     *                   1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                              ''         '',      1X,20(1H/),/)')
     *                   ICHARG
C
                    STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIG)3'
C
                ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "NOFLIG" MATRIX ELEMENTS  ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE, AND VICE VERSA.
C=======================================================================
C
                    IF ((NOMLIG(IPARIT,IREVER).GT.0.AND.
     *                   OBPFLI.GT.OBHFLI).OR.
     *                  (NOMLIG(IPARIT,IREVER).LT.0.AND.
     *                   OBPFLI.LT.OBHFLI)) THEN
C
                        VMOCCU(JSPFLI+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *                           NMOCCU(NHMLIG(IPARIT,IREVER),
     *                                         IPARIT,IREVER)
                        VMOCCU(JSHFLI+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *                           NMOCCU(NPMLIG(IPARIT,IREVER),
     *                                         IPARIT,IREVER)
C
                    END IF
C
                END IF
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         DETERMINING THE ORDERED SINGLE-PARTICLE SPECTRUM AND THE FERMI
C         ENERGY
C=======================================================================
C
      IORDER=0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IORDER=IORDER+1
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=PNENER(ISTATE+IREVER
     *                                  *(NUMBSP(0,0)+NUMBSP(0,1)))
C
         END DO
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
      NUMACT=IN_FIX+IZ_FIX
C
      IF (MREVER.EQ.0) THEN
C
          IF (MOD(IN_FIX+IZ_FIX,2).NE.0)
     *    STOP ' ODD IN_FIX+IZ_FIX IN CONMIG'
          NUMACT=(IN_FIX+IZ_FIX)/2
C
      END IF
C
      EFERMI=0.5*(EORDER(NUMACT+1)+EORDER(NUMACT))
C
C=======================================================================
C         CALCULATING THE NUMBERS OF OCCUPIED STATES IN EVERY
C         PARITY/TIME-REVERSAL BLOCK
C=======================================================================
C
      IPARTI=0
C
      DO IREVER=0,MREVER
C
         NPAPLU=0
         NPAMIN=0
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF (PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                             .LT.EFERMI) THEN
C
                IPARTI=IPARTI+1
C
                IF (PNPARI(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                     .GT.0.0) THEN
C
                    NPAPLU=NPAPLU+1
                    NMOCVA(NPAPLU,0,IREVER)=1
C
                ELSE
C
                    NPAMIN=NPAMIN+1
                    NMOCVA(NPAMIN,1,IREVER)=1
C
                END IF
C
            END IF
C
         END DO
C
      END DO
C
C=======================================================================
C        IN CASE OF DEGENERATE STATES AT THE FERMI  ENERGY  THE
C        CONFIGURATION DATA ARE SET TO 100 TO OBTAIN  ASTERISKS
C        ON THE OUTPUT. A BETTER TREATMENT OF SUCH A DEGENERACY
C        IS STILL TO BE FOUND.
C=======================================================================
C
      IF (IPARTI.NE.NUMACT) THEN
C
          DO IREVER=0,MREVER
C
             DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
                NMOCVA(ISTATE,0,IREVER)=100
                NMOCVA(ISTATE,1,IREVER)=100
C
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CONMIM(MREVER,IN_FIX,IZ_FIX,EFERMI,
     *                                       IREFLI,
     *                         ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          EORDER(1:4*NDBASE),NORDER(1:4*NDBASE)
      DIMENSION
     *          NOCCUP(0:NDREVE)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNMOME/ PNMO20(1:4*NDSTAT),
     *                PNMO22(1:4*NDSTAT)
      COMMON
     *       /MIMOCC/ LMOCCU(1:2*NDSTAT,0:NDREVE),
     *                LMOCVA(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /MIMNVA/ NVAMIM(0:NDREVE)
      COMMON
     *       /N_MLIM/ NPMLIM(0:NDREVE),
     *                NHMLIM(0:NDREVE),
     *                NOMLIM(0:NDREVE)
      COMMON
     *       /MIOCCU/ VMOCCU(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C         THIS SUBROUTINE IS CALLED IN THE CASE OF CONSERVATION OF THE
C         SIMPLEX SYMMETRY AND PROTON-NEUTRON MIXING INCLUDED.
C         IT SETS THE OCCUPATION  FACTORS  ACCORDING
C         TO THE CHOSEN SIMPLEX CONFIGURATIONS (IN CASE OF NO PAIRING).
C         IT ALSO CALCULATES THE LOWEST - SIMPLEX  CONFIGURATION FOR A
C         GIVEN SINGLE-PARTICLE SPECTRUM.
C
C=======================================================================
C
C=======================================================================
C         ZEROING OCCUPATION FACTORS AND THE VACUUM CONFIGURATION DATA
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=0.0
C
            LMOCVA(ISTATE,IREVER)=0
C
         END DO
C
      END DO
C
C=======================================================================
C         SETTING THE OCCUPATION FACTORS ACCORDING TO THE CONFIGURATION
C=======================================================================
C
      DO IREVER=0,MREVER
C
         NOCCUP(IREVER)=0
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            NOCCUP(IREVER)=NOCCUP(IREVER)+
     *               LMOCCU(ISTATE,IREVER)
C
            VMOCCU(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *               LMOCCU(ISTATE,IREVER)
C
         END DO
C
      END DO
C
C=======================================================================
C         THE TEST BELOW ENSURES THAT THE NUMBER OF STATES KEPT AFTER
C         THE DIAGONALIZATION IS SUFFICIENT TO ACCOMODATE ALL  STATES
C         OCCUPIED IN EACH OF THE SIMPLEX BLOCKS. THE TEST COULD HAVE
C         BEEN PERFORMED IN ANOTHER PLACE, HOWEVER, IT  IS  PERFORMED
C         HERE TO KEEP CONSISTENCY WITH OTHER SYMMETRIES.
C=======================================================================
C
      DO IREVER=0,MREVER
C
         IF (NOCCUP(IREVER).NE.NVAMIM(IREVER)) THEN
C
             WRITE(NFIPRI,'(
     *            1X,20(1H/),''  MESSAGE FROM CONMIM FOR IC'',
     *                       ''HARG = '',I1,1H:, 1X,20(1H/),/
     *            1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                       ''EAN-FIELD'',      1X,20(1H/),/
     *            1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                       ''IZATION 1'',      1X,20(1H/),/
     *            1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                       ''IX IN THE'',      1X,20(1H/),/
     *            1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                       ''         '',      1X,20(1H/),/)')
     *            ICHARG
C
             STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIM)1'
C
         END IF
C
      END DO
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          DO IREVER=0,MREVER
C
             JSPFLI=0
             JSHFLI=0
C
             OBPFLI=0.0D0
             OBHFLI=0.0D0
C
             DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "IFLIPI" CONTROL VARIABLE.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
                IF (ABS(IFLIPI).EQ. 1)
     *              OBSFLI=PNALIG(ISTATE+IREVER
     *                                *(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).EQ. 2)
     *              OBSFLI=PNSPAL(ISTATE+IREVER
     *                                *(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).EQ. 9)
     *              OBSFLI=PNMO20(ISTATE+IREVER
     *                                *(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).EQ.10)
     *              OBSFLI=PNMO22(ISTATE+IREVER
     *                                *(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).EQ.11)
     *              OBSFLI=PNISOS(ISTATE+IREVER
     *                                *(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(IFLIPI).GT.11.OR.
     *             (ABS(IFLIPI).GE. 3.AND.ABS(IFLIPI).LE.8))
     *              STOP ' IFLIPI OUT OF RANGE IN CONMIM'
C
C=======================================================================
C               SELECTING INDICES
C=======================================================================
C
                IF (IREVER.EQ.IREFLI) THEN
C
                    IF (ISTATE.EQ.ISPFLI) THEN
                        OBPFLI=OBSFLI
                        JSPFLI=ISTATE
                    END IF
C
                    IF (ISTATE.EQ.ISHFLI) THEN
                        OBHFLI=OBSFLI
                        JSHFLI=ISTATE
                    END IF
C
                END IF
C
             END DO
C
             IF (IREVER.EQ.IREFLI) THEN
C
C=======================================================================
C            A WARNING IS ISSUED IF THE INDICES HAVE NOT BEEN SELECTED
C=======================================================================
C
                 IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                     WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONMIM'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              ''          '',3X,''        '',3X,''   IREFLI='',I3,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' ISPFLI='',I3,''   ISHFLI='',I3,''   IFLIPI='',I3,
     *                                          2X,20(1H/))')
     *                             IREFLI,
     *               ISPFLI,ISHFLI,IFLIPI
C
                     WRITE(NFIPRI,'(
     *                    1X,20(1H/),''  MESSAGE FROM CONMIM FOR IC'',
     *                               ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                    1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                               ''EAN-FIELD'',      1X,20(1H/),/
     *                    1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                               ''IZATION 2'',      1X,20(1H/),/
     *                    1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                               ''IX IN THE'',      1X,20(1H/),/
     *                    1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                               ''         '',      1X,20(1H/),/)')
     *                    ICHARG
C
                     STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIM)2'
C
                 ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "IFLIPI" CONTROL VARIABLE ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE
C=======================================================================
C
                     IF ((IFLIPI.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *                   (IFLIPI.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                         VMOCCU(JSPFLI+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                               =LMOCCU(ISHFLI,IREVER)
                         VMOCCU(JSHFLI+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                               =LMOCCU(ISPFLI,IREVER)
C
                     END IF
C
                 END IF
C
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (ALL-BLOCKS CASE)
C=======================================================================
C
      DO IREVER=0,MREVER
C
         JSPFLI=0
         JSHFLI=0
C
         OBPFLI=0.0D0
         OBHFLI=0.0D0
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "NOFLIM"  MATRIX ELEMENTS.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
C=======================================================================
C                   SELECTING INDICES IN THE GIVEN
C                   SIMPLEX  BLOCK
C=======================================================================
C
            IF (NOMLIM(IREVER).NE.0) THEN
C
                IF (ABS(NOMLIM(IREVER)).EQ. 1)
     *            OBSFLI=PNALIG(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(NOMLIM(IREVER)).EQ. 2)
     *            OBSFLI=PNSPAL(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(NOMLIM(IREVER)).EQ. 9)
     *            OBSFLI=PNMO20(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(NOMLIM(IREVER)).EQ.10)
     *            OBSFLI=PNMO22(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(NOMLIM(IREVER)).EQ.11)
     *            OBSFLI=PNISOS(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
C
                IF (ABS(NOMLIM(IREVER)).GT.11.OR.
     *             (ABS(NOMLIM(IREVER)).GE. 3.AND.
     *              ABS(NOMLIM(IREVER)).LE. 8))
     *              STOP ' NOMLIM OUT OF RANGE IN CONMIM'
C
                IF (ISTATE.EQ.NPMLIM(IREVER)) THEN
                    OBPFLI=OBSFLI
                    JSPFLI=ISTATE
                END IF
C
                IF (ISTATE.EQ.NHMLIM(IREVER)) THEN
                    OBHFLI=OBSFLI
                    JSHFLI=ISTATE
                END IF
C
            END IF
C
         END DO
C
         IF (NOMLIM(IREVER).NE.0) THEN
C
C=======================================================================
C              A WARNING IS ISSUED IF THE INDICES HAVE NOT BEEN SELECTED
C=======================================================================
C
             IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                 WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONMIM'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              ''        '',3X,''          '',3X,''   IREVER='',I3,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' NPMLIM='',I3,''   NHMLIM='',I3,''   NOMLIM='',I3,
     *                                          2X,20(1H/))')
     *           IREVER,
     *           NPMLIM(IREVER),
     *           NHMLIM(IREVER),
     *           NOMLIM(IREVER)
C
                 WRITE(NFIPRI,'(
     *                1X,20(1H/),''  MESSAGE FROM CONMIM FOR IC'',
     *                           ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                           ''EAN-FIELD'',      1X,20(1H/),/
     *                1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                           ''IZATION 3'',      1X,20(1H/),/
     *                1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                           ''IX IN THE'',      1X,20(1H/),/
     *                1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                           ''         '',      1X,20(1H/),/)')
     *                ICHARG
C
                 STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIM)3'
C
             ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "NOMLIM" MATRIX ELEMENTS  ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE, AND VICE VERSA.
C=======================================================================
C
                 IF ((NOMLIM(IREVER).GT.0.AND.
     *                OBPFLI.GT.OBHFLI).OR.
     *               (NOMLIM(IREVER).LT.0.AND.
     *                OBPFLI.LT.OBHFLI)) THEN
C
                     VMOCCU(JSPFLI+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *                    LMOCCU(NHMLIM(IREVER),IREVER)
                     VMOCCU(JSHFLI+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))=
     *                    LMOCCU(NPMLIM(IREVER),IREVER)
C
                 END IF
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C        DETERMINING THE ORDERED SINGLE-PARTICLE SPECTRUM AND
C        THE FERMI ENERGY
C=======================================================================
C
      IORDER=0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IORDER=IORDER+1
            NORDER(IORDER)=IORDER
            EORDER(IORDER)=PNENER(ISTATE+IREVER
     *                                       *(NUMBSP(0,0)+NUMBSP(0,1)))
C
         END DO
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
      NUMACT=IN_FIX+IZ_FIX
C
      IF (MREVER.EQ.0) THEN
C
          IF (MOD(IN_FIX+IZ_FIX,2).NE.0)
     *           STOP ' ODD IN_FIX+IZ_FIX IN CONMIM'
          NUMACT=(IN_FIX+IZ_FIX)/2
C
      END IF
C
      EFERMI=0.5*(EORDER(NUMACT+1)+EORDER(NUMACT))
C
C=======================================================================
C         CALCULATING THE NUMBERS OF OCCUPIED STATES IN EVERY
C         SIMPLEX BLOCK
C=======================================================================
C
      IPARTI=0
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF (PNENER(ISTATE+IREVER*(NUMBSP(0,0)+NUMBSP(0,1)))
     *                                                  .LT.EFERMI) THEN
C
                IPARTI=IPARTI+1
C
                LMOCVA(ISTATE,IREVER)=1
C
            END IF
C
         END DO
C
      END DO
C
C=======================================================================
C        IN CASE OF DEGENERATE STATES AT THE FERMI  ENERGY  THE
C        CONFIGURATION DATA ARE SET TO 100 TO OBTAIN  ASTERISKS
C        ON THE OUTPUT. A BETTER TREATMENT OF SUCH A DEGENERACY
C        IS STILL TO BE FOUND.
C=======================================================================
C
      IF (IPARTI.NE.NUMACT) THEN
C
          DO IREVER=0,MREVER
C
             DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
                LMOCVA(ISTATE,IREVER)=100
C
             END DO
C
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CONMIQ(IN_FIX,IZ_FIX,EFERMI,IPAFLI,
     *                                ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNSTAT/ PNXALI(1:4*NDSTAT),
     *                PNZALI(1:4*NDSTAT),
     *                PNXSPI(1:4*NDSTAT),
     *                PNZSPI(1:4*NDSTAT)
      COMMON
     *       /PNMOME/ PNMO20(1:4*NDSTAT),
     *                PNMO22(1:4*NDSTAT)
      COMMON
     *       /MIQNOC/ NOCMIQ(0:NDPARI)
      COMMON
     *       /MIQOCC/ KMOCCU(1:4*NDSTAT,0:NDPARI),
     *                KMOCVA(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /N_MLIQ/ NPMLIQ(0:NDPARI),
     *                NHMLIQ(0:NDPARI),
     *                NOMLIQ(0:NDPARI)
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /MIOCCU/ VMOCCU(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C         THIS SUBROUTINE IS CALLED IN THE CASE OF CONSERVATION OF THE
C         PARITY SYMMETRY AND PROTON-NEUTRON MIXING INCLUDED
C         IT SETS THE OCCUPATION  FACTORS  ACCORDING
C         TO THE CHOSEN PARITY CONFIGURATIONS (IN CASE OF NO PAIRING).
C         IT ALSO CALCULATES THE LOWEST - PARITY  CONFIGURATION FOR A
C         GIVEN SINGLE-PARTICLE SPECTRUM.
C
C=======================================================================
C         ZEROING OCCUPATION FACTORS AND THE VACUUM CONFIGURATION DATA
C=======================================================================
C
      DO ISTATE=1,4*NDSTAT
         VMOCCU(ISTATE)=0.0
      END DO
C
      DO IPARIT=0,NDPARI
         DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
            KMOCVA(ISTATE,IPARIT)=0
C
         END DO
      END DO
C
C=======================================================================
C         DETERMINING THE FERMI ENERGY
C=======================================================================
C
      EFERMI=0.5*(PNENER(IN_FIX+IZ_FIX+1)+PNENER(IN_FIX+IZ_FIX))
C
C=======================================================================
C         SETTING THE OCCUPATION FACTORS ACCORDING TO THE CONFIGURATION
C         AND CALCULATING THE VACUUM CONFIGURATION  TOGETHER  WITH  THE
C         NUMBERS OF OCCUPIED STATES IN EACH PARITY
C=======================================================================
C
      NPAPLU=0
      NPAMIN=0
C
      NOCPLU=0
      NOCMIN=0
C
      IPARTI=0
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         IF (PNPARI(ISTATE).GT.0.0) THEN
C
             NPAPLU=NPAPLU+ 1
             NOCPLU=NOCPLU+ KMOCCU(NPAPLU,0)
C
             VMOCCU(ISTATE)=KMOCCU(NPAPLU,0)
C
             IF (PNENER(ISTATE).LT.EFERMI) THEN
C
                 KMOCVA(NPAPLU,0)=1
                 IPARTI=IPARTI+1
C
             END IF
C
         ELSE
C
             NPAMIN=NPAMIN+ 1
             NOCMIN=NOCMIN+ KMOCCU(NPAMIN,1)
C
             VMOCCU(ISTATE)=KMOCCU(NPAMIN,1)
C
             IF (PNENER(ISTATE).LT.EFERMI) THEN
C
                 KMOCVA(NPAMIN,1)=1
                 IPARTI=IPARTI+1
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C         THE TEST BELOW ENSURES THAT THE NUMBER OF STATES KEPT AFTER
C         THE DIAGONALIZATION IS SUFFICIENT TO ACCOMODATE ALL  STATES
C         OCCUPIED IN EACH OF THE PARITY BLOCKS. THE TEST CAN ONLY BE
C         PERFORMED IN THIS PLACE, BECAUSE THE NUMBER OF STATES  KEPT
C         AFTER THE DIAGONALIZATION DEPENDS ON THE  ENERGY  SPECTRUM,
C         AND THE NUMBERS OF STATES KEPT IN EACH PARITY ARE NOT KNOWN
C         BEFORE THE SPECTRUM IS CALCULATED.
C=======================================================================
C
      IF (NOCPLU.NE.NOCMIQ(0).OR.NOCMIN.NE.NOCMIQ(1)) THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONMIQ FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/
     *         1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                    ''EAN-FIELD'',      1X,20(1H/),/
     *         1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                    ''IZATION 1'',      1X,20(1H/),/
     *         1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                    ''IX IN THE'',      1X,20(1H/),/
     *         1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                    ''         '',      1X,20(1H/),/)')
     *         ICHARG
C
          STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIQ)1'
C
      END IF
C
C=======================================================================
C        IN CASE OF DEGENERATE STATES AT THE FERMI  ENERGY  THE
C        CONFIGURATION DATA ARE SET TO 100 TO OBTAIN  ASTERISKS
C        ON THE OUTPUT. A BETTER TREATMENT OF SUCH A DEGENERACY
C        IS STILL TO BE FOUND.
C=======================================================================
C
      IF (IPARTI.NE.IN_FIX+IZ_FIX) THEN
C
          DO IPARIT=0,NDPARI
             DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
                KMOCVA(ISTATE,IPARIT)=100
C
             END DO
          END DO
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (SINGLE-PAIR CASE)
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          NPAPLU=0
          NPAMIN=0
C
          JSPFLI=0
          JSHFLI=0
C
          OBPFLI=0.0D0
          OBHFLI=0.0D0
C
          DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "IFLIPI" CONTROL VARIABLE.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
             IF (ABS(IFLIPI).EQ. 1) OBSFLI=PNALIG(ISTATE)
             IF (ABS(IFLIPI).EQ. 2) OBSFLI=PNSPAL(ISTATE)
             IF (ABS(IFLIPI).EQ. 3) OBSFLI=PNXALI(ISTATE)
             IF (ABS(IFLIPI).EQ. 4) OBSFLI=PNXSPI(ISTATE)
             IF (ABS(IFLIPI).EQ. 5) OBSFLI=PNZALI(ISTATE)
             IF (ABS(IFLIPI).EQ. 6) OBSFLI=PNZSPI(ISTATE)
C
             IF (ABS(IFLIPI).EQ. 7) OBSFLI=PNXALI(ISTATE)*OMOVAX
     *                                    +PNALIG(ISTATE)*OMOVAY
     *                                    +PNZALI(ISTATE)*OMOVAZ
C
             IF (ABS(IFLIPI).EQ. 8) OBSFLI=PNXSPI(ISTATE)*OMOVAX
     *                                    +PNSPAL(ISTATE)*OMOVAY
     *                                    +PNZSPI(ISTATE)*OMOVAZ
C
             IF (ABS(IFLIPI).EQ. 9) OBSFLI=PNMO20(ISTATE)
             IF (ABS(IFLIPI).EQ.10) OBSFLI=PNMO22(ISTATE)
C
             IF (ABS(IFLIPI).EQ.11) OBSFLI=PNISOS(ISTATE)
C
             IF (ABS(IFLIPI).GT.11) STOP ' IFLIPI TOO LARGE IN CONMIQ'
C
C=======================================================================
C
             IF (PNPARI(ISTATE).GT.0.0) THEN
C
                 NPAPLU=NPAPLU+1
C
C=======================================================================
C                   SELECTING INDICES IN THE POSITIVE PARITY BLOCK
C=======================================================================
C
                 IF (IPAFLI.EQ.0) THEN
C
                     IF (NPAPLU.EQ.ISPFLI) THEN
                         OBPFLI=OBSFLI
                         JSPFLI=ISTATE
                     END IF
C
                     IF (NPAPLU.EQ.ISHFLI) THEN
                         OBHFLI=OBSFLI
                         JSHFLI=ISTATE
                     END IF
C
                 END IF
C
             ELSE
C
                 NPAMIN=NPAMIN+1
C
C=======================================================================
C                   SELECTING INDICES IN THE NEGATIVE PARITY BLOCK
C=======================================================================
C
                 IF (IPAFLI.EQ.1) THEN
C
                     IF (NPAMIN.EQ.ISPFLI) THEN
                         OBPFLI=OBSFLI
                         JSPFLI=ISTATE
                     END IF
C
                     IF (NPAMIN.EQ.ISHFLI) THEN
                         OBHFLI=OBSFLI
                         JSHFLI=ISTATE
                     END IF
C
                 END IF
C
             END IF
C
          END DO
C
C
C=======================================================================
C            PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
          IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
              WRITE(NFIPRI,'(/,1X,20(1H/),
     *          '' ERROR IN DIABATIC BLOCKING IN CONMIQ'',
     *                                      2X,20(1H/),/,1X,20(1H/),
     *          ''        '',3X,''   IPAFLI='',I3,''          '',3X,
     *                                      2X,20(1H/),/,1X,20(1H/),
     *          '' ISPFLI='',I3,''   ISHFLI='',I3,''   IFLIPI='',I3,
     *                                      2X,20(1H/))')
     *        IPAFLI,
     *        ISPFLI,ISHFLI,IFLIPI
C
              WRITE(NFIPRI,'(
     *             1X,20(1H/),''  MESSAGE FROM CONMIQ FOR IC'',
     *                        ''HARG = '',I1,1H:, 1X,20(1H/),/
     *             1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                        ''EAN-FIELD'',      1X,20(1H/),/
     *             1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                        ''IZATION 2'',      1X,20(1H/),/
     *             1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                        ''IX IN THE'',      1X,20(1H/),/
     *             1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                        ''         '',      1X,20(1H/),/)')
     *             ICHARG
C
              STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIQ)2'
C
          ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "IFLIPI" CONTROL VARIABLE ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE
C=======================================================================
C
              IF ((IFLIPI.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *            (IFLIPI.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                  VMOCCU(JSPFLI)=KMOCCU(ISHFLI,IPAFLI)
                  VMOCCU(JSHFLI)=KMOCCU(ISPFLI,IPAFLI)
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (ALL-BLOCKS CASE)
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
         NPARTY=0
C
         JSPFLI=0
         JSHFLI=0
C
         OBPFLI=0.0D0
         OBHFLI=0.0D0
C
         DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
C=======================================================================
C           FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C           BY THE ABSOLUTE VALUE OF THE  "NOFLIQ"  MATRIX ELEMENTS.
C           SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
            IF ((IPARIT.EQ.0.AND.PNPARI(ISTATE).GT.0.0).OR.
     *          (IPARIT.EQ.1.AND.PNPARI(ISTATE).LT.0.0)) THEN
C
                NPARTY=NPARTY+1
C
C=======================================================================
C               SELECTING INDICES IN THE GIVEN PARITY BLOCK
C=======================================================================
C
                IF (NOMLIQ(IPARIT).NE.0) THEN
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 1)
     *                  OBSFLI=PNALIG(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 2)
     *                  OBSFLI=PNSPAL(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 3)
     *                  OBSFLI=PNXALI(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 4)
     *                  OBSFLI=PNXSPI(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 5)
     *                  OBSFLI=PNZALI(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 6)
     *                  OBSFLI=PNZSPI(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 7)
     *                  OBSFLI=PNXALI(ISTATE)*OMOVAX
     *                        +PNALIG(ISTATE)*OMOVAY
     *                        +PNZALI(ISTATE)*OMOVAZ
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 8)
     *                  OBSFLI=PNXSPI(ISTATE)*OMOVAX
     *                        +PNSPAL(ISTATE)*OMOVAY
     *                        +PNZSPI(ISTATE)*OMOVAZ
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ. 9)
     *                  OBSFLI=PNMO20(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ.10)
     *                  OBSFLI=PNMO22(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).EQ.11)
     *                  OBSFLI=PNISOS(ISTATE)
C
                    IF (ABS(NOMLIQ(IPARIT)).GT.11)
     *                  STOP ' NOMLIQ TOO LARGE IN CONMIQ'
C
C=======================================================================
C
                    IF (NPARTY.EQ.NPMLIQ(IPARIT)) THEN
                        OBPFLI=OBSFLI
                        JSPFLI=ISTATE
                    END IF
C
                    IF (NPARTY.EQ.NHMLIQ(IPARIT)) THEN
                        OBHFLI=OBSFLI
                        JSHFLI=ISTATE
                    END IF
C
                END IF
C
            END IF
C
         END DO
C
         IF (NOMLIQ(IPARIT).NE.0) THEN
C
C=======================================================================
C            PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
             IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
                 WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONMIQ'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              ''        '',3X,''   IPARIT='',I3,''          '',3X,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' NPMLIQ='',I3,''   NHMLIQ='',I3,''   NOMLIQ='',I3,
     *                                          2X,20(1H/))')
     *           IPARIT,
     *           NPMLIQ(IPARIT),
     *           NHMLIQ(IPARIT),
     *           NOMLIQ(IPARIT)
C
                 WRITE(NFIPRI,'(
     *                1X,20(1H/),''  MESSAGE FROM CONMIQ FOR IC'',
     *                           ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                           ''EAN-FIELD'',      1X,20(1H/),/
     *                1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                           ''IZATION 3'',      1X,20(1H/),/
     *                1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                           ''IX IN THE'',      1X,20(1H/),/
     *                1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                           ''         '',      1X,20(1H/),/)')
     *                ICHARG
C
                 STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIQ)3'
C
             ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "NOMLIQ" MATRIX ELEMENTS  ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE, AND VICE VERSA.
C=======================================================================
C
                 IF ((NOMLIQ(IPARIT).GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *               (NOMLIQ(IPARIT).LT.0.AND.OBPFLI.LT.OBHFLI))
     *           THEN
C
                     VMOCCU(JSPFLI)=KMOCCU(NHMLIQ(IPARIT),IPARIT)
                     VMOCCU(JSHFLI)=KMOCCU(NPMLIQ(IPARIT),IPARIT)
C
                 END IF
C
             END IF
C
         END IF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE CONMIZ(IN_FIX,IZ_FIX,EFERMI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          EORDER(1:4*NDBASE),NORDER(1:4*NDBASE)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNSTAT/ PNXALI(1:4*NDSTAT),
     *                PNZALI(1:4*NDSTAT),
     *                PNXSPI(1:4*NDSTAT),
     *                PNZSPI(1:4*NDSTAT)
      COMMON
     *       /PNMOME/ PNMO20(1:4*NDSTAT),
     *                PNMO22(1:4*NDSTAT)
      COMMON
     *       /MIZOCC/ MMOCCU(1:4*NDSTAT),
     *                MMOCVA(1:4*NDSTAT)
      COMMON
     *       /MIZNVA/ NVAMIZ
      COMMON
     *       /MIZNOC/ NOCMIZ
      COMMON
     *       /N_MLIZ/ NPMLIZ,
     *                NHMLIZ,
     *                NOMLIZ
      COMMON
     *      /N_MILZ/  NPMILZ,
     *                NHMILZ,
     *                NOMILZ
      COMMON
     *       /MIZFIL/ VFIMIZ(1:4*NDSTAT)
      COMMON
     *       /OMOVAS/ OMOVAX,OMOVAY,OMOVAZ
      COMMON
     *       /MIOCCU/ VMOCCU(1:4*NDSTAT)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE IS CALLED IN THE CASE OF  NO SYMMETRY
C         AND PROTON-NEUTRON MIXING INCLUDED.
C         IT SETS THE OCCUPATION FACTORS ACCORDING TO THE CHOSEN GLOBAL
C         CONFIGURATIONS (IN CASE OF NO PAIRING).
C=======================================================================
C
C=======================================================================
C         ZEROING OCCUPATION FACTORS AND THE VACUUM CONFIGURATION DATA
C=======================================================================
C
C      DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         VMOCCU(ISTATE)=0.0
C
         MMOCVA(ISTATE)=0
C
      END DO
C
C=======================================================================
C         SETTING THE OCCUPATION FACTORS ACCORDING TO THE CONFIGURATION
C=======================================================================
C
      NOCCUP=0
      OCCFIL=0.0D0
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         NOCCUP=NOCCUP+ MMOCCU(ISTATE)
C
         VMOCCU(ISTATE)=MMOCCU(ISTATE)
C
         IF (NOMILZ.GE.1) THEN
C
             IF (ISTATE.GE.NHMILZ.AND.
     *           ISTATE.LE.NPMILZ)
     *
     *           VMOCCU(ISTATE)=VFIMIZ(ISTATE)
C
         END IF
C
         OCCFIL=OCCFIL+VMOCCU(ISTATE)**2
C
      END DO
C
C=======================================================================
C         THE TEST BELOW ENSURES THAT THE NUMBER OF STATES KEPT AFTER
C         THE DIAGONALIZATION IS SUFFICIENT TO ACCOMODATE ALL  STATES
C         OCCUPIED IN EACH OF THE CHARGE BLOCKS. THE TEST  COULD HAVE
C         BEEN PERFORMED IN ANOTHER PLACE, HOWEVER, IT  IS  PERFORMED
C         HERE TO KEEP CONSISTENCY WITH OTHER SYMMETRIES.
C=======================================================================
C         THE TEST BELOW CAN  BE  PERFORMED  ONLY  WHEN  THE  FILLING
C         APPROXIMATION HAS NOT BEEN REQUESTED
C=======================================================================
C
      IF (NOMILZ.LT.1.AND.NOCCUP.NE.NVAMIZ) THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONMIZ FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/
     *         1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                    ''EAN-FIELD'',      1X,20(1H/),/
     *         1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                    ''IZATION 1'',      1X,20(1H/),/
     *         1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                    ''IX IN THE'',      1X,20(1H/),/
     *         1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                    ''         '',      1X,20(1H/),/)')
     *         ICHARG
C
          STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIZ)1'
C
      END IF
C
C=======================================================================
C         THE TEST BELOW CAN BE PERFORMED IN CASE  WHEN  THE  FILLING
C         APPROXIMATION HAS BEEN REQUESTED
C=======================================================================
C
      IF (NOMILZ.GE.1.AND.
     *    ABS(OCCFIL-NOCMIZ).GT.1.0E-12) THEN
C
          WRITE(NFIPRI,'(
     *         1X,20(1H/),''  MESSAGE FROM CONMIZ FOR IC'',
     *                    ''HARG = '',I1,1H:, 1X,20(1H/),/
     *         1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                    ''EAN-FIELD'',      1X,20(1H/),/
     *         1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                    ''IZATION 4'',      1X,20(1H/),/
     *         1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                    ''IX IN THE'',      1X,20(1H/),/
     *         1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                    ''         '',      1X,20(1H/),/)')
     *         ICHARG
C
          STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIZ)4'
C
      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (SINGLE-BLOCK CASE)
C=======================================================================
C
      IF (IFLIPI.NE.0) THEN
C
          JSPFLI=0
          JSHFLI=0
C
          OBPFLI=0.0D0
          OBHFLI=0.0D0
C
          DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
C=======================================================================
C               FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C               BY THE ABSOLUTE VALUE OF THE  "IFLIPI" CONTROL VARIABLE.
C               SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
             IF (ABS(IFLIPI).EQ. 1) OBSFLI=PNALIG(ISTATE)
             IF (ABS(IFLIPI).EQ. 2) OBSFLI=PNSPAL(ISTATE)
             IF (ABS(IFLIPI).EQ. 3) OBSFLI=PNXALI(ISTATE)
             IF (ABS(IFLIPI).EQ. 4) OBSFLI=PNXSPI(ISTATE)
             IF (ABS(IFLIPI).EQ. 5) OBSFLI=PNZALI(ISTATE)
             IF (ABS(IFLIPI).EQ. 6) OBSFLI=PNZSPI(ISTATE)
C
             IF (ABS(IFLIPI).EQ. 7) OBSFLI=PNXALI(ISTATE)*OMOVAX
     *                                    +PNALIG(ISTATE)*OMOVAY
     *                                    +PNZALI(ISTATE)*OMOVAZ
C
             IF (ABS(IFLIPI).EQ. 8) OBSFLI=PNXSPI(ISTATE)*OMOVAX
     *                                    +PNSPAL(ISTATE)*OMOVAY
     *                                    +PNZSPI(ISTATE)*OMOVAZ
C
             IF (ABS(IFLIPI).EQ. 9) OBSFLI=PNMO20(ISTATE)
             IF (ABS(IFLIPI).EQ.10) OBSFLI=PNMO22(ISTATE)
C
             IF (ABS(IFLIPI).EQ.11) OBSFLI=PNISOS(ISTATE)
C
             IF (ABS(IFLIPI).GT.11) STOP ' IFLIPI TOO LARGE IN CONMIZ'
C
C=======================================================================
C               SELECTING INDICES
C=======================================================================
C
C             IF (ICHARG.EQ.ICHFLI) THEN
C
             IF (ISTATE.EQ.ISPFLI) THEN
                 OBPFLI=OBSFLI
                 JSPFLI=ISTATE
             END IF
C
             IF (ISTATE.EQ.ISHFLI) THEN
                 OBHFLI=OBSFLI
                 JSHFLI=ISTATE
             END IF
C
C             END IF
C
          END DO
C
C          IF (ICHARG.EQ.ICHFLI) THEN
C
C=======================================================================
C            A WARNING IS ISSUED IF THE INDICES HAVE NOT BEEN SELECTED
C=======================================================================
C
          IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
              WRITE(NFIPRI,'(/,1X,20(1H/),
     *          '' ERROR IN DIABATIC BLOCKING IN CONMIZ'',
     *                                      2X,20(1H/),/,1X,20(1H/),
     *          ''          '',3X,''        '',3X,''          '',3X,
     *                                      2X,20(1H/),/,1X,20(1H/),
     *          '' ISPFLI='',I3,''   ISHFLI='',I3,''   IFLIPI='',I3,
     *                                      2X,20(1H/))')
     *        ISPFLI,ISHFLI,IFLIPI
C
              WRITE(NFIPRI,'(
     *                 1X,20(1H/),''  MESSAGE FROM CONMIZ FOR IC'',
     *                            ''HARG = '',I1,1H:, 1X,20(1H/),/
     *                 1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                            ''EAN-FIELD'',      1X,20(1H/),/
     *                 1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                            ''IZATION 2'',      1X,20(1H/),/
     *                 1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                            ''IX IN THE'',      1X,20(1H/),/
     *                 1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                            ''         '',      1X,20(1H/),/)')
     *                 ICHARG
C
              STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIZ)2'
C
          ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "IFLIPI" CONTROL VARIABLE ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE
C=======================================================================
C
              IF ((IFLIPI.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *            (IFLIPI.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                  VMOCCU(JSPFLI)=MMOCCU(ISHFLI)
                  VMOCCU(JSHFLI)=MMOCCU(ISPFLI)
C
              END IF
C
          END IF
C
      END IF
C
C      END IF
C
C=======================================================================
C         FLIPPING THE OCCUPATIONS WHEN REQUIRED TO CONSTRUCT THE
C         DIABATIC CONFIGURATIONS (ALL-BLOCKS CASE)
C=======================================================================
C
      NPARTY=0
C
      JSPFLI=0
      JSHFLI=0
C
      OBPFLI=0.0D0
      OBHFLI=0.0D0
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
C=======================================================================
C        FLIPPING IS BASED ON THE VALUES OF OBSERVABLES SELECTED
C        BY THE ABSOLUTE VALUE OF THE  "NOMLIZ"  MATRIX ELEMENTS.
C        SEE COMMENTS IN SUBROUTINE NAMELI.
C=======================================================================
C
         NPARTY=NPARTY+1
C
C=======================================================================
C        SELECTING INDICES IN THE GIVEN CHARGE  BLOCK
C=======================================================================
C
         IF (NOMLIZ.NE.0) THEN
C
             IF (ABS(NOMLIZ).EQ. 1) OBSFLI=PNALIG(ISTATE)
C
             IF (ABS(NOMLIZ).EQ. 2) OBSFLI=PNSPAL(ISTATE)
C
             IF (ABS(NOMLIZ).EQ. 3) OBSFLI=PNXALI(ISTATE)
C
             IF (ABS(NOMLIZ).EQ. 4) OBSFLI=PNXSPI(ISTATE)
C
             IF (ABS(NOMLIZ).EQ. 5) OBSFLI=PNZALI(ISTATE)
C
             IF (ABS(NOMLIZ).EQ. 6) OBSFLI=PNZSPI(ISTATE)
C
             IF (ABS(NOMLIZ).EQ. 7)
     *           OBSFLI=PNXALI(ISTATE)*OMOVAX
     *                 +PNALIG(ISTATE)*OMOVAY
     *                 +PNZALI(ISTATE)*OMOVAZ
C
             IF (ABS(NOMLIZ).EQ. 8)
     *           OBSFLI=PNXSPI(ISTATE)*OMOVAX
     *                 +PNSPAL(ISTATE)*OMOVAY
     *                 +PNZSPI(ISTATE)*OMOVAZ
C
             IF (ABS(NOMLIZ).EQ. 9) OBSFLI=PNMO20(ISTATE)
C
             IF (ABS(NOMLIZ).EQ.10) OBSFLI=PNMO22(ISTATE)
C
             IF (ABS(NOMLIZ).EQ.11) OBSFLI=PNISOS(ISTATE)
C
             IF (ABS(NOMLIZ).GT.11)
     *           STOP ' NOMLIZ TOO LARGE IN CONMIZ'
C
C=======================================================================
C
             IF (NPARTY.EQ.NPMLIZ) THEN
                 OBPFLI=OBSFLI
                 JSPFLI=ISTATE
             END IF
C
             IF (NPARTY.EQ.NHMLIZ) THEN
                 OBHFLI=OBSFLI
                 JSHFLI=ISTATE
             END IF
C
         END IF
C
      END DO
C
      IF (NOMLIZ.NE.0) THEN
C
C=======================================================================
C         PROGRAM STOPS IF THE INDICES HAVE NOT BEEN FOUND
C=======================================================================
C
          IF (JSPFLI.EQ.0.OR.JSHFLI.EQ.0) THEN
C
              WRITE(NFIPRI,'(/,1X,20(1H/),
     *              '' ERROR IN DIABATIC BLOCKING IN CONMIZ'',
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              ''        '',3X,''          '',3X,''          '',3X,
     *                                          2X,20(1H/),/,1X,20(1H/),
     *              '' NPMLIZ='',I3,''   NHMLIZ='',I3,''   NOMLIZ='',I3,
     *                                          2X,20(1H/))')
     *        NPMLIZ,
     *        NHMLIZ,
     *        NOMLIZ
C
              WRITE(NFIPRI,'(
     *             1X,20(1H/),''  MESSAGE FROM CONMIZ FOR IC'',
     *                        ''HARG = '',I1,1H:, 1X,20(1H/),/
     *             1X,20(1H/),''  INSUFFICIENT NUMBER  OF  M'',
     *                        ''EAN-FIELD'',      1X,20(1H/),/
     *             1X,20(1H/),''  STATES KEPT AFTER DIAGONAL'',
     *                        ''IZATION 3'',      1X,20(1H/),/
     *             1X,20(1H/),''  INCREASE THE  NUMBSP  MATR'',
     *                        ''IX IN THE'',      1X,20(1H/),/
     *             1X,20(1H/),''  INPUT DATA AND START AGAIN'',
     *                        ''         '',      1X,20(1H/),/)')
     *             ICHARG
C
              STOP 'INSUFFICIENT NUMBER OF STATES KEPT (CONMIZ)3'
C
          ELSE
C
C=======================================================================
C            HERE THE OCCUPATIONS ARE FLIPPED. POSITIVE  VALUES  OF  THE
C            "NOMLIZ" MATRIX ELEMENTS  ENSURE THAT THE CHOSEN OBSERVABLE
C            HAS A LARGER VALUE IN THE OCCUPIED STATE THAN IN THE  EMPTY
C            STATE, AND VICE VERSA.
C=======================================================================
C
              IF ((NOMLIZ.GT.0.AND.OBPFLI.GT.OBHFLI).OR.
     *            (NOMLIZ.LT.0.AND.OBPFLI.LT.OBHFLI)) THEN
C
                  VMOCCU(JSPFLI)=MMOCCU(NHMLIZ)
                  VMOCCU(JSHFLI)=MMOCCU(NPMLIZ)
C
              END IF
C
          END IF
C
      END IF
C
C=======================================================================
C        DETERMINING THE ORDERED SINGLE-PARTICLE SPECTRUM AND
C        THE FERMI ENERGY
C=======================================================================
C
      IORDER=0
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         IORDER=IORDER+1
         NORDER(IORDER)=IORDER
         EORDER(IORDER)=PNENER(ISTATE)
C
      END DO
C
      CALL ORDER1(EORDER,NORDER,IORDER)
C
      NUMACT=IN_FIX+IZ_FIX
C
      EFERMI=0.5*(EORDER(NUMACT+1)+EORDER(NUMACT))
C
C=======================================================================
C         DETERMINING THE VACUUM CONFIGURATION
C=======================================================================
C
      IPARTI=0
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         IF (PNENER(ISTATE).LT.EFERMI) THEN
C
             IPARTI=IPARTI+1
C
             MMOCVA(ISTATE)=1
C
         END IF
C
      END DO
C
C=======================================================================
C        IN CASE OF DEGENERATE STATES AT THE FERMI  ENERGY  THE
C        CONFIGURATION DATA ARE SET TO 100 TO OBTAIN  ASTERISKS
C        ON THE OUTPUT. A BETTER TREATMENT OF SUCH A DEGENERACY
C        IS STILL TO BE FOUND.
C=======================================================================
C
      IF (IPARTI.NE.NUMACT) THEN
C
          DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
             MMOCVA(ISTATE)=100
C
          END DO
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABSIG(ICHFLI,IPAFLI,IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  MREVER,IPAIRI,KPAHFB)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHASIG(0:NDPARI)*1,NAMNUC(0:NDISOS)*8
      CHARACTER
     *          NLOCCU(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)*3,
     *          NLVACC(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)*3
C
      DIMENSION
     *          KPAHFB(0:NDISOS)
C
      COMMON
     *       /SIGOCC/ N_OCCU(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS),
     *                N_OCVA(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGACT/ N_OCAC(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIG/ NPFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFLIG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFLIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FILG/ NPFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFILG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMNUC /'NEUTRON ','PROTON  '/
      DATA
     *       CHASIG /'+','-'/
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE CONFIGURATION DATA
C         FOR THE PARITY/SIGNATURE CASE
C=======================================================================
C
      IF (MREVER.EQ.1) THEN
          IDEGEN=1
      ELSE
          IDEGEN=2
      END IF
C
C=======================================================================
C         SELECTING STATES AFFECTED BY THE DIABATIC BLOCKING OR FILLING
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (IPAIRI.NE.1.OR.KPAHFB(ICHARG).EQ.0) THEN
C
         DO IPARIT=0,NDPARI
            DO IREVER=0,MREVER
C
               DO ISTATE=1,NDSTAT
C
                  WRITE(NLOCCU(ISTATE,IPARIT,IREVER,ICHARG),'(I1,2X)')
     *                  N_OCAC(ISTATE,IPARIT,IREVER,ICHARG)*IDEGEN
                  WRITE(NLVACC(ISTATE,IPARIT,IREVER,ICHARG),'(A3)')'N  '
C
               END DO
C
               JSPFLI=NPFLIG(IPARIT,IREVER,ICHARG)
               JSHFLI=NHFLIG(IPARIT,IREVER,ICHARG)
               JFLIPI=NOFLIG(IPARIT,IREVER,ICHARG)
C
               JSPFIL=NPFILG(IPARIT,IREVER,ICHARG)
               JSHFIL=NHFILG(IPARIT,IREVER,ICHARG)
               JFILPI=NOFILG(IPARIT,IREVER,ICHARG)
C
               DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                  IF ((IFLIPI.NE.0.AND.ICHARG.EQ.ICHFLI.AND.
     *                                 IPARIT.EQ.IPAFLI.AND.
     *                                 IREVER.EQ.IREFLI.AND.
     *                     ISTATE.GE.MIN(ISHFLI,ISPFLI).AND.
     *                     ISTATE.LT.MAX(ISHFLI,ISPFLI)).OR.
     *                (JFLIPI.NE.0.AND.
     *                     ISTATE.GE.MIN(JSHFLI,JSPFLI).AND.
     *                     ISTATE.LT.MAX(JSHFLI,JSPFLI))) THEN
C
                      NLOCCU(ISTATE,IPARIT,IREVER,ICHARG)(2:3)='><'
C
                  END IF
C
                  IF (JFILPI.GE.1.AND.
     *                ISTATE.GE.JSHFIL.AND.ISTATE.LT.JSPFIL) THEN
C
                      NLOCCU(ISTATE,IPARIT,IREVER,ICHARG)(2:3)='--'
C
                  END IF
C
                  WRITE(NLVACC(ISTATE,IPARIT,IREVER,ICHARG)(1:1),'(I1)')
     *                  N_OCVA(ISTATE,IPARIT,IREVER,ICHARG)*IDEGEN
C
               END DO
C
            END DO
         END DO
C
         END IF
C
      END DO
C
C=======================================================================
C         SELECTING STATES AROUND THE FERMI LEVEL TO BE PRINTED
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (IPAIRI.NE.1.OR.KPAHFB(ICHARG).EQ.0) THEN
C
         INDMIN=10000
         INDMAX=0
C
         DO IPARIT=0,NDPARI
            DO IREVER=0,MREVER
               DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
                  IF (N_OCAC(ISTATE,IPARIT,IREVER,ICHARG).EQ.0.OR.
     *                N_OCVA(ISTATE,IPARIT,IREVER,ICHARG).EQ.0)
     *                INDMIN=MIN(INDMIN,ISTATE)
C
                  IF (N_OCAC(ISTATE,IPARIT,IREVER,ICHARG).EQ.1.OR.
     *                N_OCVA(ISTATE,IPARIT,IREVER,ICHARG).EQ.1)
     *                INDMAX=MAX(INDMAX,ISTATE)
C
               END DO
            END DO
         END DO
C
C=======================================================================
C        PRINTING CONFIGURATIONS
C=======================================================================
C=======================================================================
C            ATTENTION: THE MATRICES WITH CONFIGURATIONS  USE THE
C                       TIME-REVERSAL CONVENTION.   THEREFORE, IN
C                       ORDER TO PRINT THE CONFIGURATIONS  IN THE
C                       PARITY/SIGNATURE CONVENTION, THE NEGATIVE
C                       PARITY BLOCKS CORRESPOND TO THE EXCHANGED
C                       IREVER BLOCKS. THE PRINTING ORDER IS:
C                       (PARITY,IREVER)  = (+,+) (+,-) (-,-) (-,+)
C=======================================================================
C
         ISTART=MAX((INDMIN+INDMAX)/2-10,1)
         IFINIS=ISTART+20
C
         WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,27X,A8,'' CONFIGURATIONS'',   27X,1H*,/,
     *                 1H*,27X,23(''=''),                27X,1H*,/,
     *                 1H*,2X,''      P S'',1X,21I3,      2X,1H*,/,
     *                 1H*,2X,''      ---'',2X,62(''-''), 2X,1H*,/,
     *                 1H*,                              77X,1H*)')
     *
     *   NAMNUC(ICHARG),(I,I=ISTART,IFINIS)
C
         WRITE(NFIPRI,'(2(1H*,2X,A5,2(1X,A1),      3X,21(A3),1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *    (('CONF:',CHASIG(IPARIT),CHASIG(IREVER),
     *       (NLOCCU(ISTATE,IPARIT,IREVER,ICHARG),
     *               ISTATE=ISTART,IFINIS),
     *
     *      'VACC:',CHASIG(IPARIT),CHASIG(IREVER),
     *       (NLVACC(ISTATE,IPARIT,IREVER,ICHARG),
     *               ISTATE=ISTART,IFINIS),
     *                             IREVER=0,MREVER),IPARIT=0,0),
     *
     *    (('CONF:',CHASIG(IPARIT),CHASIG(1-IREVER),
     *       (NLOCCU(ISTATE,IPARIT,IREVER,ICHARG),
     *               ISTATE=ISTART,IFINIS),
     *
     *      'VACC:',CHASIG(IPARIT),CHASIG(1-IREVER),
     *       (NLVACC(ISTATE,IPARIT,IREVER,ICHARG),
     *               ISTATE=ISTART,IFINIS),
     *                             IREVER=MREVER,0,-1),IPARIT=1,1)
C
         END IF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABSIM(ICHFLI,       IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                  MREVER,IPAIRI,KPAHFB)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHASIM(0:NDREVE)*1,NAMNUC(0:NDISOS)*8
      CHARACTER
     *          LLOCCU(1:NDSTAT,0:NDREVE,0:NDISOS)*3,
     *          LLVACC(1:NDSTAT,0:NDREVE,0:NDISOS)*3
C
      DIMENSION
     *          KPAHFB(0:NDISOS)
C
      COMMON
     *       /SIMOCC/ L_OCCU(1:NDSTAT,0:NDREVE,0:NDISOS),
     *                L_OCVA(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMACT/ L_OCAC(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /N_FLIM/ NPFLIM(0:NDREVE,0:NDISOS),
     *                NHFLIM(0:NDREVE,0:NDISOS),
     *                NOFLIM(0:NDREVE,0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMNUC /'NEUTRON ','PROTON  '/
      DATA
     *       CHASIM /'+','-'/
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE CONFIGURATION DATA
C         FOR THE SIMPLEX CASE
C=======================================================================
C
      IF (MREVER.EQ.1) THEN
          IDEGEN=1
      ELSE
          IDEGEN=2
      END IF
C
C=======================================================================
C         SELECTING STATES AFFECTED BY THE DIABATIC BLOCKING
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (IPAIRI.NE.1.OR.KPAHFB(ICHARG).EQ.0) THEN
C
         DO IREVER=0,MREVER
C
            DO ISTATE=1,NDSTAT
C
               WRITE(LLOCCU(ISTATE,IREVER,ICHARG),'(I1,2X)')
     *               L_OCAC(ISTATE,IREVER,ICHARG)*IDEGEN
               WRITE(LLVACC(ISTATE,IREVER,ICHARG),'(A3)') 'N  '
C
            END DO
C
            JSPFLI=NPFLIM(IREVER,ICHARG)
            JSHFLI=NHFLIM(IREVER,ICHARG)
            JFLIPI=NOFLIM(IREVER,ICHARG)
C
            DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
               IF ((IFLIPI.NE.0.AND.ICHARG.EQ.ICHFLI.AND.
     *                              IREVER.EQ.IREFLI.AND.
     *                  ISTATE.GE.MIN(ISHFLI,ISPFLI).AND.
     *                  ISTATE.LT.MAX(ISHFLI,ISPFLI)).OR.
     *             (JFLIPI.NE.0.AND.
     *                  ISTATE.GE.MIN(JSHFLI,JSPFLI).AND.
     *                  ISTATE.LT.MAX(JSHFLI,JSPFLI))) THEN
C
                   LLOCCU(ISTATE,IREVER,ICHARG)(2:3)='><'
C
               END IF
C
               WRITE(LLVACC(ISTATE,IREVER,ICHARG)(1:1),'(I1)')
     *               L_OCVA(ISTATE,IREVER,ICHARG)*IDEGEN
C
            END DO
         END DO
C
         END IF
C
      END DO
C
C=======================================================================
C         SELECTING STATES AROUND THE FERMI LEVEL TO BE PRINTED
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (IPAIRI.NE.1.OR.KPAHFB(ICHARG).EQ.0) THEN
C
         INDMIN=10000
         INDMAX=0
C
         DO IREVER=0,MREVER
            DO ISTATE=1,NUMBSP(IREVER,ICHARG)
C
               IF (L_OCAC(ISTATE,IREVER,ICHARG).EQ.0.OR.
     *             L_OCVA(ISTATE,IREVER,ICHARG).EQ.0)
     *             INDMIN=MIN(INDMIN,ISTATE)
C
               IF (L_OCAC(ISTATE,IREVER,ICHARG).EQ.1.OR.
     *             L_OCVA(ISTATE,IREVER,ICHARG).EQ.1)
     *             INDMAX=MAX(INDMAX,ISTATE)
C
            END DO
         END DO
C
C=======================================================================
C        PRINTING CONFIGURATIONS
C=======================================================================
C
         ISTART=MAX((INDMIN+INDMAX)/2-10,1)
         IFINIS=ISTART+20
C
         WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,27X,A8,'' CONFIGURATIONS'',   27X,1H*,/,
     *                 1H*,27X,23(''=''),                27X,1H*,/,
     *                 1H*,2X,''      SIM'',1X,21I3,      2X,1H*,/,
     *                 1H*,2X,''      ---'',2X,62(''-''), 2X,1H*,/,
     *                 1H*,                              77X,1H*)')
     *
     *    NAMNUC(ICHARG),(I,I=ISTART,IFINIS)
C
          WRITE(NFIPRI,'(2(1H*,2X,A5,'' ('',A1,'')'',3X,21(A3),1H*,/),
     *                                                 1H*,77X,1H*)')
     *
     *     ('CONF:',CHASIM(IREVER),
     *       (LLOCCU(ISTATE,IREVER,ICHARG),ISTATE=ISTART,IFINIS),
     *
     *      'VACC:',CHASIM(IREVER),
     *       (LLVACC(ISTATE,IREVER,ICHARG),ISTATE=ISTART,IFINIS),
     *                                                  IREVER=0,MREVER)
C
         END IF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABSIQ(ICHFLI,IPAFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                         IPAIRI,KPAHFB)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHASIQ(0:NDPARI)*1,NAMNUC(0:NDISOS)*8
      CHARACTER
     *          KLOCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS)*3,
     *          KLVACC(1:2*NDSTAT,0:NDPARI,0:NDISOS)*3
C
      DIMENSION
     *          KPAHFB(0:NDISOS)
C
      COMMON
     *       /SIQOCC/ K_OCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *                K_OCVA(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQACT/ K_OCAC(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /N_FLIQ/ NPFLIQ(0:NDPARI,         0:NDISOS),
     *                NHFLIQ(0:NDPARI,         0:NDISOS),
     *                NOFLIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMNUC /'NEUTRON ','PROTON  '/
      DATA
     *       CHASIQ /'+','-'/
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE CONFIGURATION DATA
C         FOR THE PARITY CASE
C=======================================================================
C
      IDEGEN=1
C
C=======================================================================
C         SELECTING STATES AFFECTED BY THE DIABATIC BLOCKING
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (IPAIRI.NE.1.OR.KPAHFB(ICHARG).EQ.0) THEN
C
         DO IPARIT=0,NDPARI
C
            DO ISTATE=1,2*NDSTAT
C
               WRITE(KLOCCU(ISTATE,IPARIT,ICHARG),'(I1,2X)')
     *               K_OCAC(ISTATE,IPARIT,ICHARG)*IDEGEN
               WRITE(KLVACC(ISTATE,IPARIT,ICHARG),'(A3)') 'N  '
C
            END DO
C
            JSPFLI=NPFLIQ(IPARIT,ICHARG)
            JSHFLI=NHFLIQ(IPARIT,ICHARG)
            JFLIPI=NOFLIQ(IPARIT,ICHARG)
C
            DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
               IF ((IFLIPI.NE.0.AND.ICHARG.EQ.ICHFLI.AND.
     *                              IPARIT.EQ.IPAFLI.AND.
     *                  ISTATE.GE.MIN(ISHFLI,ISPFLI).AND.
     *                  ISTATE.LT.MAX(ISHFLI,ISPFLI)).OR.
     *             (JFLIPI.NE.0.AND.
     *                  ISTATE.GE.MIN(JSHFLI,JSPFLI).AND.
     *                  ISTATE.LT.MAX(JSHFLI,JSPFLI))) THEN
C
                   KLOCCU(ISTATE,IPARIT,ICHARG)(2:3)='><'
C
               END IF
C
               WRITE(KLVACC(ISTATE,IPARIT,ICHARG)(1:1),'(I1)')
     *               K_OCVA(ISTATE,IPARIT,ICHARG)*IDEGEN
C
            END DO
         END DO
C
         END IF
C
      END DO
C
C=======================================================================
C         SELECTING STATES AROUND THE FERMI LEVEL TO BE PRINTED
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (IPAIRI.NE.1.OR.KPAHFB(ICHARG).EQ.0) THEN
C
         INDMIN=10000
         INDMAX=0
C
         DO IPARIT=0,NDPARI
            DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
               IF (K_OCAC(ISTATE,IPARIT,ICHARG).EQ.0.OR.
     *             K_OCVA(ISTATE,IPARIT,ICHARG).EQ.0)
     *             INDMIN=MIN(INDMIN,ISTATE)
C
               IF (K_OCAC(ISTATE,IPARIT,ICHARG).EQ.1.OR.
     *             K_OCVA(ISTATE,IPARIT,ICHARG).EQ.1)
     *             INDMAX=MAX(INDMAX,ISTATE)
C
C     WRITE (*,*) ICHARG,IPARIT,ISTATE,INDMIN,INDMAX,
C    *             K_OCAC(ISTATE,IPARIT,ICHARG),
C    *             K_OCVA(ISTATE,IPARIT,ICHARG)
C
            END DO
         END DO
C
C=======================================================================
C        PRINTING CONFIGURATIONS
C=======================================================================
C
         ISTART=MAX((INDMIN+INDMAX)/2-10,1)
         IFINIS=ISTART+20
C
         WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,27X,A8,'' CONFIGURATIONS'',   27X,1H*,/,
     *                 1H*,27X,23(''=''),                27X,1H*,/,
     *                 1H*,2X,''      PAR'',1X,21I3,      2X,1H*,/,
     *                 1H*,2X,''      ---'',2X,62(''-''), 2X,1H*,/,
     *                 1H*,                              77X,1H*)')
     *
     *    NAMNUC(ICHARG),(I,I=ISTART,IFINIS)
C
          WRITE(NFIPRI,'(2(1H*,2X,A5,'' ('',A1,'')'',3X,21(A3),1H*,/),
     *                                                 1H*,77X,1H*)')
     *
     *     ('CONF:',CHASIQ(IPARIT),
     *       (KLOCCU(ISTATE,IPARIT,ICHARG),ISTATE=ISTART,IFINIS),
     *
     *      'VACC:',CHASIQ(IPARIT),
     *       (KLVACC(ISTATE,IPARIT,ICHARG),ISTATE=ISTART,IFINIS),
     *                                                  IPARIT=0,NDPARI)
C
         END IF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABSIZ(ICHFLI,
     *                  ISPFLI,ISHFLI,IFLIPI,
     *                         IPAIRI,KPAHFB)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMNUC(0:NDISOS)*8
      CHARACTER
     *          MLOCCU(1:2*NDSTAT,0:NDISOS)*3,
     *          MLVACC(1:2*NDSTAT,0:NDISOS)*3
C
      DIMENSION
     *          KPAHFB(0:NDISOS)
C
      COMMON
     *       /SIZOCC/ M_OCCU(1:2*NDSTAT,0:NDISOS),
     *                M_OCVA(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZACT/ M_OCAC(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /N_FLIZ/ NPFLIZ(                  0:NDISOS),
     *                NHFLIZ(                  0:NDISOS),
     *                NOFLIZ(                  0:NDISOS)
      COMMON
     *       /N_FILZ/ NPFILZ(                  0:NDISOS),
     *                NHFILZ(                  0:NDISOS),
     *                NOFILZ(                  0:NDISOS)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       NAMNUC /'NEUTRON ','PROTON  '/
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE CONFIGURATION DATA
C         FOR THE CASE OF NO SYMMETRY
C=======================================================================
C
      IDEGEN=1
C
C=======================================================================
C         SELECTING STATES AFFECTED BY THE DIABATIC BLOCKING
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (IPAIRI.NE.1.OR.KPAHFB(ICHARG).EQ.0) THEN
C
         DO ISTATE=1,2*NDSTAT
C
            WRITE(MLOCCU(ISTATE,ICHARG),'(I1,2X)')
     *            M_OCAC(ISTATE,ICHARG)*IDEGEN
            WRITE(MLVACC(ISTATE,ICHARG),'(A3)') 'N  '
C
         END DO
C
         JSPFLI=NPFLIZ(ICHARG)
         JSHFLI=NHFLIZ(ICHARG)
         JFLIPI=NOFLIZ(ICHARG)
C
         JSPFIL=NPFILZ(ICHARG)
         JSHFIL=NHFILZ(ICHARG)
         JFILPI=NOFILZ(ICHARG)
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            IF ((IFLIPI.NE.0.AND.ICHARG.EQ.ICHFLI.AND.
     *               ISTATE.GE.MIN(ISHFLI,ISPFLI).AND.
     *               ISTATE.LT.MAX(ISHFLI,ISPFLI)).OR.
     *          (JFLIPI.NE.0.AND.
     *               ISTATE.GE.MIN(JSHFLI,JSPFLI).AND.
     *               ISTATE.LT.MAX(JSHFLI,JSPFLI))) THEN
C
                MLOCCU(ISTATE,ICHARG)(2:3)='><'
C
            END IF
C
            IF (JFILPI.NE.0.AND.
     *          ISTATE.GE.JSHFIL.AND.ISTATE.LT.JSPFIL) THEN
C
                MLOCCU(ISTATE,ICHARG)(2:3)='--'
C
            END IF
C
            WRITE(MLVACC(ISTATE,ICHARG)(1:1),'(I1)')
     *            M_OCVA(ISTATE,ICHARG)*IDEGEN
C
         END DO
C
         END IF
C
      END DO
C
C=======================================================================
C         SELECTING STATES AROUND THE FERMI LEVEL TO BE PRINTED
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         IF (IPAIRI.NE.1.OR.KPAHFB(ICHARG).EQ.0) THEN
C
         INDMIN=10000
         INDMAX=0
C
         DO ISTATE=1,NUMBSP(0,ICHARG)+NUMBSP(1,ICHARG)
C
            IF (M_OCAC(ISTATE,ICHARG).EQ.0.OR.
     *          M_OCVA(ISTATE,ICHARG).EQ.0)
     *          INDMIN=MIN(INDMIN,ISTATE)
C
            IF (M_OCAC(ISTATE,ICHARG).EQ.1.OR.
     *          M_OCVA(ISTATE,ICHARG).EQ.1)
     *          INDMAX=MAX(INDMAX,ISTATE)
C
         END DO
C
C=======================================================================
C        PRINTING CONFIGURATIONS
C=======================================================================
C
         ISTART=MAX((INDMIN+INDMAX)/2-11,1)
         IFINIS=ISTART+22
C
         WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *                 1H*,27X,A8,'' CONFIGURATIONS'',   27X,1H*,/,
     *                 1H*,27X,23(''=''),                27X,1H*,/,
     *                 1H*,5X,              1X,23I3,      2X,1H*,/,
     *                 1H*,5X,              2X,68(''-''), 2X,1H*,/,
     *                 1H*,                              77X,1H*)')
     *
     *    NAMNUC(ICHARG),(I,I=ISTART,IFINIS)
C
          WRITE(NFIPRI,'(2(1H*,2X,A5,              1X,23(A3),1H*,/),
     *                                               1H*,77X,1H*)')
     *
     *      'CONF:',
     *       (MLOCCU(ISTATE,ICHARG),ISTATE=ISTART,IFINIS),
     *
     *      'VACC:',
     *       (MLVACC(ISTATE,ICHARG),ISTATE=ISTART,IFINIS)
C
         END IF
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABMIG(MREVER,       IPAFLI,IREFLI,
     *                         ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHASIG(0:NDPARI)*1
      CHARACTER
     *          NLOCCU(1:2*NDSTAT,0:NDPARI,0:NDREVE)*3,
     *          NLVACC(1:2*NDSTAT,0:NDPARI,0:NDREVE)*3
C
      COMMON
     *       /MIGOCC/ NMOCCU(1:2*NDSTAT,0:NDPARI,0:NDREVE),
     *                NMOCVA(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MLIG/ NPMLIG(0:NDPARI,0:NDREVE),
     *                NHMLIG(0:NDPARI,0:NDREVE),
     *                NOMLIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /N_MILG/ NPMILG(0:NDPARI,0:NDREVE),
     *                NHMILG(0:NDPARI,0:NDREVE),
     *                NOMILG(0:NDPARI,0:NDREVE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       CHASIG /'+','-'/
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE CONFIGURATION DATA
C         FOR THE PARITY/SIGNATURE CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C
      IF (MREVER.EQ.1) THEN
          IDEGEN=1
      ELSE
          IDEGEN=2
      END IF
C
C=======================================================================
C         SELECTING STATES AFFECTED BY THE DIABATIC BLOCKING OR FILLING
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,MREVER
C
            DO ISTATE=1,2*NDSTAT
C
               WRITE(NLOCCU(ISTATE,IPARIT,IREVER),'(I1,2X)')
     *               NMOCCU(ISTATE,IPARIT,IREVER)*IDEGEN
               WRITE(NLVACC(ISTATE,IPARIT,IREVER),'(A3)')'N  '
C
            END DO
C
            JSPFLI=NPMLIG(IPARIT,IREVER)
            JSHFLI=NHMLIG(IPARIT,IREVER)
            JFLIPI=NOMLIG(IPARIT,IREVER)
C
            JSPFIL=NPMILG(IPARIT,IREVER)
            JSHFIL=NHMILG(IPARIT,IREVER)
            JFILPI=NOMILG(IPARIT,IREVER)
C
            DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
               IF ((IFLIPI.NE.0.AND.
     *                              IPARIT.EQ.IPAFLI.AND.
     *                              IREVER.EQ.IREFLI.AND.
     *                  ISTATE.GE.MIN(ISHFLI,ISPFLI).AND.
     *                  ISTATE.LT.MAX(ISHFLI,ISPFLI)).OR.
     *             (JFLIPI.NE.0.AND.
     *                  ISTATE.GE.MIN(JSHFLI,JSPFLI).AND.
     *                  ISTATE.LT.MAX(JSHFLI,JSPFLI))) THEN
C
                   NLOCCU(ISTATE,IPARIT,IREVER)(2:3)='><'
C
               END IF
C
               IF (JFILPI.GE.1.AND.
     *             ISTATE.GE.JSHFIL.AND.ISTATE.LT.JSPFIL) THEN
C
                   NLOCCU(ISTATE,IPARIT,IREVER)(2:3)='--'
C
               END IF
C
               WRITE(NLVACC(ISTATE,IPARIT,IREVER)(1:1),'(I1)')
     *               NMOCVA(ISTATE,IPARIT,IREVER)*IDEGEN
C
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         SELECTING STATES AROUND THE FERMI LEVEL TO BE PRINTED
C=======================================================================
C
C
      INDMIN=10000
      INDMAX=0
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,MREVER
            DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
               IF (NMOCCU(ISTATE,IPARIT,IREVER).EQ.0.OR.
     *             NMOCVA(ISTATE,IPARIT,IREVER).EQ.0)
     *             INDMIN=MIN(INDMIN,ISTATE)
C
               IF (NMOCCU(ISTATE,IPARIT,IREVER).GE.1.OR.
     *             NMOCVA(ISTATE,IPARIT,IREVER).GE.1)
     *             INDMAX=MAX(INDMAX,ISTATE)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C        PRINTING CONFIGURATIONS
C=======================================================================
C=======================================================================
C            ATTENTION: THE MATRICES WITH CONFIGURATIONS  USE THE
C                       TIME-REVERSAL CONVENTION.   THEREFORE, IN
C                       ORDER TO PRINT THE CONFIGURATIONS  IN THE
C                       PARITY/SIGNATURE CONVENTION, THE NEGATIVE
C                       PARITY BLOCKS CORRESPOND TO THE EXCHANGED
C                       IREVER BLOCKS. THE PRINTING ORDER IS:
C                       (PARITY,IREVER)  = (+,+) (+,-) (-,-) (-,+)
C=======================================================================
C
      ISTART=MAX((INDMIN+INDMAX)/2-10,1)
      IFINIS=ISTART+20
C
      WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,27X,A8,'' CONFIGURATIONS'',   27X,1H*,/,
     *              1H*,27X,23(''=''),                27X,1H*,/,
     *              1H*,2X,''      P S'',1X,21I3,      2X,1H*,/,
     *              1H*,2X,''      ---'',2X,62(''-''), 2X,1H*,/,
     *              1H*,                              77X,1H*)')
     *
     * 'NUCLEON ',(I,I=ISTART,IFINIS)
C
      WRITE(NFIPRI,'(2(1H*,2X,A5,2(1X,A1),      3X,21(A3),1H*,/),
     *                                            1H*,77X,1H*)')
     *
     * (('CONF:',CHASIG(IPARIT),CHASIG(IREVER),
     *    (NLOCCU(ISTATE,IPARIT,IREVER),
     *            ISTATE=ISTART,IFINIS),
     *
     *   'VACC:',CHASIG(IPARIT),CHASIG(IREVER),
     *    (NLVACC(ISTATE,IPARIT,IREVER),
     *            ISTATE=ISTART,IFINIS),
     *                          IREVER=0,MREVER),IPARIT=0,0),
     *
     * (('CONF:',CHASIG(IPARIT),CHASIG(1-IREVER),
     *    (NLOCCU(ISTATE,IPARIT,IREVER),
     *            ISTATE=ISTART,IFINIS),
     *
     *   'VACC:',CHASIG(IPARIT),CHASIG(1-IREVER),
     *    (NLVACC(ISTATE,IPARIT,IREVER),
     *            ISTATE=ISTART,IFINIS),
     *                          IREVER=MREVER,0,-1),IPARIT=1,1)
C
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABMIM(MREVER,       IREFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHASIM(0:NDREVE)*1
      CHARACTER
     *          LLOCCU(1:2*NDSTAT,0:NDREVE)*3,
     *          LLVACC(1:2*NDSTAT,0:NDREVE)*3
C
      COMMON
     *       /MIMOCC/ LMOCCU(1:2*NDSTAT,0:NDREVE),
     *                LMOCVA(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /N_MLIM/ NPMLIM(0:NDREVE),
     *                NHMLIM(0:NDREVE),
     *                NOMLIM(0:NDREVE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       CHASIM /'+','-'/
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE PNMIX CONFIGURATION DATA
C         FOR THE SIMPLEX CASE
C=======================================================================
C
      IF (MREVER.EQ.1) THEN
          IDEGEN=1
      ELSE
          IDEGEN=2
      END IF
C
C=======================================================================
C         SELECTING STATES AFFECTED BY THE DIABATIC BLOCKING
C=======================================================================
C
      DO IREVER=0,MREVER
C
         DO ISTATE=1,2*NDSTAT
C
            WRITE(LLOCCU(ISTATE,IREVER),'(I1,2X)')
     *            LMOCCU(ISTATE,IREVER)*IDEGEN
            WRITE(LLVACC(ISTATE,IREVER),'(A3)') 'N  '
C
         END DO
C
         JSPFLI=NPMLIM(IREVER)
         JSHFLI=NHMLIM(IREVER)
         JFLIPI=NOMLIM(IREVER)
C
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF ((IFLIPI.NE.0.AND.IREVER.EQ.IREFLI.AND.
     *               ISTATE.GE.MIN(ISHFLI,ISPFLI).AND.
     *               ISTATE.LT.MAX(ISHFLI,ISPFLI)).OR.
     *          (JFLIPI.NE.0.AND.
     *               ISTATE.GE.MIN(JSHFLI,JSPFLI).AND.
     *               ISTATE.LT.MAX(JSHFLI,JSPFLI))) THEN
C
                LLOCCU(ISTATE,IREVER)(2:3)='><'
C
            END IF
C
            WRITE(LLVACC(ISTATE,IREVER)(1:1),'(I1)')
     *            LMOCVA(ISTATE,IREVER)*IDEGEN
C
         END DO
      END DO
C
C=======================================================================
C         SELECTING STATES AROUND THE FERMI LEVEL TO BE PRINTED
C=======================================================================
C
      INDMIN=10000
      INDMAX=0
C
      DO IREVER=0,MREVER
         DO ISTATE=1,NUMBSP(IREVER,0)+NUMBSP(IREVER,1)
C
            IF (LMOCCU(ISTATE,IREVER).EQ.0.OR.
     *          LMOCVA(ISTATE,IREVER).EQ.0)
     *          INDMIN=MIN(INDMIN,ISTATE)
C
            IF (LMOCCU(ISTATE,IREVER).GE.1.OR.
     *          LMOCVA(ISTATE,IREVER).GE.1)
     *          INDMAX=MAX(INDMAX,ISTATE)
C
         END DO
      END DO
C
C=======================================================================
C        PRINTING CONFIGURATIONS
C=======================================================================
C
      ISTART=MAX((INDMIN+INDMAX)/2-10,1)
      IFINIS=ISTART+20
C
      WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,27X,A8,'' CONFIGURATIONS'',   27X,1H*,/,
     *              1H*,27X,23(''=''),                27X,1H*,/,
     *              1H*,2X,''      SIM'',1X,21I3,      2X,1H*,/,
     *              1H*,2X,''      ---'',2X,62(''-''), 2X,1H*,/,
     *              1H*,                              77X,1H*)')
     *
     *     'NUCLEON ',(I,I=ISTART,IFINIS)
C
       WRITE(NFIPRI,'(2(1H*,2X,A5,'' ('',A1,'')'',3X,21(A3),1H*,/),
     *                                              1H*,77X,1H*)')
     *
     *  ('CONF:',CHASIM(IREVER),
     *    (LLOCCU(ISTATE,IREVER),ISTATE=ISTART,IFINIS),
     *
     *   'VACC:',CHASIM(IREVER),
     *    (LLVACC(ISTATE,IREVER),ISTATE=ISTART,IFINIS),
     *                                               IREVER=0,MREVER)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABMIQ(IPAFLI,
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          CHASIQ(0:NDPARI)*1
      CHARACTER
     *          KLOCCU(1:4*NDSTAT,0:NDPARI)*3,
     *          KLVACC(1:4*NDSTAT,0:NDPARI)*3
C
      COMMON
     *       /MIQOCC/ KMOCCU(1:4*NDSTAT,0:NDPARI),
     *                KMOCVA(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /N_MLIQ/ NPMLIQ(0:NDPARI),
     *                NHMLIQ(0:NDPARI),
     *                NOMLIQ(0:NDPARI)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
      DATA
     *       CHASIQ /'+','-'/
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE PNMIX CONFIGURATION DATA
C         FOR THE PARITY CASE
C=======================================================================
C
      IDEGEN=1
C
C=======================================================================
C         SELECTING STATES AFFECTED BY THE DIABATIC BLOCKING
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
         DO ISTATE=1,4*NDSTAT
C
            WRITE(KLOCCU(ISTATE,IPARIT),'(I1,2X)')
     *            KMOCCU(ISTATE,IPARIT)*IDEGEN
            WRITE(KLVACC(ISTATE,IPARIT),'(A3)') 'N  '
C
         END DO
C
         JSPFLI=NPMLIQ(IPARIT)
         JSHFLI=NHMLIQ(IPARIT)
         JFLIPI=NOMLIQ(IPARIT)
C
         DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
            IF ((IFLIPI.NE.0.AND.IPARIT.EQ.IPAFLI.AND.
     *               ISTATE.GE.MIN(ISHFLI,ISPFLI).AND.
     *               ISTATE.LT.MAX(ISHFLI,ISPFLI)).OR.
     *          (JFLIPI.NE.0.AND.
     *               ISTATE.GE.MIN(JSHFLI,JSPFLI).AND.
     *               ISTATE.LT.MAX(JSHFLI,JSPFLI))) THEN
C
                KLOCCU(ISTATE,IPARIT)(2:3)='><'
C
            END IF
C
            WRITE(KLVACC(ISTATE,IPARIT)(1:1),'(I1)')
     *            KMOCVA(ISTATE,IPARIT)*IDEGEN
C
         END DO
      END DO
C
C=======================================================================
C         SELECTING STATES AROUND THE FERMI LEVEL TO BE PRINTED
C=======================================================================
C
C
      INDMIN=10000
      INDMAX=0
C
      DO IPARIT=0,NDPARI
         DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
            IF (KMOCCU(ISTATE,IPARIT).EQ.0.OR.
     *          KMOCVA(ISTATE,IPARIT).EQ.0)
     *          INDMIN=MIN(INDMIN,ISTATE)
C
            IF (KMOCCU(ISTATE,IPARIT).GE.1.OR.
     *          KMOCVA(ISTATE,IPARIT).GE.1)
     *          INDMAX=MAX(INDMAX,ISTATE)
C
         END DO
      END DO
C
C=======================================================================
C        PRINTING CONFIGURATIONS
C=======================================================================
C
      ISTART=MAX((INDMIN+INDMAX)/2-10,1)
      IFINIS=ISTART+20
C
      WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,27X,A8,'' CONFIGURATIONS'',   27X,1H*,/,
     *              1H*,27X,23(''=''),                27X,1H*,/,
     *              1H*,2X,''      PAR'',1X,21I3,      2X,1H*,/,
     *              1H*,2X,''      ---'',2X,62(''-''), 2X,1H*,/,
     *              1H*,                              77X,1H*)')
     *
     *    'NUCLEON ',(I,I=ISTART,IFINIS)
C
      WRITE(NFIPRI,'(2(1H*,2X,A5,'' ('',A1,'')'',3X,21(A3),1H*,/),
     *                                              1H*,77X,1H*)')
     *
     *  ('CONF:',CHASIQ(IPARIT),
     *    (KLOCCU(ISTATE,IPARIT),ISTATE=ISTART,IFINIS),
     *
     *   'VACC:',CHASIQ(IPARIT),
     *    (KLVACC(ISTATE,IPARIT),ISTATE=ISTART,IFINIS),
     *                                               IPARIT=0,NDPARI)
C
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TABMIZ(
     *                  ISPFLI,ISHFLI,IFLIPI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          MLOCCU(1:4*NDSTAT)*3,
     *          MLVACC(1:4*NDSTAT)*3
C
      COMMON
     *       /MIZOCC/ MMOCCU(1:4*NDSTAT),
     *                MMOCVA(1:4*NDSTAT)
      COMMON
     *       /N_MLIZ/ NPMLIZ,
     *                NHMLIZ,
     *                NOMLIZ
      COMMON
     *       /N_MILZ/ NPMILZ,
     *                NHMILZ,
     *                NOMILZ
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C
C=======================================================================
C         THIS SUBROUTINE PRINTS THE PNMIX CONFIGURATION DATA
C         FOR THE CASE OF NO SYMMETRY
C=======================================================================
C
      IDEGEN=1
C
C=======================================================================
C         SELECTING STATES AFFECTED BY THE DIABATIC BLOCKING
C=======================================================================
C
C
      DO ISTATE=1,4*NDSTAT
C
         WRITE(MLOCCU(ISTATE),'(I1,2X)')
     *         MMOCCU(ISTATE)*IDEGEN
         WRITE(MLVACC(ISTATE),'(A3)') 'N  '
C
      END DO
C
      JSPFLI=NPMLIZ
      JSHFLI=NHMLIZ
      JFLIPI=NOMLIZ
C
      JSPFIL=NPMILZ
      JSHFIL=NHMILZ
      JFILPI=NOMILZ
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         IF ((IFLIPI.NE.0.AND.
     *            ISTATE.GE.MIN(ISHFLI,ISPFLI).AND.
     *            ISTATE.LT.MAX(ISHFLI,ISPFLI)).OR.
     *       (JFLIPI.NE.0.AND.
     *            ISTATE.GE.MIN(JSHFLI,JSPFLI).AND.
     *            ISTATE.LT.MAX(JSHFLI,JSPFLI))) THEN
C
             MLOCCU(ISTATE)(2:3)='><'
C
         END IF
C
         IF (JFILPI.NE.0.AND.
     *       ISTATE.GE.JSHFIL.AND.ISTATE.LT.JSPFIL) THEN
C
             MLOCCU(ISTATE)(2:3)='--'
C
         END IF
C
         WRITE(MLVACC(ISTATE)(1:1),'(I1)')
     *         MMOCVA(ISTATE)*IDEGEN
C
      END DO
C
C=======================================================================
C         SELECTING STATES AROUND THE FERMI LEVEL TO BE PRINTED
C=======================================================================
C
C
      INDMIN=10000
      INDMAX=0
C
      DO ISTATE=1,NUMBSP(0,0)+NUMBSP(1,0)+NUMBSP(0,1)+NUMBSP(1,1)
C
         IF (MMOCCU(ISTATE).EQ.0.OR.
     *       MMOCVA(ISTATE).EQ.0)
     *       INDMIN=MIN(INDMIN,ISTATE)
C
         IF (MMOCCU(ISTATE).GE.1.OR.
     *       MMOCVA(ISTATE).GE.1)
     *       INDMAX=MAX(INDMAX,ISTATE)
C
      END DO
C
C====================================================================
C        PRINTING CONFIGURATIONS
C====================================================================
C
      ISTART=MAX((INDMIN+INDMAX)/2-11,1)
      IFINIS=ISTART+22
C
      WRITE(NFIPRI,'(79(1H*),/,                   1H*,77X,1H*,/,
     *              1H*,27X,A8,'' CONFIGURATIONS'',   27X,1H*,/,
     *              1H*,27X,23(''=''),                27X,1H*,/,
     *              1H*,5X,              1X,23I3,      2X,1H*,/,
     *              1H*,5X,              2X,68(''-''), 2X,1H*,/,
     *              1H*,                              77X,1H*)')
     *
     *     'NUCLEAON ',(I,I=ISTART,IFINIS)
C
      WRITE(NFIPRI,'(2(1H*,2X,A5,              1X,23(A3),1H*,/),
     *                                            1H*,77X,1H*)')
     *
     *   'CONF:',
     *    (MLOCCU(ISTATE),ISTATE=ISTART,IFINIS),
     *
     *   'VACC:',
     *    (MLVACC(ISTATE),ISTATE=ISTART,IFINIS)
C
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DUMSIG(NUPAHO,IPARIT,IREVER,ICHARG,N_PART,N_HOLE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          N_PART(NDPAHO,0:NDPARI,0:NDREVE),
     *          N_HOLE(NDPAHO,0:NDPARI,0:NDREVE)
C
      COMMON
     *       /SIGNPH/ NP_SIG(NDPAHO,0:NDPARI,0:NDREVE,0:NDISOS),
     *                NH_SIG(NDPAHO,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGNVA/ NVASIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DUMPS ON THE OUTPUT THE CONFIGURATION DATA
C         FOR THE PARITY/SIGNATURE CASE
C=======================================================================
C
      WRITE(NFIPRI,'(/,
     *             1X,20(1H/),''    WRONG CONFIGURATION NO. '',I2,
     *                                                   5X,20(1H/),/,
     *             1X,20(1H/),''  IPARIT='',I2,''  IREVER='',I2,
     *                        ''  ICHARG='',I2,          2X,20(1H/),/,
     *             1X,20(1H/),4X,4I3,2X,4I3,             5X,20(1H/),/)')
     *
     *       NUPAHO,IPARIT,IREVER,ICHARG,
     *
     *     ((N_PART(NUPAHO,IPARI_,IREVE_),IREVE_=0,NDREVE),
     *                                    IPARI_=0,NDPARI),
     *     ((N_HOLE(NUPAHO,IPARI_,IREVE_),IREVE_=0,NDREVE),
     *                                    IPARI_=0,NDPARI)
C
      WRITE(NFIPRI,'('' NVASIG='', 4I5,/)')
     *
     *     ((NVASIG(IPARI_,IREVE_,ICHARG),IREVE_=0,NDREVE),
     *                                    IPARI_=0,NDPARI)
C
      DO NUPAH_=1,NDPAHO
C
         WRITE(NFIPRI,'('' NUPAHO='',I2,1X,'',      N_PART='', 4I5,
     *                                     '',      N_HOLE='', 4I5)')
     *         NUPAH_,
     *
     *         NP_SIG(NUPAH_,0,0,ICHARG),
     *         NP_SIG(NUPAH_,0,1,ICHARG),
     *         NP_SIG(NUPAH_,1,1,ICHARG),
     *         NP_SIG(NUPAH_,1,0,ICHARG),
     *
     *         NH_SIG(NUPAH_,0,0,ICHARG),
     *         NH_SIG(NUPAH_,0,1,ICHARG),
     *         NH_SIG(NUPAH_,1,1,ICHARG),
     *         NH_SIG(NUPAH_,1,0,ICHARG)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DUMSIM(NUPAHO,IREVER,ICHARG,L_PART,L_HOLE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          L_PART(NDPAHO,0:NDREVE),
     *          L_HOLE(NDPAHO,0:NDREVE)
C
      COMMON
     *       /SIMNPH/ NP_SIM(NDPAHO,0:NDSIMP,0:NDISOS),
     *                NH_SIM(NDPAHO,0:NDSIMP,0:NDISOS)
      COMMON
     *       /SIMNVA/ NVASIM(0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DUMPS ON THE OUTPUT THE CONFIGURATION DATA
C         FOR THE SIMPLEX CASE
C=======================================================================
C
      WRITE(NFIPRI,'(/,
     *             1X,20(1H/),''    WRONG CONFIGURATION NO. '',I2,
     *                                                   5X,20(1H/),/,
     *             1X,20(1H/),''         '',2X,''  IREVER='',I2,
     *                        ''  ICHARG='',I2,          2X,20(1H/),/,
     *             1X,20(1H/),10X,2I3,8X,2I3,            5X,20(1H/),/)')
     *
     *       NUPAHO,IREVER,ICHARG,
     *
     *       (L_PART(NUPAHO,IREVE_),IREVE_=0,NDREVE),
     *       (L_HOLE(NUPAHO,IREVE_),IREVE_=0,NDREVE)
C
      WRITE(NFIPRI,'('' NVASIM='', 2I5,/)')
     *
     *       (NVASIM(IREVE_,ICHARG),IREVE_=0,NDREVE)
C
      DO NUPAH_=1,NDPAHO
C
         WRITE(NFIPRI,'('' NUPAHO='',I2,1X,'',      L_PART='', 2I5,
     *                                     '',      L_HOLE='', 2I5)')
     *         NUPAH_,
     *
     *         NP_SIM(NUPAH_,0,ICHARG),
     *         NP_SIM(NUPAH_,1,ICHARG),
     *
     *         NH_SIM(NUPAH_,0,ICHARG),
     *         NH_SIM(NUPAH_,1,ICHARG)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DUMSIQ(NUPAHO,IPARIT,ICHARG,K_PART,K_HOLE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          K_PART(NDPAHO,0:NDPARI),
     *          K_HOLE(NDPAHO,0:NDPARI)
C
      COMMON
     *       /SIQNPH/ NP_SIQ(NDPAHO,0:NDPARI,0:NDISOS),
     *                NH_SIQ(NDPAHO,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQNVA/ NVASIQ(0:NDPARI,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DUMPS ON THE OUTPUT THE CONFIGURATION DATA
C         FOR THE PARITY CASE
C=======================================================================
C
      WRITE(NFIPRI,'(/,
     *             1X,20(1H/),''    WRONG CONFIGURATION NO. '',I2,
     *                                                   5X,20(1H/),/,
     *             1X,20(1H/),''         '',2X,''  IPARIT='',I2,
     *                        ''  ICHARG='',I2,          2X,20(1H/),/,
     *             1X,20(1H/),10X,2I3,8X,2I3,            5X,20(1H/),/)')
     *
     *       NUPAHO,IPARIT,ICHARG,
     *
     *       (K_PART(NUPAHO,IPARI_),IPARI_=0,NDPARI),
     *       (K_HOLE(NUPAHO,IPARI_),IPARI_=0,NDPARI)
C
      WRITE(NFIPRI,'('' NVASIQ='', 2I5,/)')
     *
     *       (NVASIQ(IPARI_,ICHARG),IPARI_=0,NDPARI)
C
      DO NUPAH_=1,NDPAHO
C
         WRITE(NFIPRI,'('' NUPAHO='',I2,1X,'',      K_PART='', 2I5,
     *                                     '',      K_HOLE='', 2I5)')
     *         NUPAH_,
     *
     *         NP_SIQ(NUPAH_,0,ICHARG),
     *         NP_SIQ(NUPAH_,1,ICHARG),
     *
     *         NH_SIQ(NUPAH_,0,ICHARG),
     *         NH_SIQ(NUPAH_,1,ICHARG)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DUMSIZ(NUPAHO,ICHARG,M_PART,M_HOLE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          M_PART(NDPAHO),
     *          M_HOLE(NDPAHO)
C
      COMMON
     *       /SIZNPH/ NP_SIZ(NDPAHO,0:NDISOS),
     *                NH_SIZ(NDPAHO,0:NDISOS)
      COMMON
     *       /SIZNVA/ NVASIZ(0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DUMPS ON THE OUTPUT THE CONFIGURATION DATA
C         FOR THE NON-CONSERVED SIMPLEX CASE
C=======================================================================
C
      WRITE(NFIPRI,'(/,
     *             1X,20(1H/),''    WRONG CONFIGURATION NO. '',I2,
     *                                                   5X,20(1H/),/,
     *             1X,20(1H/),''         '',2X,''         '',2X,
     *                        ''  ICHARG='',I2,          2X,20(1H/),/,
     *             1X,20(1H/),13X,I3,11X,I3,             5X,20(1H/),/)')
     *
     *       NUPAHO,ICHARG,
     *
     *       M_PART(NUPAHO),
     *       M_HOLE(NUPAHO)
C
      WRITE(NFIPRI,'('' NVASIZ='', I5,/)')
     *
     *       NVASIZ(ICHARG)
C
      DO NUPAH_=1,NDPAHO
C
         WRITE(NFIPRI,'('' NUPAHO='',I2,1X,'',      M_PART='', I5,
     *                                     '',      M_HOLE='', I5)')
     *         NUPAH_,
     *         NP_SIZ(NUPAH_,ICHARG),
     *         NH_SIZ(NUPAH_,ICHARG)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DUMMIG(NUPAHO,IPARIT,IREVER,N_PART,N_HOLE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          N_PART(NDPAHO,0:NDPARI,0:NDREVE),
     *          N_HOLE(NDPAHO,0:NDPARI,0:NDREVE)
C
      COMMON
     *       /MIGNPH/ NP_MIG(NDPAHO,0:NDPARI,0:NDREVE),
     *                NH_MIG(NDPAHO,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGNVA/ NVAMIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DUMPS ON THE OUTPUT THE CONFIGURATION DATA
C         FOR THE PARITY/SIGNATURE CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C
      WRITE(NFIPRI,'(/,
     *             1X,20(1H/),''    WRONG CONFIGURATION NO. '',I2,
     *                                                   5X,20(1H/),/,
     *             1X,20(1H/),''  IPARIT='',I2,''  IREVER='',I2,
     *                        ''         '',2X,          2X,20(1H/),/,
     *             1X,20(1H/),4X,4I3,2X,4I3,             5X,20(1H/),/)')
     *
     *       NUPAHO,IPARIT,IREVER,
     *
     *     ((N_PART(NUPAHO,IPARI_,IREVE_),IREVE_=0,NDREVE),
     *                                    IPARI_=0,NDPARI),
     *     ((N_HOLE(NUPAHO,IPARI_,IREVE_),IREVE_=0,NDREVE),
     *                                    IPARI_=0,NDPARI)
C
      WRITE(NFIPRI,'('' NVAMIG='', 4I5,/)')
     *
     *     ((NVAMIG(IPARI_,IREVE_),IREVE_=0,NDREVE),
     *                                    IPARI_=0,NDPARI)
C
      DO NUPAH_=1,NDPAHO
C
         WRITE(NFIPRI,'('' NUPAHO='',I2,1X,'',      N_PART='', 4I5,
     *                                     '',      N_HOLE='', 4I5)')
     *         NUPAH_,
     *
     *         NP_MIG(NUPAH_,0,0),
     *         NP_MIG(NUPAH_,0,1),
     *         NP_MIG(NUPAH_,1,1),
     *         NP_MIG(NUPAH_,1,0),
     *
     *         NH_MIG(NUPAH_,0,0),
     *         NH_MIG(NUPAH_,0,1),
     *         NH_MIG(NUPAH_,1,1),
     *         NH_MIG(NUPAH_,1,0)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DUMMIM(NUPAHO,IREVER,L_PART,L_HOLE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          L_PART(NDPAHO,0:NDREVE),
     *          L_HOLE(NDPAHO,0:NDREVE)
C
      COMMON
     *       /MIMNPH/ NP_MIM(NDPAHO,0:NDSIMP),
     *                NH_MIM(NDPAHO,0:NDSIMP)
      COMMON
     *       /MIMNVA/ NVAMIM(0:NDREVE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DUMPS ON THE OUTPUT THE CONFIGURATION DATA
C         FOR THE SIMPLEX CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C
      WRITE(NFIPRI,'(/,
     *             1X,20(1H/),''    WRONG CONFIGURATION NO. '',I2,
     *                                                   5X,20(1H/),/,
     *             1X,20(1H/),''         '',2X,''  IREVER='',I2,
     *                        ''         '',2X,          2X,20(1H/),/,
     *             1X,20(1H/),10X,2I3,8X,2I3,            5X,20(1H/),/)')
     *
     *       NUPAHO,IREVER,
     *
     *       (L_PART(NUPAHO,IREVE_),IREVE_=0,NDREVE),
     *       (L_HOLE(NUPAHO,IREVE_),IREVE_=0,NDREVE)
C
      WRITE(NFIPRI,'('' NVAMIM='', 2I5,/)')
     *
     *       (NVAMIM(IREVE_),IREVE_=0,NDREVE)
C
      DO NUPAH_=1,NDPAHO
C
         WRITE(NFIPRI,'('' NUPAHO='',I2,1X,'',      L_PART='', 2I5,
     *                                     '',      L_HOLE='', 2I5)')
     *         NUPAH_,
     *
     *         NP_MIM(NUPAH_,0),
     *         NP_MIM(NUPAH_,1),
     *
     *         NH_MIM(NUPAH_,0),
     *         NH_MIM(NUPAH_,1)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DUMMIQ(NUPAHO,IPARIT,K_PART,K_HOLE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          K_PART(NDPAHO,0:NDPARI),
     *          K_HOLE(NDPAHO,0:NDPARI)
C
      COMMON
     *       /MIQNPH/ NP_MIQ(NDPAHO,0:NDPARI),
     *                NH_MIQ(NDPAHO,0:NDPARI)
      COMMON
     *       /MIQNVA/ NVAMIQ(0:NDPARI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DUMPS ON THE OUTPUT THE CONFIGURATION DATA
C         FOR THE PARITY CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C
      WRITE(NFIPRI,'(/,
     *             1X,20(1H/),''    WRONG CONFIGURATION NO. '',I2,
     *                                                   5X,20(1H/),/,
     *             1X,20(1H/),''         '',2X,''  IPARIT='',I2,
     *                        ''         '',2X,          2X,20(1H/),/,
     *             1X,20(1H/),10X,2I3,8X,2I3,            5X,20(1H/),/)')
     *
     *       NUPAHO,IPARIT,
     *
     *       (K_PART(NUPAHO,IPARI_),IPARI_=0,NDPARI),
     *       (K_HOLE(NUPAHO,IPARI_),IPARI_=0,NDPARI)
C
      WRITE(NFIPRI,'('' NVAMIQ='', 2I5,/)')
     *
     *       (NVAMIQ(IPARI_),IPARI_=0,NDPARI)
C
      DO NUPAH_=1,NDPAHO
C
         WRITE(NFIPRI,'('' NUPAHO='',I2,1X,'',      K_PART='', 2I5,
     *                                     '',      K_HOLE='', 2I5)')
     *         NUPAH_,
     *
     *         NP_MIQ(NUPAH_,0),
     *         NP_MIQ(NUPAH_,1),
     *
     *         NH_MIQ(NUPAH_,0),
     *         NH_MIQ(NUPAH_,1)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DUMMIZ(NUPAHO,M_PART,M_HOLE)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          M_PART(NDPAHO),
     *          M_HOLE(NDPAHO)
C
      COMMON
     *       /MIZNPH/ NP_MIZ(NDPAHO),
     *                NH_MIZ(NDPAHO)
      COMMON
     *       /MIZNVA/ NVAMIZ
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE DUMPS ON THE OUTPUT THE CONFIGURATION DATA
C         FOR THE NON-CONSERVED SIMPLEX CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C
      WRITE(NFIPRI,'(/,
     *             1X,20(1H/),''    WRONG CONFIGURATION NO. '',I2,
     *                                                   5X,20(1H/),/,
     *             1X,20(1H/),''         '',2X,''         '',2X,
     *                        ''         '',2X,          2X,20(1H/),/,
     *             1X,20(1H/),13X,I3,11X,I3,             5X,20(1H/),/)')
     *
     *       NUPAHO,
     *
     *       M_PART(NUPAHO),
     *       M_HOLE(NUPAHO)
C
      WRITE(NFIPRI,'('' NVAMIZ='', I5,/)')
     *
     *       NVAMIZ
C
      DO NUPAH_=1,NDPAHO
C
         WRITE(NFIPRI,'('' NUPAHO='',I2,1X,'',      M_PART='', I5,
     *                                     '',      M_HOLE='', I5)')
     *         NUPAH_,
     *         NP_MIZ(NUPAH_),
     *         NH_MIZ(NUPAH_)
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETSIG(IPAIRI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          N_PART(NDPAHO,0:NDPARI,0:NDREVE),
     *          N_HOLE(NDPAHO,0:NDPARI,0:NDREVE)
C
      COMMON
     *       /N_FILG/ NPFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NHFILG(0:NDPARI,0:NDREVE,0:NDISOS),
     *                NOFILG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGNPH/ NP_SIG(NDPAHO,0:NDPARI,0:NDREVE,0:NDISOS),
     *                NH_SIG(NDPAHO,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGOCC/ N_OCCU(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS),
     *                N_OCVA(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGFIL/ VFISIG(1:NDSTAT,0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGNVA/ NVASIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIGNOC/ NOCSIG(0:NDPARI,0:NDREVE,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE CHOSES THE ABSOLUTE CONFIGURATION
C         FOR THE PARITY/SIGNATURE CASE
C=======================================================================
C
C=======================================================================
C         ABSOLUTE VACUUM
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,NDREVE
            DO ICHARG=0,NDISOS
C
               DO ISTATE=1,NDSTAT
                  N_OCCU(ISTATE,IPARIT,IREVER,ICHARG)=0
                  VFISIG(ISTATE,IPARIT,IREVER,ICHARG)=0.0D0
               END DO
C
               DO ISTATE=1,NVASIG(IPARIT,IREVER,ICHARG)
                  N_OCCU(ISTATE,IPARIT,IREVER,ICHARG)=1
                  VFISIG(ISTATE,IPARIT,IREVER,ICHARG)=1.0D0
               END DO
C
               IF (NOFILG(IPARIT,IREVER,ICHARG).GE.1) THEN
C
                   FRAOCC=NOFILG(IPARIT,IREVER,ICHARG)/2.0D0/
     *                   (NPFILG(IPARIT,IREVER,ICHARG)
     *                   -NHFILG(IPARIT,IREVER,ICHARG)+1.0D0)
C
                   DO ISTATE=NHFILG(IPARIT,IREVER,ICHARG),
     *                       NPFILG(IPARIT,IREVER,ICHARG)
                      VFISIG(ISTATE,IPARIT,IREVER,ICHARG)=SQRT(FRAOCC)
                   END DO
C
               END IF
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         COPYING THE PARTICLE-HOLE EXCITATIONS
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         DO NUPAHO=1,NDPAHO
C
            N_PART(NUPAHO,0,0)=NP_SIG(NUPAHO,0,0,ICHARG)
            N_PART(NUPAHO,0,1)=NP_SIG(NUPAHO,0,1,ICHARG)
            N_PART(NUPAHO,1,0)=NP_SIG(NUPAHO,1,0,ICHARG)
            N_PART(NUPAHO,1,1)=NP_SIG(NUPAHO,1,1,ICHARG)
C
            N_HOLE(NUPAHO,0,0)=NH_SIG(NUPAHO,0,0,ICHARG)
            N_HOLE(NUPAHO,0,1)=NH_SIG(NUPAHO,0,1,ICHARG)
            N_HOLE(NUPAHO,1,0)=NH_SIG(NUPAHO,1,0,ICHARG)
            N_HOLE(NUPAHO,1,1)=NH_SIG(NUPAHO,1,1,ICHARG)
C
         END DO
C
         IF (IPAIRI.EQ.1) GO TO 1
C
C=======================================================================
C       EXCITING PARTICLES AND HOLES
C=======================================================================
C
        DO NUPAHO=1,NDPAHO
C
           DO IPARIT=0,NDPARI
              DO IREVER=0,NDREVE
C
C=======================================================================
C             PARTICLE EXCITATIONS
C=======================================================================
C
                 IF (            N_PART(NUPAHO,IPARIT,IREVER).GT.0) THEN
                     IF (        N_PART(NUPAHO,IPARIT,IREVER).LE.NDSTAT
     *               .AND.N_OCCU(N_PART(NUPAHO,IPARIT,IREVER),
     *                                  IPARIT,IREVER,ICHARG).EQ.0) THEN
                          N_OCCU(N_PART(NUPAHO,IPARIT,IREVER),
     *                                  IPARIT,IREVER,ICHARG)=1
                     ELSE
                         CALL DUMSIG(NUPAHO,IPARIT,IREVER,
     *                               ICHARG,N_PART,N_HOLE)
                         STOP 'WRONG PARTICLE CONFIGURATION IN SETSIG'
                     END IF
                 END IF
C
C=======================================================================
C                HOLE EXCITATIONS
C=======================================================================
C
                 IF (            N_HOLE(NUPAHO,IPARIT,IREVER).GT.0) THEN
                     IF (        N_HOLE(NUPAHO,IPARIT,IREVER).LE.NDSTAT
     *               .AND.N_OCCU(N_HOLE(NUPAHO,IPARIT,IREVER),
     *                                  IPARIT,IREVER,ICHARG).EQ.1) THEN
                          N_OCCU(N_HOLE(NUPAHO,IPARIT,IREVER),
     *                                  IPARIT,IREVER,ICHARG)=0
                     ELSE
                         CALL DUMSIG(NUPAHO,IPARIT,IREVER,
     *                               ICHARG,N_PART,N_HOLE)
                         STOP 'WRONG HOLE CONFIGURATION IN SETSIG'
                     END IF
                 END IF
C
              END DO
           END DO
C
        END DO
C
    1   CONTINUE
C
      END DO
C
      IF (IPAIRI.EQ.1) GO TO 2
C
C=======================================================================
C              COUNTING PARTICLES IN EACH PARITY/TIME-REVERSAL BLOCK
C=======================================================================
C
      DO ICHARG=0,NDISOS
         DO IPARIT=0,NDPARI
            DO IREVER=0,NDREVE
               NOCSIG(IPARIT,IREVER,ICHARG)=0
               DO ISTATE=1,NDSTAT
                         NOCSIG(IPARIT,IREVER,ICHARG)=
     *                   NOCSIG(IPARIT,IREVER,ICHARG)
     *           +N_OCCU(ISTATE,IPARIT,IREVER,ICHARG)
               END DO
            END DO
         END DO
      END DO
C
C=======================================================================
C              CHECKING PARTICLE NUMBERS IN THE FILLING APPROXIMATION
C=======================================================================
C
      INCORR=0
C
      DO ICHARG=0,NDISOS
         DO IPARIT=0,NDPARI
C
            NUFILL=0
            OCFILL=0
C
            DO IREVER=0,NDREVE
C
               IF (NOFILG(IPARIT,IREVER,ICHARG).GE.1) THEN
C
                   DO ISTATE=NHFILG(IPARIT,IREVER,ICHARG),
     *                       NPFILG(IPARIT,IREVER,ICHARG)
C
                      NUFILL=NUFILL
     *                      +N_OCCU(ISTATE,IPARIT,IREVER,ICHARG)
C
                      OCFILL=OCFILL
     *                      +VFISIG(ISTATE,IPARIT,IREVER,ICHARG)**2
C
                   END DO
C
               END IF
C
            END DO
C
            IF (ABS(NUFILL-OCFILL).GT.1.0E-12)THEN
C
                DO IREVER=0,NDREVE
C
                   WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                    '' INCOMPATIBLE SIGNATURE'',
     *                    '' CONFIGURATION'',1X,20(1H/),/,
     *                                       1X,20(1H/),
     *                    '' IN THE FILLING APPROXIMATION'',
     *                    '' DATA:  '',  1X,20(1H/),/,
     *                                       1X,20(1H/),
     *                    '' ICHARG='',I3,1X,
     *                    '' IPARIT='',I3,1X,
     *                    '' IREVER='',I3,   3X,20(1H/),/,
     *                                       1X,20(1H/),
     *                    '' NPFILG='',I3,1X,
     *                    '' NHFILG='',I3,1X,
     *                    '' NOFILG='',I3,   3X,20(1H/),/,
     *                                       1X,20(1H/),
     *                    '' NUFILL='',I3,1X,
     *                    '' OCFILL='',E11.3,
     *                                       7X,20(1H/),/)')
     *
     *                    ICHARG,IPARIT,IREVER,
     *                    NPFILG(IPARIT,IREVER,ICHARG),
     *                    NHFILG(IPARIT,IREVER,ICHARG),
     *                    NOFILG(IPARIT,IREVER,ICHARG),
     *                    NUFILL,OCFILL
C
                END DO
C
                INCORR=1
C
            END IF
C
         END DO
      END DO
C
      IF (INCORR.EQ.1) STOP 'INCOMPATIBLE FILLING DATA IN SETSIG'
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETSIM(IPAIRI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          L_PART(NDPAHO,0:NDREVE),
     *          L_HOLE(NDPAHO,0:NDREVE)
C
      COMMON
     *       /SIMNPH/ NP_SIM(NDPAHO,0:NDSIMP,0:NDISOS),
     *                NH_SIM(NDPAHO,0:NDSIMP,0:NDISOS)
      COMMON
     *       /SIMOCC/ L_OCCU(1:NDSTAT,0:NDREVE,0:NDISOS),
     *                L_OCVA(1:NDSTAT,0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMNVA/ NVASIM(0:NDREVE,0:NDISOS)
C
C=======================================================================
C         THIS SUBROUTINE CHOSES THE ABSOLUTE CONFIGURATION
C         FOR THE SIMPLEX CASE
C=======================================================================
C
C=======================================================================
C         ABSOLUTE VACUUM
C=======================================================================
C
      DO IREVER=0,NDREVE
         DO ICHARG=0,NDISOS
C
            DO ISTATE=1,NDSTAT
               L_OCCU(ISTATE,IREVER,ICHARG)=0
            END DO
C
            DO ISTATE=1,NVASIM(IREVER,ICHARG)
               L_OCCU(ISTATE,IREVER,ICHARG)=1
            END DO
C
         END DO
      END DO
C
C=======================================================================
C         COPYING THE PARTICLE-HOLE EXCITATIONS
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         DO NUPAHO=1,NDPAHO
C
            L_PART(NUPAHO,0)=NP_SIM(NUPAHO,0,ICHARG)
            L_PART(NUPAHO,1)=NP_SIM(NUPAHO,1,ICHARG)
C
            L_HOLE(NUPAHO,0)=NH_SIM(NUPAHO,0,ICHARG)
            L_HOLE(NUPAHO,1)=NH_SIM(NUPAHO,1,ICHARG)
C
         END DO
C
         IF (IPAIRI.EQ.1) GO TO 1
C
C=======================================================================
C        EXCITING PARTICLES AND HOLES
C=======================================================================
C
         DO NUPAHO=1,NDPAHO
C
            DO IREVER=0,NDREVE
C
C=======================================================================
C              PARTICLE EXCITATIONS
C=======================================================================
C
               IF (                L_PART(NUPAHO,IREVER).GT.0) THEN
                   IF (            L_PART(NUPAHO,IREVER).LE.NDSTAT
     *                 .AND.L_OCCU(L_PART(NUPAHO,IREVER),
     *                                    IREVER,ICHARG).EQ.0) THEN
                            L_OCCU(L_PART(NUPAHO,IREVER),
     *                                    IREVER,ICHARG)=1
                   ELSE
                       CALL DUMSIM(NUPAHO,IREVER,ICHARG,L_PART,L_HOLE)
                       STOP 'WRONG PARTICLE CONFIGURATION IN SETSIM'
                   END IF
               END IF
C
C=======================================================================
C              HOLE EXCITATIONS
C=======================================================================
C
               IF (                L_HOLE(NUPAHO,IREVER).GT.0) THEN
                   IF (            L_HOLE(NUPAHO,IREVER).LE.NDSTAT
     *                 .AND.L_OCCU(L_HOLE(NUPAHO,IREVER),
     *                                    IREVER,ICHARG).EQ.1) THEN
                            L_OCCU(L_HOLE(NUPAHO,IREVER),
     *                                    IREVER,ICHARG)=0
                   ELSE
                       CALL DUMSIM(NUPAHO,IREVER,ICHARG,L_PART,L_HOLE)
                       STOP 'WRONG HOLE CONFIGURATION IN SETSIM'
                   END IF
               END IF
C
            END DO
         END DO
C
    1    CONTINUE
C
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETSIQ(IPAIRI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          K_PART(NDPAHO,0:NDPARI),
     *          K_HOLE(NDPAHO,0:NDPARI)
C
      COMMON
     *       /SIQNPH/ NP_SIQ(NDPAHO,0:NDPARI,0:NDISOS),
     *                NH_SIQ(NDPAHO,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQOCC/ K_OCCU(1:2*NDSTAT,0:NDPARI,0:NDISOS),
     *                K_OCVA(1:2*NDSTAT,0:NDPARI,0:NDISOS)
      COMMON
     *       /SIQNVA/ NVASIQ(0:NDPARI,         0:NDISOS)
      COMMON
     *       /SIQNOC/ NOCSIQ(0:NDPARI,         0:NDISOS)
C
C=======================================================================
C         THIS SUBROUTINE CHOSES THE ABSOLUTE CONFIGURATION
C         FOR THE PARITY CASE
C=======================================================================
C         ABSOLUTE VACUUM
C=======================================================================
C
      DO ICHARG=0,NDISOS
         DO IPARIT=0,NDPARI
C
            DO ISTATE=1,2*NDSTAT
               K_OCCU(ISTATE,IPARIT,ICHARG)=0
            END DO
C
            DO ISTATE=1,NVASIQ(IPARIT,ICHARG)
               K_OCCU(ISTATE,IPARIT,ICHARG)=1
            END DO
C
         END DO
      END DO
C
      DO ICHARG=0,NDISOS
C
C=======================================================================
C        COPYING THE PARTICLE-HOLE EXCITATIONS
C=======================================================================
C
         DO NUPAHO=1,NDPAHO
C
            K_PART(NUPAHO,0)=NP_SIQ(NUPAHO,0,ICHARG)
            K_PART(NUPAHO,1)=NP_SIQ(NUPAHO,1,ICHARG)
C
            K_HOLE(NUPAHO,0)=NH_SIQ(NUPAHO,0,ICHARG)
            K_HOLE(NUPAHO,1)=NH_SIQ(NUPAHO,1,ICHARG)
C
         END DO
C
         IF (IPAIRI.EQ.1) GO TO 1
C
C=======================================================================
C        EXCITING PARTICLES AND HOLES
C=======================================================================
C
         DO NUPAHO=1,NDPAHO
C
            DO IPARIT=0,NDPARI
C
C=======================================================================
C              PARTICLE EXCITATIONS
C=======================================================================
C
               IF (                K_PART(NUPAHO,IPARIT).GT.0) THEN
                   IF (            K_PART(NUPAHO,IPARIT).LE.2*NDSTAT
     *                 .AND.K_OCCU(K_PART(NUPAHO,IPARIT),
     *                                    IPARIT,ICHARG).EQ.0) THEN
                            K_OCCU(K_PART(NUPAHO,IPARIT),
     *                                    IPARIT,ICHARG)=1
                   ELSE
                       CALL DUMSIQ(NUPAHO,IPARIT,ICHARG,K_PART,K_HOLE)
                       STOP 'WRONG PARTICLE CONFIGURATION IN SETSIQ'
                   END IF
               END IF
C
C=======================================================================
C              HOLE EXCITATIONS
C=======================================================================
C
               IF (                K_HOLE(NUPAHO,IPARIT).GT.0) THEN
                   IF (            K_HOLE(NUPAHO,IPARIT).LE.2*NDSTAT
     *                 .AND.K_OCCU(K_HOLE(NUPAHO,IPARIT),
     *                                    IPARIT,ICHARG).EQ.1) THEN
                            K_OCCU(K_HOLE(NUPAHO,IPARIT),
     *                                    IPARIT,ICHARG)=0
                   ELSE
                       CALL DUMSIQ(NUPAHO,IPARIT,ICHARG,K_PART,K_HOLE)
                       STOP 'WRONG HOLE CONFIGURATION IN SETSIQ'
                   END IF
               END IF
C
            END DO
         END DO
C
    1    CONTINUE
C
      END DO
C
C=======================================================================
C              COUNTING PARTICLES IN EACH PARITY BLOCK
C=======================================================================
C
      DO ICHARG=0,NDISOS
         DO IPARIT=0,NDPARI
            NOCSIQ(IPARIT,ICHARG)=0
            DO ISTATE=1,2*NDSTAT
               NOCSIQ(IPARIT,ICHARG)=NOCSIQ(IPARIT,ICHARG)
     *                       +K_OCCU(ISTATE,IPARIT,ICHARG)
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETSIZ(IPAIRI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          M_PART(NDPAHO),
     *          M_HOLE(NDPAHO)
C
      COMMON
     *       /SIZNPH/ NP_SIZ(NDPAHO,0:NDISOS),
     *                NH_SIZ(NDPAHO,0:NDISOS)
      COMMON
     *       /SIZOCC/ M_OCCU(1:2*NDSTAT,0:NDISOS),
     *                M_OCVA(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /N_FILZ/ NPFILZ(                  0:NDISOS),
     *                NHFILZ(                  0:NDISOS),
     *                NOFILZ(                  0:NDISOS)
      COMMON
     *       /SIZFIL/ VFISIZ(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SIZNVA/ NVASIZ(0:NDISOS)
      COMMON
     *       /SIZNOC/ NOCSIZ(0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE CHOSES THE ABSOLUTE CONFIGURATION
C         FOR THE CASE OF NO CONSERVED SYMMETRIES
C=======================================================================
C
C=======================================================================
C         ABSOLUTE VACUUM
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         DO ISTATE=1,2*NDSTAT
            M_OCCU(ISTATE,ICHARG)=0
            VFISIZ(ISTATE,ICHARG)=0.0D0
         END DO
C
         DO ISTATE=1,NVASIZ(ICHARG)
            M_OCCU(ISTATE,ICHARG)=1
            VFISIZ(ISTATE,ICHARG)=1.0D0
         END DO
C
         IF (NOFILZ(ICHARG).GE.1) THEN
C
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS  2.39K  AND  3.04,  THE  FRACTIONAL
C                   OCCUPATION "FRAOCC" WAS TWICE TOO  SMALL.  THIS  BUG
C                   WAS CORRECTED ON 19/03/2021 IN VERSION 3.04A.
C=======================================================================
C
             FRAOCC=NOFILZ(ICHARG)/(NPFILZ(ICHARG)-NHFILZ(ICHARG)+1.0D0)
C
             DO ISTATE=NHFILZ(ICHARG),
     *                 NPFILZ(ICHARG)
                VFISIZ(ISTATE,ICHARG)=SQRT(FRAOCC)
             END DO
C
         END IF
C
      END DO
C
C=======================================================================
C         COPYING THE PARTICLE-HOLE EXCITATIONS
C=======================================================================
C
      DO ICHARG=0,NDISOS
C
         DO NUPAHO=1,NDPAHO
C
            M_PART(NUPAHO)=NP_SIZ(NUPAHO,ICHARG)
C
            M_HOLE(NUPAHO)=NH_SIZ(NUPAHO,ICHARG)
C
         END DO
C
         IF (IPAIRI.EQ.1) GO TO 1
C
C=======================================================================
C        EXCITING PARTICLES AND HOLES
C=======================================================================
C
         DO NUPAHO=1,NDPAHO
C
C=======================================================================
C              PARTICLE EXCITATIONS
C=======================================================================
C
            IF (                M_PART(NUPAHO).GT.0) THEN
                IF (            M_PART(NUPAHO).LE.2*NDSTAT
     *              .AND.M_OCCU(M_PART(NUPAHO),ICHARG).EQ.0) THEN
                         M_OCCU(M_PART(NUPAHO),ICHARG)=1
                ELSE
                    CALL DUMSIZ(NUPAHO,ICHARG,M_PART,M_HOLE)
                    STOP 'WRONG PARTICLE CONFIGURATION IN SETSIZ'
                END IF
            END IF
C
C=======================================================================
C              HOLE EXCITATIONS
C=======================================================================
C
            IF (                M_HOLE(NUPAHO).GT.0) THEN
                IF (            M_HOLE(NUPAHO).LE.2*NDSTAT
     *              .AND.M_OCCU(M_HOLE(NUPAHO),ICHARG).EQ.1) THEN
                         M_OCCU(M_HOLE(NUPAHO),ICHARG)=0
                ELSE
                    CALL DUMSIZ(NUPAHO,ICHARG,M_PART,M_HOLE)
                    STOP 'WRONG HOLE CONFIGURATION IN SETSIZ'
                END IF
            END IF
C
         END DO
C
    1    CONTINUE
C
      END DO
C
      IF (IPAIRI.EQ.1) GO TO 2
C
C=======================================================================
C              COUNTING PARTICLES IN EACH CHARGE BLOCK
C=======================================================================
C
      DO ICHARG=0,NDISOS
         NOCSIZ(ICHARG)=0
         DO ISTATE=1,2*NDSTAT
                   NOCSIZ(ICHARG)=
     *             NOCSIZ(ICHARG)
     *     +M_OCCU(ISTATE,ICHARG)
         END DO
      END DO
C
C=======================================================================
C              CHECKING PARTICLE NUMBERS IN THE FILLING APPROXIMATION
C=======================================================================
C
      INCORR=0
C
      DO ICHARG=0,NDISOS
C
         NUFILL=0
         OCFILL=0
C
         IF (NOFILZ(ICHARG).GE.1) THEN
C
             DO ISTATE=NHFILZ(ICHARG),
     *                 NPFILZ(ICHARG)
C
                NUFILL=NUFILL
     *                +M_OCCU(ISTATE,ICHARG)
C
                OCFILL=OCFILL
     *                +VFISIZ(ISTATE,ICHARG)**2
C
             END DO
C
         END IF
C
         IF (ABS(NUFILL-OCFILL).GT.1.0E-12) THEN
C
             WRITE(NFIPRI,'(/,         1X,20(1H/),
     *              '' INCOMPATIBLE NO-SYMMET'',
     *              '' CONFIGURATION'',1X,20(1H/),/,
     *                                 1X,20(1H/),
     *              '' IN THE FILLING APPROXIMATION'',
     *              '' DATA:  '',  1X,20(1H/),/,
     *                                 1X,20(1H/),
     *              '' ICHARG='',I3,1X,
     *              ''        '',3X,1X,
     *              ''        '',3X,   3X,20(1H/),/,
     *                                 1X,20(1H/),
     *              '' NPFILZ='',I3,1X,
     *              '' NHFILZ='',I3,1X,
     *              '' NOFILZ='',I3,   3X,20(1H/),/,
     *                                 1X,20(1H/),
     *              '' NUFILL='',I3,1X,
     *              '' OCFILL='',E11.3,
     *                                 7X,20(1H/),/)')
     *
     *              ICHARG,
     *              NPFILZ(ICHARG),
     *              NHFILZ(ICHARG),
     *              NOFILZ(ICHARG),
     *              NUFILL,OCFILL
C
             INCORR=1
C
         END IF
C
      END DO
C
      IF (INCORR.EQ.1) STOP 'INCOMPATIBLE FILLING DATA IN SETSIZ'
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETMIG(IPAIRI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          N_PART(NDPAHO,0:NDPARI,0:NDREVE),
     *          N_HOLE(NDPAHO,0:NDPARI,0:NDREVE)
C
      COMMON
     *       /N_MILG/ NPMILG(0:NDPARI,0:NDREVE),
     *                NHMILG(0:NDPARI,0:NDREVE),
     *                NOMILG(0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGNPH/ NP_MIG(NDPAHO,0:NDPARI,0:NDREVE),
     *                NH_MIG(NDPAHO,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGOCC/ NMOCCU(1:2*NDSTAT,0:NDPARI,0:NDREVE),
     *                NMOCVA(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGFIL/ VFIMIG(1:2*NDSTAT,0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGNVA/ NVAMIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /MIGNOC/ NOCMIG(0:NDPARI,0:NDREVE)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE CHOSES THE ABSOLUTE CONFIGURATION
C         FOR THE PARITY/SIGNATURE CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C
C=======================================================================
C         ABSOLUTE VACUUM
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,NDREVE
C
            DO ISTATE=1,2*NDSTAT
               NMOCCU(ISTATE,IPARIT,IREVER)=0
               VFIMIG(ISTATE,IPARIT,IREVER)=0.0D0
            END DO
C
            DO ISTATE=1,NVAMIG(IPARIT,IREVER)
               NMOCCU(ISTATE,IPARIT,IREVER)=1
               VFIMIG(ISTATE,IPARIT,IREVER)=1.0D0
            END DO
C
            IF (NOMILG(IPARIT,IREVER).GE.1) THEN
C
                FRAOCC=NOMILG(IPARIT,IREVER)/2.0D0/
     *                (NPMILG(IPARIT,IREVER)
     *                -NHMILG(IPARIT,IREVER)+1.0D0)
C
                DO ISTATE=NHMILG(IPARIT,IREVER),
     *                    NPMILG(IPARIT,IREVER)
                   VFIMIG(ISTATE,IPARIT,IREVER)=SQRT(FRAOCC)
                END DO
C
            END IF
C
         END DO
      END DO
C
C=======================================================================
C         COPYING THE PARTICLE-HOLE EXCITATIONS
C=======================================================================
C
C
      DO NUPAHO=1,NDPAHO
C
         N_PART(NUPAHO,0,0)=NP_MIG(NUPAHO,0,0)
         N_PART(NUPAHO,0,1)=NP_MIG(NUPAHO,0,1)
         N_PART(NUPAHO,1,0)=NP_MIG(NUPAHO,1,0)
         N_PART(NUPAHO,1,1)=NP_MIG(NUPAHO,1,1)
C
         N_HOLE(NUPAHO,0,0)=NH_MIG(NUPAHO,0,0)
         N_HOLE(NUPAHO,0,1)=NH_MIG(NUPAHO,0,1)
         N_HOLE(NUPAHO,1,0)=NH_MIG(NUPAHO,1,0)
         N_HOLE(NUPAHO,1,1)=NH_MIG(NUPAHO,1,1)
C
      END DO
C
      IF (IPAIRI.EQ.1) GO TO 1
C
C=======================================================================
C       EXCITING PARTICLES AND HOLES
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
C
         DO IPARIT=0,NDPARI
            DO IREVER=0,NDREVE
C
C=======================================================================
C             PARTICLE EXCITATIONS
C=======================================================================
C
              IF (            N_PART(NUPAHO,IPARIT,IREVER).GT.0) THEN
                  IF (        N_PART(NUPAHO,IPARIT,IREVER).LE.2*NDSTAT
     *            .AND.NMOCCU(N_PART(NUPAHO,IPARIT,IREVER),
     *                               IPARIT,IREVER).EQ.0) THEN
                       NMOCCU(N_PART(NUPAHO,IPARIT,IREVER),
     *                               IPARIT,IREVER)=1
                  ELSE
                      CALL DUMMIG(NUPAHO,IPARIT,IREVER,
     *                                   N_PART,N_HOLE)
                      STOP 'WRONG PARTICLE CONFIGURATION IN SETMIG'
                  END IF
              END IF
C
C=======================================================================
C                HOLE EXCITATIONS
C=======================================================================
C
               IF (            N_HOLE(NUPAHO,IPARIT,IREVER).GT.0) THEN
                   IF (        N_HOLE(NUPAHO,IPARIT,IREVER).LE.2*NDSTAT
     *             .AND.NMOCCU(N_HOLE(NUPAHO,IPARIT,IREVER),
     *                                IPARIT,IREVER).EQ.1) THEN
                        NMOCCU(N_HOLE(NUPAHO,IPARIT,IREVER),
     *                                IPARIT,IREVER)=0
                   ELSE
                       CALL DUMMIG(NUPAHO,IPARIT,IREVER,
     *                                    N_PART,N_HOLE)
                       STOP 'WRONG HOLE CONFIGURATION IN SETMIG'
                   END IF
               END IF
C
            END DO
         END DO
C
      END DO
C
    1   CONTINUE
C
      IF (IPAIRI.EQ.1) GO TO 2
C
C=======================================================================
C              COUNTING PARTICLES IN EACH PARITY/TIME-REVERSAL BLOCK
C=======================================================================
C
      DO IPARIT=0,NDPARI
         DO IREVER=0,NDREVE
            NOCMIG(IPARIT,IREVER)=0
            DO ISTATE=1,2*NDSTAT
                      NOCMIG(IPARIT,IREVER)=
     *                NOCMIG(IPARIT,IREVER)
     *        +NMOCCU(ISTATE,IPARIT,IREVER)
            END DO
         END DO
      END DO
C
C=======================================================================
C              CHECKING PARTICLE NUMBERS IN THE FILLING APPROXIMATION
C=======================================================================
C
      INCORR=0
C
      DO IPARIT=0,NDPARI
C
         NUFILL=0
         OCFILL=0
C
         DO IREVER=0,NDREVE
C
            IF (NOMILG(IPARIT,IREVER).GE.1) THEN
C
                DO ISTATE=NHMILG(IPARIT,IREVER),
     *                    NPMILG(IPARIT,IREVER)
C
                   NUFILL=NUFILL
     *                   +NMOCCU(ISTATE,IPARIT,IREVER)
C
                   OCFILL=OCFILL
     *                   +VFIMIG(ISTATE,IPARIT,IREVER)**2
C
                END DO
C
            END IF
C
         END DO
C
         IF (ABS(NUFILL-OCFILL).GT.1.0E-12)THEN
C
             DO IREVER=0,NDREVE
C
                WRITE(NFIPRI,'(/,         1X,20(1H/),
     *                 '' INCOMPATIBLE SIGNATURE'',
     *                 '' CONFIGURATION'',1X,20(1H/),/,
     *                                    1X,20(1H/),
     *                 '' IN THE FILLING APPROXIMATION'',
     *                 '' DATA:  '',  1X,20(1H/),/,
     *                                    1X,20(1H/),
     *                 ''        '',3X,1X,
     *                 '' IPARIT='',I3,1X,
     *                 '' IREVER='',I3,   3X,20(1H/),/,
     *                                    1X,20(1H/),
     *                 '' NPMILG='',I3,1X,
     *                 '' NHMILG='',I3,1X,
     *                 '' NOMILG='',I3,   3X,20(1H/),/,
     *                                    1X,20(1H/),
     *                 '' NUFILL='',I3,1X,
     *                 '' OCFILL='',E11.3,
     *                                    7X,20(1H/),/)')
     *
     *                        IPARIT,IREVER,
     *                 NPMILG(IPARIT,IREVER),
     *                 NHMILG(IPARIT,IREVER),
     *                 NOMILG(IPARIT,IREVER),
     *                 NUFILL,OCFILL
C
             END DO
C
             INCORR=1
C
         END IF
C
      END DO
C
      IF (INCORR.EQ.1) STOP 'INCOMPATIBLE FILLING DATA IN SETMIG'
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETMIM(IPAIRI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          L_PART(NDPAHO,0:NDREVE),
     *          L_HOLE(NDPAHO,0:NDREVE)
C
      COMMON
     *       /MIMNPH/ NP_MIM(NDPAHO,0:NDSIMP),
     *                NH_MIM(NDPAHO,0:NDSIMP)
      COMMON
     *       /MIMOCC/ LMOCCU(1:2*NDSTAT,0:NDREVE),
     *                LMOCVA(1:2*NDSTAT,0:NDREVE)
      COMMON
     *       /MIMNVA/ NVAMIM(0:NDREVE)
C
C=======================================================================
C         THIS SUBROUTINE CHOSES THE ABSOLUTE CONFIGURATION
C         FOR THE SIMPLEX CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C
C=======================================================================
C         ABSOLUTE VACUUM
C=======================================================================
C
      DO IREVER=0,NDREVE
C
         DO ISTATE=1,2*NDSTAT
            LMOCCU(ISTATE,IREVER)=0
         END DO
C
         DO ISTATE=1,NVAMIM(IREVER)
            LMOCCU(ISTATE,IREVER)=1
         END DO
C
      END DO
C
C=======================================================================
C         COPYING THE PARTICLE-HOLE EXCITATIONS
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
C
         L_PART(NUPAHO,0)=NP_MIM(NUPAHO,0)
         L_PART(NUPAHO,1)=NP_MIM(NUPAHO,1)
C
         L_HOLE(NUPAHO,0)=NH_MIM(NUPAHO,0)
         L_HOLE(NUPAHO,1)=NH_MIM(NUPAHO,1)
C
      END DO
C
      IF (IPAIRI.EQ.1) GO TO 1
C
C=======================================================================
C        EXCITING PARTICLES AND HOLES
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
C
         DO IREVER=0,NDREVE
C
C=======================================================================
C              PARTICLE EXCITATIONS
C=======================================================================
C
            IF (                L_PART(NUPAHO,IREVER).GT.0) THEN
                IF (            L_PART(NUPAHO,IREVER).LE.2*NDSTAT
     *              .AND.LMOCCU(L_PART(NUPAHO,IREVER),
     *                                 IREVER).EQ.0) THEN
                         LMOCCU(L_PART(NUPAHO,IREVER),
     *                                 IREVER)=1
                ELSE
                    CALL DUMMIM(NUPAHO,IREVER,L_PART,L_HOLE)
                    STOP 'WRONG PARTICLE CONFIGURATION IN SETMIM'
                END IF
            END IF
C
C=======================================================================
C              HOLE EXCITATIONS
C=======================================================================
C
            IF (                L_HOLE(NUPAHO,IREVER).GT.0) THEN
                IF (            L_HOLE(NUPAHO,IREVER).LE.2*NDSTAT
     *              .AND.LMOCCU(L_HOLE(NUPAHO,IREVER),
     *                                 IREVER).EQ.1) THEN
                         LMOCCU(L_HOLE(NUPAHO,IREVER),
     *                                 IREVER)=0
                ELSE
                    CALL DUMMIM(NUPAHO,IREVER,L_PART,L_HOLE)
                    STOP 'WRONG HOLE CONFIGURATION IN SETMIM'
                END IF
            END IF
C
         END DO
      END DO
C
    1 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETMIQ(IPAIRI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          K_PART(NDPAHO,0:NDPARI),
     *          K_HOLE(NDPAHO,0:NDPARI)
C
      COMMON
     *       /MIQNPH/ NP_MIQ(NDPAHO,0:NDPARI),
     *                NH_MIQ(NDPAHO,0:NDPARI)
      COMMON
     *       /MIQOCC/ KMOCCU(1:4*NDSTAT,0:NDPARI),
     *                KMOCVA(1:4*NDSTAT,0:NDPARI)
      COMMON
     *       /MIQNVA/ NVAMIQ(0:NDPARI)
      COMMON
     *       /MIQNOC/ NOCMIQ(0:NDPARI)
C
C=======================================================================
C         THIS SUBROUTINE CHOSES THE ABSOLUTE CONFIGURATION
C         FOR THE PARITY CASE AND PROTON-NEUTRON MIXING
C=======================================================================
C         ABSOLUTE VACUUM
C=======================================================================
C
      DO IPARIT=0,NDPARI
C
         DO ISTATE=1,4*NDSTAT
            KMOCCU(ISTATE,IPARIT)=0
         END DO
C
         DO ISTATE=1,NVAMIQ(IPARIT)
            KMOCCU(ISTATE,IPARIT)=1
         END DO
C
      END DO
C
C
C=======================================================================
C        COPYING THE PARTICLE-HOLE EXCITATIONS
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
C
         K_PART(NUPAHO,0)=NP_MIQ(NUPAHO,0)
         K_PART(NUPAHO,1)=NP_MIQ(NUPAHO,1)
C
         K_HOLE(NUPAHO,0)=NH_MIQ(NUPAHO,0)
         K_HOLE(NUPAHO,1)=NH_MIQ(NUPAHO,1)
C
      END DO
C
      IF (IPAIRI.EQ.1) GO TO 1
C
C=======================================================================
C        EXCITING PARTICLES AND HOLES
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
C
         DO IPARIT=0,NDPARI
C
C=======================================================================
C              PARTICLE EXCITATIONS
C=======================================================================
C
            IF (                K_PART(NUPAHO,IPARIT).GT.0) THEN
                IF (            K_PART(NUPAHO,IPARIT).LE.4*NDSTAT
     *              .AND.KMOCCU(K_PART(NUPAHO,IPARIT),IPARIT).EQ.0) THEN
                         KMOCCU(K_PART(NUPAHO,IPARIT),IPARIT)=1
                ELSE
                    CALL DUMMIQ(NUPAHO,IPARIT,K_PART,K_HOLE)
                    STOP 'WRONG PARTICLE CONFIGURATION IN SETMIQ'
                END IF
            END IF
C
C=======================================================================
C              HOLE EXCITATIONS
C=======================================================================
C
            IF (                K_HOLE(NUPAHO,IPARIT).GT.0) THEN
                IF (            K_HOLE(NUPAHO,IPARIT).LE.4*NDSTAT
     *              .AND.KMOCCU(K_HOLE(NUPAHO,IPARIT),IPARIT).EQ.1) THEN
                         KMOCCU(K_HOLE(NUPAHO,IPARIT),IPARIT)=0
                ELSE
                    CALL DUMMIQ(NUPAHO,IPARIT,K_PART,K_HOLE)
                    STOP 'WRONG HOLE CONFIGURATION IN SETMIQ'
                END IF
            END IF
C
         END DO
      END DO
C
    1    CONTINUE
C
C
C=======================================================================
C              COUNTING PARTICLES IN EACH PARITY BLOCK
C=======================================================================
C
      DO IPARIT=0,NDPARI
         NOCMIQ(IPARIT)=0
         DO ISTATE=1,4*NDSTAT
            NOCMIQ(IPARIT)=NOCMIQ(IPARIT)
     *                    +KMOCCU(ISTATE,IPARIT)
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SETMIZ(IPAIRI)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          M_PART(NDPAHO),
     *          M_HOLE(NDPAHO)
C
      COMMON
     *       /MIZNPH/ NP_MIZ(NDPAHO),
     *                NH_MIZ(NDPAHO)
      COMMON
     *       /MIZOCC/ MMOCCU(1:4*NDSTAT),
     *                MMOCVA(1:4*NDSTAT)
      COMMON
     *       /N_MILZ/ NPMILZ,
     *                NHMILZ,
     *                NOMILZ
      COMMON
     *       /MIZFIL/ VFIMIZ(1:4*NDSTAT)
      COMMON
     *       /MIZNVA/ NVAMIZ
      COMMON
     *       /MIZNOC/ NOCMIZ
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE CHOSES THE ABSOLUTE CONFIGURATION
C         FOR THE CASE OF NON-COSERVED SIMPLEX AND PROTON-NEUTRON MIXING
C=======================================================================
C
C=======================================================================
C         ABSOLUTE VACUUM
C=======================================================================
C
C
      DO ISTATE=1,4*NDSTAT
         MMOCCU(ISTATE)=0
         VFIMIZ(ISTATE)=0.0D0
      END DO
C
      DO ISTATE=1,NVAMIZ
         MMOCCU(ISTATE)=1
         VFIMIZ(ISTATE)=1.0D0
      END DO
C
      IF (NOMILZ.GE.1) THEN
C
          FRAOCC=NOMILZ/2.0D0/
     *          (NPMILZ
     *          -NHMILZ+1.0D0)
C
          DO ISTATE=NHMILZ,
     *              NPMILZ
             VFIMIZ(ISTATE)=SQRT(FRAOCC)
          END DO
C
      END IF
C
C
C=======================================================================
C         COPYING THE PARTICLE-HOLE EXCITATIONS
C=======================================================================
C
C
      DO NUPAHO=1,NDPAHO
C
         M_PART(NUPAHO)=NP_MIZ(NUPAHO)
C
         M_HOLE(NUPAHO)=NH_MIZ(NUPAHO)
C
      END DO
C
      IF (IPAIRI.EQ.1) GO TO 1
C
C=======================================================================
C        EXCITING PARTICLES AND HOLES
C=======================================================================
C
      DO NUPAHO=1,NDPAHO
C
C=======================================================================
C              PARTICLE EXCITATIONS
C=======================================================================
C
         IF (                M_PART(NUPAHO).GT.0) THEN
             IF (            M_PART(NUPAHO).LE.4*NDSTAT
     *           .AND.MMOCCU(M_PART(NUPAHO)).EQ.0) THEN
                      MMOCCU(M_PART(NUPAHO))=1
             ELSE
                 CALL DUMMIZ(NUPAHO,M_PART,M_HOLE)
                 STOP 'WRONG PARTICLE CONFIGURATION IN SETMIZ'
             END IF
         END IF
C
C=======================================================================
C              HOLE EXCITATIONS
C=======================================================================
C
         IF (                M_HOLE(NUPAHO).GT.0) THEN
             IF (            M_HOLE(NUPAHO).LE.4*NDSTAT
     *           .AND.MMOCCU(M_HOLE(NUPAHO)).EQ.1) THEN
                      MMOCCU(M_HOLE(NUPAHO))=0
             ELSE
                 CALL DUMMIZ(NUPAHO,M_PART,M_HOLE)
                 STOP 'WRONG HOLE CONFIGURATION IN SETMIZ'
             END IF
         END IF
C
      END DO
C
    1 CONTINUE
C
C
      IF (IPAIRI.EQ.1) GO TO 2
C
C=======================================================================
C              COUNTING PARTICLES IN EACH CHARGE BLOCK
C=======================================================================
C
      NOCMIZ=0
      DO ISTATE=1,4*NDSTAT
         NOCMIZ=
     *   NOCMIZ
     *  +MMOCCU(ISTATE)
      END DO
C
C=======================================================================
C              CHECKING PARTICLE NUMBERS IN THE FILLING APPROXIMATION
C=======================================================================
C
      INCORR=0
C
C
      NUFILL=0
      OCFILL=0
C
      IF (NOMILZ.GE.1) THEN
C
          DO ISTATE=NHMILZ,
     *              NPMILZ
C
             NUFILL=NUFILL
     *             +MMOCCU(ISTATE)
C
             OCFILL=OCFILL
     *             +VFIMIZ(ISTATE)**2
C
          END DO
C
      END IF
C
      IF (ABS(NUFILL-OCFILL).GT.1.0E-12) THEN
C
          WRITE(NFIPRI,'(/,         1X,20(1H/),
     *           '' INCOMPATIBLE NO-SYMMET'',
     *           '' CONFIGURATION'',1X,20(1H/),/,
     *                              1X,20(1H/),
     *           '' IN THE FILLING APPROXIMATION'',
     *           '' DATA:  '',  1X,20(1H/),/,
     *                              1X,20(1H/),
     *           ''        '',3X,1X,
     *           ''        '',3X,1X,
     *           ''        '',3X,   3X,20(1H/),/,
     *                              1X,20(1H/),
     *           '' NPMILZ='',I3,1X,
     *           '' NHMILZ='',I3,1X,
     *           '' NOMILZ='',I3,   3X,20(1H/),/,
     *                              1X,20(1H/),
     *           '' NUFILL='',I3,1X,
     *           '' OCFILL='',E11.3,
     *                              7X,20(1H/),/)')
     *
     *           NPMILZ,
     *           NHMILZ,
     *           NOMILZ,
     *           NUFILL,OCFILL
C
          INCORR=1
C
      END IF
C
C      END DO
C
      IF (INCORR.EQ.1) STOP 'INCOMPATIBLE FILLING DATA IN SETMIZ'
C
C=======================================================================
C
    2 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DELPAI(ICHARG,MREVER,JPABCS,NOPART,ITERUN,
     *                  DELFIX,G_PAIR,E_PAIR,EFERMI,BCSDEL)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          V2OCCU(1:NDSTAT),NAUXIL(1:NDSTAT),ESINGP(1:NDSTAT),
     *          EQSPRT(1:NDSTAT),DELTAS(1:NDSTAT),
     *          DELTA0(1:NDSTAT),SM(1:NDSTAT)
C=======================================================================
      ALLOCATABLE PARELE(:,:)
C=======================================================================
C
      COMMON
     *       /PROCCU/ V_OCCU(1:4*NDSTAT)
      COMMON
     *       /SIMSPE/ SPESIM(1:NDBASE)
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /MATRIG/ GMATRI(1:NDSTAT,1:NDSTAT,0:NDISOS)
      COMMON
     *       /CFIPRI/ NFIPRI
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      COMMON
     *       /SENTRO/ ENTRPY(0:NDISOS)
C     ATTENTION: BUG CORRECTED ON 19/02/2020, SEE COMMENTS IN  "HFBSIG"
      COMMON
     *       /FER_IS/ FERMFN(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /GCTEMP/ TEMP_T
      COMMON
     *       /T_FLAG/ IFTEMP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
C=======================================================================
C
      CALL CPUTIM('DELPAI',1)
C
C=======================================================================
C
      IALLOC=0
C
C=======================================================================
      ALLOCATE (PARELE(1:NDSTAT,1:NDSTAT),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('PARELE','DELPAI')
C=======================================================================
C
C=======================================================================
C         SUBROUTINE DELPAI SOLVES THE BCS EQUATIONS FOR THE SENIORITY
C         PAIRING FORCE (JPABCS=1), WITH FIXED PARING GAP (JPABCS=2),
C         OR FOR THE ZERO-RANGE FORCE (JPABCS=3).
C=======================================================================
C
C         MEANING OF SOME PARAMETERS:
C
C         ICHARG = 0 FOR NEUTRONS
C                = 1 FOR PROTONS
C
C         JPABCS = 1 SENIORITY PAIRING FORCE
C                = 2 SENIORITY PAIRING FORCE WITH FIXED PAIRING GAP
C                = 3 ZERO-RANGE FORCE
C
C         NTQPAR = 0 BCS GROUND STATE, OTHERWISE
C                > 0 2-QP STATE BUILT ON NTQPAR ORBITAL
C
C         NOPART - THE ACTUAL PARTICLE NUMBER (OF PROTONS OR NEUTRONS)
C         G_PAIR - THE PAIRING STRENGTH CONSTANT IN MEV (SEE: GUESSES)
C                  FOR SENIORITY PAIRIND FORCE (JPABCS=1 OR 2)
C         GMATRI - THE PAIRING MATRIX ELEMENTS BETWEEN PAIRS OF TIME-
C                  REVERSED STATES (SEE: GINTER)
C         SPESIM - THE SINGLE - PARTICLE SPECTRUM (DOES NOT NEED TO BE
C                  ORDERED BEFORE CALLING THIS ROUTINE)
C         LSTATE - THE TOTAL NUMBER OF LEVELS IN THE S. PART. SPECTRUM
C
C         BCSDEL - THE INITIAL PARING (PROTON OR NEUTRON) GAP
C                  (ENFORCED VALUE WHEN JPABCS=2)
C         V2OCCU - THE PAIRING OCCUPATION FACTORS (TO BE CALCULETED)
C         EFERMI - THE FERMI ENERGY TO BE CALCULATED (IN MEV)
C         E_PAIR - THE PAIRING ENERGY TO BE CALCULATED (IN MEV)
C
C         EPSILF - THE ACCURACY FOR THE FERMI ENERGY
C         EPSILG - THE ACCURACY FOR THE PAIRING GAP
C         MAXITE - MAXIMUM NUMBER OF ITERATIONS ALLOWED
C
C=======================================================================
C         WITHOUT ROTATION (IROTAT=0) AND WITHOUT BREAKING THE Y-SIMPLEX
C         SYMMETRY (ISIMPY=1), THE TIME-REVERSED BLOCK IS NOT EXPLICITLY
C         CALCULATED. THIS IS DONE BY USING MREVER=0.
C=======================================================================
C
      LSTATE=NUMBSP(0,ICHARG)+MREVER*NUMBSP(1,ICHARG)
C
      EPSILF= 1.0D-07
      EPSILG= 1.0D-05
      MAXITE= 200
      NTQPAR= 0
C
      DO I=1,LSTATE
         NAUXIL(I)=I
         ESINGP(I)=SPESIM(I)
      END DO
C
C=======================================================================
C         THE ARRIVING SINGLE PARTICLE LEVELS ARE USUALLY NOT ORDERED
C         THEY WILL BE ORDERED HERE TO AVOID INCREASING ORDER PROBLEM
C=======================================================================
C
      CALL ORDER1(ESINGP,NAUXIL,LSTATE)
C
C=======================================================================
C         BCS FILLING: PAIRING MATRIX ELEMENTS * 1/2
C=======================================================================
C
C=======================================================================
C         WITH SENIORTY FORCE
C=======================================================================
C
      IF (JPABCS.EQ.1.OR.(JPABCS.EQ.3.AND.ITERUN.EQ.1)) THEN
C
          DO I=1,LSTATE
             DO J=I,LSTATE
               PARELE(I,J)=G_PAIR/2
               PARELE(J,I)=G_PAIR/2
             END DO
          END DO
      END IF
C
      IF (JPABCS.EQ.2) THEN
C
          BCSDEL=DELFIX
C
      END IF
C
C=======================================================================
C         WITH DELTA FORCE
C=======================================================================
C
      IF (JPABCS.EQ.3.AND.ITERUN.NE.1) THEN
C
          DO I=1,LSTATE
             DO J=1,LSTATE
C                                               (SEE COMMENTS IN GINTER)
                PARELE(I,J)=GMATRI(NAUXIL(I),NAUXIL(J),ICHARG)/2
C                                               (SEE COMMENTS IN GINTER)
C
             END DO
          END DO
      END IF
C
C=======================================================================
C         INITIALIZATION OF THE FERMI ENERGY AND THE GAPS
C=======================================================================
C
      NFERMI=NOPART/2
      EFERMI=0.5*(ESINGP(NFERMI)+ESINGP(NFERMI+1))
C
      DO I=1,LSTATE
         DELTAS(I)=BCSDEL
      END DO
C
C=======================================================================
C        REINITIALIZATION TO AVOID MISSING A NON-TRIVIAL BCS SOLUTION
C=======================================================================
C
      IF (BCSDEL.LT.1.D-05) THEN
C
          DO I=1,LSTATE
             DELTAS(I)=1.0
          END DO
C
      END IF
C
C=======================================================================
C         BCS INTERATIONS
C=======================================================================
C
      ITERTN=0
C
 7777 ITERTN=ITERTN+1
C
      DO I=1,LSTATE
         DELTA0(I)=DELTAS(I)
      END DO
C
C=======================================================================
C         CALCULATION OF NEW FERMI ENERGY EFERMI
C=======================================================================
C
      EFERM0=EFERMI
      SOESUM=0.0D0
      SORSUM=0.0D0
C
      ENTRPY(ICHARG) = 0.0D0
      EPSILO=1.0D-13
C
      DO I=1,LSTATE
         E  = ESINGP(I)
         EML= EFERM0-E
         EQP= SQRT(EML**2+DELTA0(I)**2)
         IF (I.EQ.NTQPAR) EQP= -EQP
         EQSPRT(I)= EQP
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
         IF (IFTEMP.EQ.1) THEN
C
             F1=(1.0D0-TANH(EQP/TEMP_T/2.0D0))/2.0D0
             FERMFN(I,ICHARG)=F1
             IF (ABS(F1).GT.EPSILO.AND.(1.0D0-F1).GT.EPSILO) THEN
                 ENTRPY(ICHARG)=ENTRPY(ICHARG)-F1 *LOG(F1)-
     *                                  (1.0D0-F1)*LOG(1.0D0-F1)
             END IF
             SOESUM = SOESUM + (1.0-E/EQP*(1.D0-2*FERMFN(I,ICHARG)))
             SORSUM = SORSUM +    1.0/EQP*(1.D0-2*FERMFN(I,ICHARG))
C
         ELSE
             SOESUM = SOESUM + (1.0-E/EQP)
             SORSUM = SORSUM + 1.0/EQP
         END IF
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
      END DO
C
      EFERMI= (REAL(NOPART)-SOESUM)/SORSUM
C
C=======================================================================
C         CALCULATIONS OF THE NEW GAPS DELTAS(I)
C=======================================================================
C
      IF (JPABCS.NE.2) THEN
C
          GAPERR= 0.0
          NORBIT= 0
          BCSDEL= 0.0
C
          DO I=1,LSTATE
C
             GAPSUM= 0.0
C
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
             IF (IFTEMP.EQ.1) THEN
                 DO J=1,LSTATE
                    GAPSUM=GAPSUM+PARELE(I,J)*DELTA0(J)/EQSPRT(J)
     *                        *TANH(EQSPRT(J)/TEMP_T/2.0D0)
                 END DO
             ELSE
                 DO J=1,LSTATE
                    GAPSUM=GAPSUM+PARELE(I,J)*DELTA0(J)/EQSPRT(J)
                 END DO
             END IF
C@@@ TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP - TEMP
C
             DELTAS(I)= GAPSUM
C
             IF (GAPSUM.GT.BCSDEL) BCSDEL= GAPSUM
C
             GAPSUM= ABS(DELTA0(I)-GAPSUM)
C
             IF (GAPSUM.GT.GAPERR) THEN
                 GAPERR= GAPSUM
                 NORBIT= I
             END IF
C
          END DO
C
      END IF
C
C=======================================================================
C         CONVERGENCE CRITERIA
C=======================================================================
C
      IF (ITERTN.GT.MAXITE) GO TO 9999
      IF (ABS(EFERMI-EFERM0).GE.EPSILF) GO TO 7777
      IF ((GAPERR.GE.EPSILF).AND.(BCSDEL.GE.EPSILG)) GO TO 7777
      IF ((GAPERR.GE.EPSILG).AND.(BCSDEL.LT.EPSILG)) GO TO 7777
C
 9999 CONTINUE
C
      IF (ITERTN.GT.MAXITE) THEN
         WRITE(NFIPRI,'(/,
     *         1X,18(1H/),''  BCS DOES NOT CONVERGE  IN  DELPAI'',
     *                                                     5X,18(1H/),/,
     *         1X,18(1H/),''  ICHARG='',I2,18X,''JPABCS='',I2,
     *                                                     2X,18(1H/),/,
     *         1X,18(1H/),''  EFERM0='',1PE10.3,''  EFERMI='',
     *                                            1PE10.3, 2X,18(1H/),/,
     *         1X,18(1H/),''  ORBITAL NO.='',I5,''  GAPERR='',
     *                                             E10.3, 2X,18(1H/)/)')
     *         ICHARG,JPABCS,EFERM0,EFERMI,NORBIT,GAPERR
      END IF
C
C=======================================================================
C         CALCULATIONS OF THE PAIRING OCCUPATION FACTORS V2OCCU(I),
C         FLUCTUATION IN THE NUMBER OF PARTICLES,
C         VARIAN=(DN)**2=:<gs|N**2|gs> - [<gs|N|gs>]**2
C               =4*Sum_i[u(i)**2*v(i)**2]=Sum_i{[Del(i)/E(i)]**2},
C         AND SPECTRAL GAP,
C         BCSDEL=<uvDel>=:Sum_i[u(i)*v(i)*Del(i)]/Sum_i[u(i)*v(i)]
C=======================================================================
C
      DISSUM= 0.0
      DITSUM= 0.0
      DIRSUM= 0.0
      VUDSUM= 0.0
      VUSUM = 0.0
C
      DO I=1,LSTATE
C
         E  = ESINGP(I)
         EML= EFERMI-E
         EQP= SQRT(EML**2+DELTAS(I)**2)
         IF (I.EQ.NTQPAR) EQP= -EQP
         EQSPRT(I)= EQP
C
         C        = EML/EQSPRT(I)
         V2OCCU(I)= (1.0+C)/2.0
         IF (V2OCCU(I).LT.1.0D-09) V2OCCU(I)=0.0
C
         U2OCCU= 1.0D0-V2OCCU(I)
         VU    = SQRT(V2OCCU(I)*U2OCCU)
         VUD   = VU*DELTAS(I)
         VUSUM = VUSUM + VU
         VUDSUM= VUDSUM+ VUD
C
         IF (IFTEMP.EQ.1) THEN
             S = DELTAS(I)/EQSPRT(I)
     *                   *TANH(EQSPRT(I)/TEMP_T/2.0D0)
         ELSE
             S = DELTAS(I)/EQSPRT(I)
         END IF
C
         SM(I) = S
         S2    = S*S
         DISSUM= DISSUM + S2
         DITSUM= DITSUM + S
         DIRSUM= DIRSUM + S*DELTAS(I)
C
      END DO
C
C     VARIAN= DISSUM
C
      IF (ABS(VUSUM).GT.1.E-12) THEN
          SPCDEL = VUDSUM/VUSUM
      ELSE
          SPCDEL = 1.E-12
      END IF
C
      IF (JPABCS.NE.2) THEN
          BCSDEL= SPCDEL
      END IF
C
C=======================================================================
C         CALCULATIONS OF THE PAIRING ENERGY: E_PAIR
C=======================================================================
C
      PAIRSU = 0.0
C
      DO I=1,LSTATE
C
         GAPSUM= 0.0
C
         IF (JPABCS.NE.2) THEN
C
             DO J=1,LSTATE
                GAPSUM= GAPSUM + PARELE(I,J)*SM(J)
             END DO
         ELSE
             GAPSUM= BCSDEL
C
         END IF
C
         PAIRSU= PAIRSU + GAPSUM*SM(I)
C
      END DO
C
      E_PAIR= -PAIRSU/2
C
C=======================================================================
C         THIS ESTIMATE OF THE PAIRING STRENGTH IS BASED ON THE SIMPLE
C         BCS EXPRESSION. IT IS VERY CRUDE.
C=======================================================================
C
      IF (JPABCS.NE.1) THEN
C
                               G_PAIR = 0.0D0
          IF (E_PAIR.NE.0.0D0) G_PAIR = -BCSDEL**2/E_PAIR
C
      END IF
C
C=======================================================================
C
      DO I=1,LSTATE
         V_OCCU(I)=SQRT(ABS(V2OCCU(I)))
      END DO
C
C=======================================================================
C         CHECKING THE NUMBER OF PARTICLES
C=======================================================================
C
      PARTNU=0.0
C
      IF (IFTEMP.EQ.1) THEN
          DO I=1,LSTATE
             PARTNU=PARTNU+2.0*V_OCCU(I)**2
     *           +2*(1.0D0-2.0*V_OCCU(I)**2)*FERMFN(I,ICHARG)
          END DO
      ELSE
          DO I=1,LSTATE
             PARTNU=PARTNU+2*V_OCCU(I)**2
          END DO
      END IF
C
      IF (ABS(PARTNU-NOPART).GT.100.*EPSILF) THEN
C
          WRITE (NFIPRI,'(/,1X,18(1H/),''                    NOPART ='',
     *                                             I4,  10X,18(1H/),/
     *                 1X,18(1H/),''  SUM OF V_OCCU  -  NOPART ='',
     *                                             E12.5,2X,18(1H/),/)')
     *                 NOPART,PARTNU-NOPART
C
C         STOP '  SUM OF V_OCCU .NE. NOPART IN DELPAI '
C
      END IF
C
C=======================================================================
      DEALLOCATE (PARELE)
C=======================================================================
C
      CALL CPUTIM('DELPAI',0)
C
C=======================================================================
C
      RETURN
      END
C
C=====================================================================
C
      SUBROUTINE SETPAI(IN_FIX,IZ_FIX,FACTOG,ICHARG,G_PAIR)
C
C=======================================================================
C         P A I R I N G     P A R A M E T R I Z A T I O N    (GUESSES)
C=======================================================================
C
      AA=IN_FIX+IZ_FIX
C
      IF (ICHARG.EQ.0) THEN
C
          IF (IZ_FIX.GE.88) THEN
C
              G_PAIR=(19.3D0-0.084D0*(IN_FIX-IZ_FIX))/AA
C
          ELSE
C
              G_PAIR=(18.95D0-0.078D0*(IN_FIX-IZ_FIX))/AA
C
          END IF
C
      ELSE
C
          IF (IZ_FIX.GE.88) THEN
C
              G_PAIR=(13.3D0+0.217D0*(IN_FIX-IZ_FIX))/AA
C
          ELSE
C
              G_PAIR=(17.90D0+0.176D0*(IN_FIX-IZ_FIX))/AA
C
          END IF
C
      END IF
C
      G_PAIR=G_PAIR*FACTOG
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GAVRAG(IN_FIX,IZ_FIX,FACTOG,ICHARG,GAPAIR)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          ESINGP(1:NDBASE)
      DIMENSION
     *          NAUXIL(1:NDBASE)
C
      COMMON
     *       /SPNUMS/ NUMBSP(0:NDREVE,0:NDISOS)
      COMMON
     *       /SIMSPE/ SPESIM(1:NDBASE)
C
C=======================================================================
C
C       SUBROUTINE GAVRAG CALCULATES THE SMOOTHED VALUE OF "G_PAIR"
C                  REPLACING IN THE BCS EQUATIONS,  THE SUMMATIONS
C                  BY AN INTEGRATION  WITH  THE STRUTINSKY DENSITY
C
C         EFERMI - FERMI ENERGY FOR WHICH THE DENSITY IS CALCULATED
C         GAPAIR - "AVERAGED" PAIRING FORCE STRENGTH  TO  BE  FOUND
C         NPAIRS - THE NUMBER OF PAIRS EQUAL TO THE NUMBER OF PARTICLES
C                  (THE SAME AS IN THE BCS EQUATIONS => SEE BELOW)
C
C=======================================================================
C
      NOLEVT=NUMBSP(0,ICHARG)
C
      A_MASS=REAL(IZ_FIX+IN_FIX)
C
                       NPAIRS=IN_FIX
      IF (ICHARG.EQ.1) NPAIRS=IZ_FIX
C
      DO I=1,NOLEVT
         NAUXIL(I)=I
         ESINGP(I)=SPESIM(I)
      END DO
C
C=======================================================================
C         THE ARRIVING SINGLE PARTICLE LEVELS ARE USUALLY NOT ORDERED
C         THEY WILL BE ORDERED HERE TO AVOID INCREASING ORDER PROBLEM
C=======================================================================
C
      CALL ORDER1(ESINGP,NAUXIL,NOLEVT)
C
      EFERMI=0.5*(ESINGP(NPAIRS/2)+ESINGP(NPAIRS/2+1))
C
      RHOBAR=0.5*DENS_E(EFERMI,IN_FIX,IZ_FIX,ESINGP,NOLEVT)
C
      DELBAR=12.0000/SQRT(A_MASS)
C
C=======================================================================
C
      GAPAIR=1.0/RHOBAR/LOG(SQRT(1.+(0.5*NPAIRS/RHOBAR/DELBAR)**2)
     *                              +0.5*NPAIRS/RHOBAR/DELBAR)
C
C=======================================================================
C
      GAPAIR=GAPAIR*FACTOG
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      FUNCTION DENS_E(EFERMI,IN_FIX,IZ_FIX,ESINGP,NOLEVT)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          COEFFM(1:NDSMTH)
      DIMENSION
     *          ESINGP(1:NDBASE)
      DIMENSION
     *          HERPOL(1:NDSMTH),DHRPOL(1:NDSMTH)
      DATA
     *     NPOLYN / 6 /
      DATA
     *     GSTRUT /1.2/
      DATA
     *     EXPLIM /20./
C
C=======================================================================
C          DENS_E  CALCULATES STRUTINSKY SMOOTHING FUNCTION
C=======================================================================
C
      PINUMB=4.0D0*ATAN(1.0D0)
C
      FACTOR=1.0D0
C
      DO KFACTO=2,NPOLYN,2
         FACTOR=FACTOR*KFACTO/2
         COEFFM(KFACTO)=(-1)**(KFACTO/2)/(2.0**KFACTO)/FACTOR
      END DO
C
C=======================================================================
C
      A_MASS=REAL(IN_FIX+IZ_FIX)
      HBAR_0=41.0D0/A_MASS**(1.0D0/3.0D0)
C
      GAMMAS=GSTRUT*HBAR_0
C
C=======================================================================
C
      SUMSTR=0.0D0
C
      DO N=1,NOLEVT
C
         UNSTRT=(EFERMI-ESINGP(N))/GAMMAS
         EXPUN2=0.
         SUMPOL=1.
C
         IF (ABS(UNSTRT).LE.EXPLIM) THEN
C
             EXPUN2=EXP(-UNSTRT*UNSTRT)
C
             CALL D_HERM(UNSTRT,NPOLYN,HERPOL,DHRPOL,NDSMTH)
C
             DO I=2,NPOLYN,2
                SUMPOL=SUMPOL+COEFFM(I)*HERPOL(I+1)
             END DO
C
         END IF
C
         SUMSTR=SUMSTR+EXPUN2*SUMPOL
C
      END DO
C
C=======================================================================
C         HERE ALL THE LEVELS ARE TREATED AS CORRESPONDING TO ONE
C         TIME REVERSAL ONLY (NO DEGENERACY).  IN ORDER TO OBTAIN
C         THE DENSITY OF DOUBLY DEGENERATE STATES WE MULTIPLY THE
C         RESULTING SUM BY A FACTOR OF TWO
C=======================================================================
C
      DENS_E=2.0*SUMSTR/GAMMAS/SQRT(PINUMB)
C
C=======================================================================
C
      RETURN
      END
C
C
C=======================================================================
C
      SUBROUTINE NORHER
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /FACHER/ HERFAC(0:ND2MAX)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE HERMITE-POLYNOMIAL NORMALIZATION
C        FACTORS AND STORES THEM IN COMMON. IT DOES THE SAME AS  NORFAC,
C        WHICH STORS THEM IN LOCAL ARRAY.
C=======================================================================
C
      HERFAC(0)=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
      DO I=1,ND2MAX
         HERFAC(I)=HERFAC(I-1)*SQRT(REAL(2*I))
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NORFAC(HERFAC,IDIMEN)
      IMPLICIT REAL*16 (A-H,O-Z)
      REAL HERFAC
      DIMENSION
     *          HERFAC(0:IDIMEN)
      DIMENSION
     *          HERFAQ(0:IDIMEN)
C
      FOUR=4
      ONE =1
C
      HERFAQ(0)=SQRT(SQRT(FOUR*ATAN(ONE)))
C
      DO I=1,IDIMEN
         TWO_I=2*I
         HERFAQ(I)=HERFAQ(I-1)*SQRT(TWO_I)
      END DO
C
      HERFAC=HERFAQ
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE NORFAQ(HERFAQ,IDIMEN)
      IMPLICIT REAL*16 (A-H,O-Z)
      DIMENSION
     *          HERFAQ(0:IDIMEN)
C
      FOUR=4
      ONE =1
C
      HERFAQ(0)=SQRT(SQRT(FOUR*ATAN(ONE)))
C
      DO I=1,IDIMEN
         TWO_I=2*I
         HERFAQ(I)=HERFAQ(I-1)*SQRT(TWO_I)
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HRECUR(PN,DPN,PN1,X,NN)
      IMPLICIT
     *         REAL*16 (A-H,O-Z)
C
C=======================================================================
C         AUXILIARY RECURRENCE ROUTINE (FROM THE MONOGRAPH BY STROUD)
C=======================================================================
C
      P1=1
      P =X
C
      DP1=0
      DP =1
C
      DO J=2,NN
C
         FJ =J
         FJ2=(FJ-1)/2
C
         Q =X*P-FJ2*P1
         DQ=X*DP+P-FJ2*DP1
C
         P1=P
         P =Q
C
         DP1=DP
         DP =DQ
C
      END DO
C
      PN=P
      DPN=DP
      PN1=P1
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE H_ROOT(X,NN,DPN,PN1,EPS)
      IMPLICIT
     *         REAL*16 (A-H,O-Z)
      REAL EPS
      DATA
     *     ITERMX / 25 /
C
C=======================================================================
C        IMPROVES THE APPROXIMATED ROOT X. IN ADDITION WE ALSO OBTAIN
C                                          PN1 = VALUE OF H(N-1) AT X
C        (FROM THE MONOGRAPH BY STROUD)
C=======================================================================
C
      ITER=0
   1  ITER=ITER+1
C
      CALL HRECUR(P,DP,PN1,X,NN)
C
      D=P/DP
      X=X-D
C
      IF (ABS(D).LE.EPS) GO TO 3
C
      IF (ITER.LT.ITERMX) THEN
          GO TO 1
      ELSE
          GO TO 4
      END IF
C
   3  DPN=DP
C
      RETURN
C
   4  CONTINUE
C
      DPN=DP
C
      PRINT 5,ITER,X,DP
   5  FORMAT(///,1X,'ITERATIONS IN H_ROOT, ITER = ',I2,'  X =',D20.10,
     *              '  DP = ',D20.10,///)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HERMIT(NN,X,A,NUGAUS)
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
C=======================================================================
      REAL*16
     *          XTT,DDPN,PPN1
C
      DIMENSION
     *          X(NUGAUS),A(NUGAUS)
C
      COMMON
     *       /HEREPS/ EPSHER
      COMMON
     *       /MUFACR/ NUFACR
C
C=======================================================================
C
C         HERMIT CALCULATES ZEROES X(I) OF THE N-TH ORDER HERMITE
C         POLYNOMIAL.   THE  LARGEST  ZERO  IS  STORED  IN  X(1).
C         IT CALCULATES  ALSO THE CORRESPONDING COEFFICIENTS A(I)
C         OF THE  NN-TH ORDER  GAUSS-HERMITE  QUADRATURE  FORMULA
C         OF THE DEGREE 2*NN-1 .
C
C         (TRIVIAL MODIFICATIONS OF THE ROUTINE FROM STROUD BOOK)
C
C=======================================================================
C
      PI=4.0D0*ATAN(1.0D0)
C
      EEPS=EPSHER
C
      N1=NN-1
      N2=(NN+1)/2
C
      IF (NN-1.GT.NUFACR) STOP ' NN-1 TOO LARGE IN HERMIT (1)'
C
      CC=SQRT(PI)*FACTOR(NN-1)/(2.0D0**N1)
      S=(2.0D0*NN+1)**.16667D0
C
      DO I=1,N2
C
C        IF (I-1) 10,1,2
         IF (I-1.LT.0) GO TO 10
         IF (I-1.EQ.0) GO TO 1
         IF (I-1.GT.0) GO TO 2
C
C=======================================================================
C            T H E   L A R G E S T    Z E R O
C=======================================================================
C
   1     XT=S**3-1.85575D0/S
C
         GO TO 9
C
C  2     IF (I-2) 10,3,4
   2     CONTINUE
         IF (I-2.LT.0) GO TO 10
         IF (I-2.EQ.0) GO TO 3
         IF (I-2.GT.0) GO TO 4
C
C=======================================================================
C            T H E     S E C O N D    Z E R O
C=======================================================================
C
   3     XT=XT-1.14D0*NN**.426D0/XT
C
         GO TO 9
C
C  4     IF (I-3) 10,5,6
   4     CONTINUE
         IF (I-3.LT.0) GO TO 10
         IF (I-3.EQ.0) GO TO 5
         IF (I-3.GT.0) GO TO 6
C
C=======================================================================
C            T H E     T H I R D     Z E R O
C=======================================================================
C
   5     XT=1.86D0*XT-.86D0*X(1)
C
         GO TO 9
C
C  6     IF (I-4) 10,7,8
   6     CONTINUE
         IF (I-4.LT.0) GO TO 10
         IF (I-4.EQ.0) GO TO 7
         IF (I-4.GT.0) GO TO 8
C
C=======================================================================
C            T H E     F O U R T H   Z E R O
C=======================================================================
C
   7     XT=1.91D0*XT-.91D0*X(2)
C
         GO TO 9
C
C=======================================================================
C            A L L     O T H E R   Z E R O S
C=======================================================================
C
   8     XT=2.0D0*XT-X(I-2)
C
   9     XTT=XT
C
C=======================================================================
         CALL H_ROOT(XTT,NN,DDPN,PPN1,EEPS)
C=======================================================================
C
         DPN=DDPN
         PN1=PPN1
         XT =XTT
C
         X(I)=XT
         A(I)=CC/DPN/PN1
         NI=NN-I+1
         X(NI)=-XT
         A(NI)=A(I)
C
      END DO
C
   10 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE HERMIQ(NN,X,A,NUGAUS)
C=======================================================================
      USE hfodd_sizes
      USE RFACTO
C=======================================================================
      IMPLICIT
     *         REAL*16 (A-H,O-Z)
      REAL
     *         EPSHER,EEPS
#if(SWITCH_QUAD==1)
#else
C      REAL
C     *         FACTOR
#endif
C
      DIMENSION
     *          X(NUGAUS),A(NUGAUS)
C
      COMMON
     *       /HEREPS/ EPSHER
      COMMON
     *       /MUFACR/ NUFACR
C
C=======================================================================
C
C         IDENTICAL TO HERMIT BUT IN QUADRUPLE PRECISION.
C
C         HERMIQ CALCULATES ZEROES X(I) OF THE N-TH ORDER HERMITE
C         POLYNOMIAL.   THE  LARGEST  ZERO  IS  STORED  IN  X(1).
C         IT CALCULATES  ALSO THE CORRESPONDING COEFFICIENTS A(I)
C         OF THE  NN-TH ORDER  GAUSS-HERMITE  QUADRATURE  FORMULA
C         OF THE DEGREE 2*NN-1 .
C
C         (TRIVIAL MODIFICATIONS OF THE ROUTINE FROM STROUD BOOK)
C
C=======================================================================
C
      FOUR=4
      ONE =1
      TWO =2
C
      PI=FOUR*ATAN(ONE)
C
      EEPS=EPSHER
C
      N1=NN-1
      N2=(NN+1)/2
C
      IF (NN-1.GT.NUFACR) STOP ' NN-1 TOO LARGE IN HERMIQ (1)'
C
      CC=SQRT(PI)*FACTOR(NN-1)/(TWO**N1)
      S=(TWO*NN+1)**.16667D0
C
      DO I=1,N2
C
C        IF (I-1) 10,1,2
         IF (I-1.LT.0) GO TO 10
         IF (I-1.EQ.0) GO TO 1
         IF (I-1.GT.0) GO TO 2
C
C=======================================================================
C            T H E   L A R G E S T    Z E R O
C=======================================================================
C
   1     XT=S**3-1.85575D0/S
C
         GO TO 9
C
C  2     IF (I-2) 10,3,4
   2     CONTINUE
         IF (I-2.LT.0) GO TO 10
         IF (I-2.EQ.0) GO TO 3
         IF (I-2.GT.0) GO TO 4
C
C=======================================================================
C            T H E     S E C O N D    Z E R O
C=======================================================================
C
   3     XT=XT-1.14D0*NN**.426D0/XT
C
         GO TO 9
C
C  4     IF (I-3) 10,5,6
   4     CONTINUE
         IF (I-3.LT.0) GO TO 10
         IF (I-3.EQ.0) GO TO 5
         IF (I-3.GT.0) GO TO 6
C
C=======================================================================
C            T H E     T H I R D     Z E R O
C=======================================================================
C
   5     XT=1.86D0*XT-.86D0*X(1)
C
         GO TO 9
C
C  6     IF (I-4) 10,7,8
   6     CONTINUE
         IF (I-4.LT.0) GO TO 10
         IF (I-4.EQ.0) GO TO 7
         IF (I-4.GT.0) GO TO 8
C
C=======================================================================
C            T H E     F O U R T H   Z E R O
C=======================================================================
C
   7     XT=1.91D0*XT-.91D0*X(2)
C
         GO TO 9
C
C=======================================================================
C            A L L     O T H E R   Z E R O S
C=======================================================================
C
   8     XT=TWO*XT-X(I-2)
C
   9     XTT=XT
C
C=======================================================================
         CALL H_ROOT(XTT,NN,DDPN,PPN1,EEPS)
C=======================================================================
C
         DPN=DDPN
         PN1=PPN1
         XT =XTT
C
         X(I)=XT
         A(I)=CC/DPN/PN1
         NI=NN-I+1
         X(NI)=-XT
         A(NI)=A(I)
C
      END DO
C
   10 CONTINUE
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE TIMPRI
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMALL*6,OUITEM(NDCOLU)*17
      CHARACTER
     *          TYTIME*10
C
      DIMENSION
     *          ATIALL(NDSUBR),NTIALL(NDSUBR),ITIALL(NDSUBR)
C
      COMMON
     *       /TIMEXE/ TIMALL(NDSUBR),TIMACT(NDSUBR),
     *                KONOFF(NDSUBR),NAMALL(NDSUBR),NUCALL(NDSUBR)
      COMMON
     *       /TIMNOW/ NUSUBR,TYTIME
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE PRINTS EXECUTION TIMES AND NUMBERS OF CALLS
C         FOR DIFFERENT SUBROUTINES
C=======================================================================
C
      IF (NUSUBR.GT.0) THEN
C
C=======================================================================
C         PRINT EXECUTION TIMES
C=======================================================================
C
          WRITE(NFIPRI,'(79(1H*),/,              1H*,77X,1H*,/,
     *                 1H*,2X,A10,''  EXECUTION  TIMES '',
     *                        ''IN SUBROUTINES'',    32X,1H*,/,
     *                 1H*,2X,''INCLUDING THEIR COMPLETE '',
     *                        ''DOWN-CALLING TREES'',32X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*)') TYTIME
C
          DO ITSUBR=1,NUSUBR
C
             ATIALL(ITSUBR)=    -TIMALL(ITSUBR)
             ITIALL(ITSUBR)= INT(TIMALL(ITSUBR))
             NTIALL(ITSUBR)=            ITSUBR
C
          END DO
C
          CALL ORDER1(ATIALL,NTIALL,NUSUBR)
C
          DO ITSUBR=1,NUSUBR,NDCOLU
C
             DO NUITEM=1,NDCOLU
                OUITEM(NUITEM)='                 '
             END DO
C
             MXITEM=MIN(NUSUBR-ITSUBR+1,NDCOLU)
C
             DO NUITEM=1,MXITEM
C
                MUSUBR=ITSUBR+NUITEM-1
C
                IF (KONOFF(MUSUBR).EQ.1) THEN
C
                    WRITE(NFIPRI,'(/,     1X,19(1H/),
     *                    '' IN TIMPRI TIME IS STILL ON FOR '',
     *                                 A6,3X,19(1H/),/)') NAMALL(MUSUBR)
C
                    STOP ' IN TIMPRI TIME IS STILL ON'
C
                END IF
C
                WRITE(OUITEM(NUITEM),'(I7,'' => '',A6)')
     *                     ITIALL(NTIALL(MUSUBR)),NAMALL(NTIALL(MUSUBR))
C
             END DO
C
          WRITE(NFIPRI,'(1H*,2X,4A17,7X,1H*,/,1H*,77X,1H*)')
     *             (OUITEM(NUITEM),NUITEM=1,NDCOLU)
C
          END DO
C
C=======================================================================
C         PRINT NUMBERS OF CALLS
C=======================================================================
C
          WRITE(NFIPRI,'(79(1H*),/,              1H*,77X,1H*,/,
     *                 1H*,2X,''NUMBERS OF CALLS '',
     *                        ''TO SUBROUTINES'',    44X,1H*,/,
     *                                           1H*,77X,1H*,/,
     *                                               79(1H*),/,
     *                                           1H*,77X,1H*)')
C
          DO ITSUBR=1,NUSUBR
C
             ATIALL(ITSUBR)=-NUCALL(ITSUBR)
             ITIALL(ITSUBR)= NUCALL(ITSUBR)
             NTIALL(ITSUBR)=        ITSUBR
C
          END DO
C
          CALL ORDER1(ATIALL,NTIALL,NUSUBR)
C
          DO ITSUBR=1,NUSUBR,NDCOLU
C
             DO NUITEM=1,NDCOLU
                OUITEM(NUITEM)='                 '
             END DO
C
             MXITEM=MIN(NUSUBR-ITSUBR+1,NDCOLU)
C
             DO NUITEM=1,MXITEM
C
                MUSUBR=ITSUBR+NUITEM-1
C
                WRITE(OUITEM(NUITEM),'(I7,'' => '',A6)')
     *                     ITIALL(NTIALL(MUSUBR)),NAMALL(NTIALL(MUSUBR))
C
             END DO
C
          WRITE(NFIPRI,'(1H*,2X,4A17,7X,1H*,/,1H*,77X,1H*)')
     *             (OUITEM(NUITEM),NUITEM=1,NDCOLU)
C
          END DO
C
          WRITE(NFIPRI,'(79(1H*))')
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      BLOCK DATA OLDIES
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          SPKART*10,SPNILS*15,SPORDE*13
      CHARACTER
     *          OLKART*10,OLNILS*15,OLORDE*13
      CHARACTER
     *          PNKART*10,PNNILS*15,PNORDE*13
      CHARACTER
     *          ONKART*10,ONNILS*15,ONORDE*13
C
      COMMON
     *       /SPLEVS/ SPENER(1:2*NDSTAT,0:NDISOS),
     *                SPOCCU(1:2*NDSTAT,0:NDISOS),
     *                SPALIG(1:2*NDSTAT,0:NDISOS),
     *                SPSPAL(1:2*NDSTAT,0:NDISOS),
     *                SPPARI(1:2*NDSTAT,0:NDISOS),
     *                SPSIMP(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSTAT/ SPXALI(1:2*NDSTAT,0:NDISOS),
     *                SPZALI(1:2*NDSTAT,0:NDISOS),
     *                SPXSPI(1:2*NDSTAT,0:NDISOS),
     *                SPZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLABS/ SPKART(1:2*NDSTAT,0:NDISOS),
     *                SPNILS(1:2*NDSTAT,0:NDISOS),
     *                SPORDE(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPLOLD/ OLALIG(1:2*NDSTAT,0:NDISOS),
     *                OLSPAL(1:2*NDSTAT,0:NDISOS),
     *                OLPARI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPSOLD/ OLXALI(1:2*NDSTAT,0:NDISOS),
     *                OLZALI(1:2*NDSTAT,0:NDISOS),
     *                OLXSPI(1:2*NDSTAT,0:NDISOS),
     *                OLZSPI(1:2*NDSTAT,0:NDISOS)
      COMMON
     *       /SPKOLD/ OLKART(1:2*NDSTAT,0:NDISOS),
     *                OLNILS(1:2*NDSTAT,0:NDISOS),
     *                OLORDE(1:2*NDSTAT,0:NDISOS)
C
      COMMON
     *       /PNLEVS/ PNENER(1:4*NDSTAT),
     *                PNOCCU(1:4*NDSTAT),
     *                PNALIG(1:4*NDSTAT),
     *                PNSPAL(1:4*NDSTAT),
     *                PNPARI(1:4*NDSTAT),
     *                PNSIMP(1:4*NDSTAT),
     *                PNISOS(1:4*NDSTAT)
      COMMON
     *       /PNSTAT/ PNXALI(1:4*NDSTAT),
     *                PNZALI(1:4*NDSTAT),
     *                PNXSPI(1:4*NDSTAT),
     *                PNZSPI(1:4*NDSTAT)
      COMMON
     *       /PNLABS/ PNKART(1:4*NDSTAT),
     *                PNNILS(1:4*NDSTAT),
     *                PNORDE(1:4*NDSTAT)
      COMMON
     *       /PNLOLD/ ONALIG(1:4*NDSTAT),
     *                ONSPAL(1:4*NDSTAT),
     *                ONPARI(1:4*NDSTAT)
      COMMON
     *       /PNSOLD/ ONXALI(1:4*NDSTAT),
     *                ONZALI(1:4*NDSTAT),
     *                ONXSPI(1:4*NDSTAT),
     *                ONZSPI(1:4*NDSTAT)
      COMMON
     *       /PNKOLD/ ONKART(1:4*NDSTAT),
     *                ONNILS(1:4*NDSTAT),
     *                ONORDE(1:4*NDSTAT)
C
      DATA
     *                SPENER /NDDATA*0.0D0/,
     *                SPOCCU /NDDATA*0.0D0/,
     *                SPALIG /NDDATA*0.0D0/,
     *                SPSPAL /NDDATA*0.0D0/,
     *                SPPARI /NDDATA*0.0D0/,
     *                SPSIMP /NDDATA*0.0D0/
      DATA
     *                SPXALI /NDDATA*0.0D0/,
     *                SPZALI /NDDATA*0.0D0/,
     *                SPXSPI /NDDATA*0.0D0/,
     *                SPZSPI /NDDATA*0.0D0/
      DATA
     *                SPKART /NDDATA*'..........'     /,
     *                SPNILS /NDDATA*'...............'/,
     *                SPORDE /NDDATA*'.............'  /
      DATA
     *                OLALIG /NDDATA*0.0D0/,
     *                OLSPAL /NDDATA*0.0D0/,
     *                OLPARI /NDDATA*0.0D0/
      DATA
     *                OLXALI /NDDATA*0.0D0/,
     *                OLZALI /NDDATA*0.0D0/,
     *                OLXSPI /NDDATA*0.0D0/,
     *                OLZSPI /NDDATA*0.0D0/
      DATA
     *                OLKART /NDDATA*'..........'     /,
     *                OLNILS /NDDATA*'...............'/,
     *                OLORDE /NDDATA*'.............'  /
      DATA
     *                PNENER /NDDATA*0.0D0/,
     *                PNOCCU /NDDATA*0.0D0/,
     *                PNALIG /NDDATA*0.0D0/,
     *                PNSPAL /NDDATA*0.0D0/,
     *                PNPARI /NDDATA*0.0D0/,
     *                PNSIMP /NDDATA*0.0D0/,
     *                PNISOS /NDDATA*0.0D0/
      DATA
     *                PNXALI /NDDATA*0.0D0/,
     *                PNZALI /NDDATA*0.0D0/,
     *                PNXSPI /NDDATA*0.0D0/,
     *                PNZSPI /NDDATA*0.0D0/
      DATA
     *                PNKART /NDDATA*'..........'     /,
     *                PNNILS /NDDATA*'...............'/,
     *                PNORDE /NDDATA*'.............'  /
      DATA
     *                ONALIG /NDDATA*0.0D0/,
     *                ONSPAL /NDDATA*0.0D0/,
     *                ONPARI /NDDATA*0.0D0/
      DATA
     *                ONXALI /NDDATA*0.0D0/,
     *                ONZALI /NDDATA*0.0D0/,
     *                ONXSPI /NDDATA*0.0D0/,
     *                ONZSPI /NDDATA*0.0D0/
      DATA
     *                ONKART /NDDATA*'..........'     /,
     *                ONNILS /NDDATA*'...............'/,
     *                ONORDE /NDDATA*'.............'  /
C
      END
C
C=======================================================================
C
      BLOCK DATA ALLENS
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          ALL_EN(1:NDENES)
      COMMON
     *       /ALLENE/ EKIN_N,EKIN_P,EKIN_T,
     *                EPOT_N,EPOT_P,EPOT_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *                EREA_N,EREA_P,EREA_T,
     *                ELIP_N,ELIP_P,ELIP_T,
     *
     *                ECOULD,ECOULE,ECOULT,
     *                       ECOULS,ECOULV,
     *
     *                EMULCO,EMUSLO,EMUREA,
     *                ESIFCO,ESISLO,ESIREA,
     *                ESPICO,ESPSLO,ESPREA,
     *
     *                ENREAR,ECORCM,ECOR_R,
     *
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
      COMMON
     *       /ISOENE/ EISOCO,EISSLO,EISREA
C
      EQUIVALENCE
     *            (EKIN_N,ALL_EN)
C
      DATA
     *                ALL_EN /NDENES*0.0D0/
      DATA
     *                EISOCO /0.0D0/,EISSLO /0.0D0/,EISREA /0.0D0/
C
      END
C
C=======================================================================
C
      BLOCK DATA CPUDAT
C
      CHARACTER
     *          TYTIME*10
C
      COMMON
     *       /TIMNOW/ NUSUBR,TYTIME
C
      DATA
     *       NUSUBR /0/,TYTIME /'         '/
C
      END
C
C=======================================================================
C
      BLOCK DATA CONPHY
C
      COMMON
     *       /PHYCON/ H_BARC,XMASSP,XMASSN,HBCOE2
      COMMON
     *       /PHYPIO/ PIMASS,G_AXIC,PIDECA
C
C=======================================================================
C
C         IN THIS PROGRAM, THE DEFINITIONS OF THE H_BAR,  MASS, AND E**2
C         FACTORS ARE:
C
C                       H_BAR*C    = 197.32891 MEV * FM
C                       MASS *C**2 = 938.90590 MEV
C                       H_BAR*C/E2 = 137.03602D0
C
C         THESE PARTICULAR VALUES EXIST, AT PRESENT, IN  A L L OTHER
C         WOODS-SAXON CODES. THE NEWER EXPERIMENTAL VALUES ARE GIVEN
C         BELOW (COMMENTED OUT DATA STATEMENT) BUT PRESENTLY UNUSED.
C
C         THE KINETIC ENERGY COEFFICIENT IS DENOTED:
C
C                              HBMASS
C
C         THE KINETIC ENERGY COEFFICIENT CONTAINING THE 'RECOIL TERM'
C         IS DENOTED:
C                              HBMRPA = HBMASS*(1-1/A)
C
C         THE OTHER HARTREE-FOCK CODES (COORDINATE SPACE CODES) USE:
C
C                   H_BAR = 6.582180 MEV * 10**(-22)  SEC
C                   MASS  = 1.044673 MEV * 10**(-22) (SEC/FM)**2
C
C=======================================================================
C
C         THESE CODES USE ONLY THE COMBINATION HBM = H_BAR**2/2*MASS
C         WHICH FOR THE NUMERICAL CONSTANTS USED AT PRESENT GIVES:
C
C                         HBM = 20.736209 MEV * FM**2
C
C         OLDER HARTREE-FOCK CODES, USING THE CYLINDRICAL OSCILLATOR
C         BASIS HAVE DIRECTLY HBM=H_BARC**2/(2*XMASSN). NUMERICALLY:
C
C                         HBM = 20.73     MEV * FM**2
C
C         THE COORDINATE-SPACE HARTREE-FOCK CODES USE:
C
C                         HBM = 20.73620  MEV * FM**2
C
C         THE SKI FORCES HAVE BEEN FITTED WITH:
C
C                         HBM = 20.7525   MEV * FM**2
C
C         THE SKO FORCES HAVE BEEN FITTED WITH:
C
C                         HBM = 20.73553  MEV * FM**2
C
C         THE E**2 FACTOR USED IN THE COULOMB POTENTIAL IS CALCULATED AS
C
C                         E**2 = H_BARC / HBCOE2  MEV * FM
C
C=======================================================================
C
C         AFTER FINISHING THE TEST THE AVERAGE 0.5*(M_PROT+M_NEUT)
C         WILL BE USED; FOR THE MOMENT DUPA.
C         TRZEBA WRESZCIE SPRAWDZIC SKAD POCHODZI TA WARTOSC XMASSN
C
C=======================================================================
C
      DATA
     *     H_BARC,XMASSP,XMASSN / 197.32891D0, 938.27231D0, 938.90590D0/
C    *     H_BARC,XMASSP,XMASSN /197.327053D0, 938.27231D0, 939.56563D0/
C
      DATA
     *     HBCOE2 / 137.03602D0 /
C    *     HBCOE2 / 137.035989D0 /
C
      DATA
     *     PIMASS,G_AXIC,PIDECA / 0.7045D0, 1.27D0, 0.4677D0 /
C
C          PIMASS = PION MASS IN FM^{-1}
C          G_AXIC = AXIAL COUPLING CONSTANT
C          PIDECA = PION DECAY CONSTANT = 92.3 MEV / H_BARC
C
      END
C
C=======================================================================
C
      BLOCK DATA HEADER
C
      COMMON
     *       /PNHEAD/ I_HEAD
C
      DATA
     *     I_HEAD /0/
C
      END
C
C=======================================================================
C
      BLOCK DATA GEFFEC
C=======================================================================
      USE hfodd_sizes
C=======================================================================
C
      COMMON
     *       /G_FACT/ G_SPIN(0:NDISOS),G_ORBI(0:NDISOS)
      DATA
     *      G_SPIN /-3.826D0,5.586D0/,
     *      G_ORBI / 0.000D0,1.000D0/
C
      END
C
C=======================================================================
C
      SUBROUTINE CPUTIM(NAMSUB,IONOFF)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      CHARACTER
     *          NAMSUB*6,NAMALL*6
      CHARACTER
     *          TYTIME*10
C
CETIM INTEGER*4
CETIM*          DUMMY
CUNIX INTEGER*4
CUNIX*          TIME,DUMMY
CF32  INTEGER*2
CF32 *          IHOURS,IMINUT,ISECON,IHUNDR
C
      COMMON
     *       /TIMEXE/ TIMALL(NDSUBR),TIMACT(NDSUBR),
     *                KONOFF(NDSUBR),NAMALL(NDSUBR),NUCALL(NDSUBR)
      COMMON
     *       /TIMNOW/ NUSUBR,TYTIME
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C         THIS SUBROUTINE COLLECTS EXECUTION TIMES FOR DIFFERENT
C         SUBROUTINES
C=======================================================================
C
      I_SUBR=0
C
C=======================================================================
C         TRACING THE CALLS
C=======================================================================
C
C     IF (IONOFF.EQ.1)
C    *    WRITE(NFIPRI,'('' ENTERING SUBROUTINE: '', A6)') NAMSUB
C     IF (IONOFF.EQ.0)
C    *    WRITE(NFIPRI,'('' LEAVING  SUBROUTINE: '',A13)') NAMSUB
C
C=======================================================================
C         THE SUBROUTINE IS IDENTIFIED BY ITS NAME. CONSECUTIVE
C         NUMBERS ARE ATTRIBUTED TO SUBROUTINES IN THE SEQUENCE
C         OF CONSECUTIVE CALLS TO CPUTIM.
C=======================================================================
C
      IF (NUSUBR.GT.0) THEN
C
          DO MUSUBR=1,NUSUBR
             IF (NAMALL(MUSUBR).EQ.NAMSUB) I_SUBR=MUSUBR
          END DO
C
      ELSE
C
          DO MUSUBR=1,NDSUBR
             KONOFF(MUSUBR)=0
             TIMACT(MUSUBR)=0
          END DO
C
      END IF
C
      IF (I_SUBR.EQ.0) THEN
C
          IF (NUSUBR.GE.NDSUBR) STOP ' TOO LARGE NUSUBR IN CPUTIM'
C
          NUSUBR=NUSUBR+1
          I_SUBR=NUSUBR
          NAMALL(I_SUBR)=NAMSUB
          TIMALL(I_SUBR)=0
          NUCALL(I_SUBR)=0
C
      END IF
C
      TSCNDS=0
C
C=======================================================================
C         HERE A CALL IS MADE TO INTEGER*4 FUNCTION  "TIME"
C         WHICH RETURNS THE TIME OF THE REAL CLOCK  OF  THE
C         SYSTEM. ANY OTHER TIME-RETURNING  SUBROUTINE  CAN
C         REPLACE "TIME".
C=======================================================================
C
CUNIX TYTIME='REAL-CLOCK'
CSAL  TYTIME='REAL-CLOCK'
CF32  TYTIME='REAL-CLOCK'
C
CUNIX TSCNDS= TIME(DUMMY)
CSAL  CALL DCLOCK@(SECNDS)
CSAL  TSCNDS=SECNDS
CF32  CALL GETTIM(IHOURS,IMINUT,ISECON,IHUNDR)
CF32  TSCNDS=3600*IHOURS+60*IMINUT+ISECON+IHUNDR/100.
C
C=======================================================================
C         HERE A CALL IS MADE TO INTEGER*4 FUNCTION "ETIME"
C         WHICH RETURNS  THE  PROCESSOR  CPU  TIME  OF  THE
C         SYSTEM. ANY OTHER TIME-RETURNING  SUBROUTINE  CAN
C         REPLACE "eTIME".
C=======================================================================
C
CETIM TYTIME='PROCESSOR '
      TYTIME='PROCESSOR '
C
CETIM TSCNDS=ETIME(DUMMY(1))
      CALL CPU_TIME(ATIME)
      TSCNDS=ATIME
C
C=======================================================================
C
      IF (IONOFF.NE.0.AND.IONOFF.NE.1) STOP ' WRONG IONOFF IN CPUTIM'
C
      IF (IONOFF.EQ.1) THEN
C
C=======================================================================
C         HERE THE TIME IS SET
C=======================================================================
C
          IF (KONOFF(I_SUBR).EQ.1) THEN
C
              WRITE(NFIPRI,'(/,'' TIME IS ALREADY ON IN CPUTIM'',
     *                         '' FOR THE SUBROUTINE: '', A6)') NAMSUB
C
              STOP ' TIME IS ALREADY ON  IN CPUTIM'
C
          END IF
C
          TIMACT(I_SUBR)=TSCNDS
          KONOFF(I_SUBR)=1
          NUCALL(I_SUBR)=NUCALL(I_SUBR)+1
C
      ELSE
C
C=======================================================================
C         HERE THE TIME IS COLLECTED
C=======================================================================
C
          IF (KONOFF(I_SUBR).EQ.0) THEN
C
              WRITE(NFIPRI,'(/,'' TIME IS ALREADY OFF IN CPUTIM'',
     *                         '' FOR THE SUBROUTINE: '', A6)') NAMSUB
C
              STOP ' TIME IS ALREADY OFF  IN CPUTIM'
C
          END IF
C
          TIMALL(I_SUBR)=TIMALL(I_SUBR)+TSCNDS-TIMACT(I_SUBR)
          KONOFF(I_SUBR)=0
C
      END IF
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE DIAMAT(CELMTS,EIGVAL,EWAVEF,LDACTU,NDACTU,NUMVEC)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
#if(USE_MPI==1)
      INTEGER :: escapeSignal
#endif
      COMPLEX
     *          C_ZERO,CELMTS,EWAVEF
      COMPLEX
     *          AUXDIC
      COMPLEX
     *          UNPMAT,AUXZHC
C
C=======================================================================
      CHARACTER
     *          SWI*1
C=======================================================================
      ALLOCATABLE UNPMAT(:,:)
      ALLOCATABLE AUXZHC(:)
      ALLOCATABLE AUXZHR(:)
      ALLOCATABLE IAUXZH(:)
      ALLOCATABLE ISUPPZ(:)
      ALLOCATABLE AUXDIA(:)
      ALLOCATABLE AUXDIC(:)
      ALLOCATABLE AUXDID(:)
      ALLOCATABLE IAUXDI(:)
      ALLOCATABLE I_FAIL(:)
C=======================================================================
      DIMENSION
     *          CELMTS(1:((NDACTU+1)*NDACTU)/2)
      DIMENSION
     *          EIGVAL(1:NDACTU)
      DIMENSION
     *          EWAVEF(1:NDACTU,1:NDACTU)
C
      COMMON
     *       /EIGLIM/ EIGMIN,EIGMAX
      COMMON
     *       /CFIPRI/ NFIPRI
#if(USE_MPI==1)
      COMMON
     *       /SIGNAL/ escapeSignal
#endif
C
C=======================================================================
C
      CALL CPUTIM('DIAMAT',1)
C
C=======================================================================
C
C         THIS IS AN AUXILIARY ROUTINE WHICH FORMS AN INTERFACE TO
C         DIFFERENT LIBRARY DIAGONALIZATION ROUTINES.
C
C         Below is an excerpt of the LAPACK Usder's Guide
C
C        "There are four types of driver routines for symmetric and
C         Hermitian eigenproblems. Originally LAPACK had just the
C         simple and expert drivers described below, and the other two
C         were added after improved algorithms were discovered. Ultima-
C         tely we expect the algorithm in the most recent driver (called
C         RRR below) to supersede all the others, but in LAPACK 3.x the
C         other drivers may still be faster on some problems, so we
C         retain them.
C
C           * A simple driver (name ending -EV) computes all the
C             eigenvalues and (optionally) eigenvectors.
C
C           * An expert driver (name ending -EVX) computes all or a
C             selected subset of the eigenvalues and (optionally)
C             eigenvectors. If few enough eigenvalues or eigenvectors
C             are desired, the expert driver is faster than the simple
C             driver.
C
C           * A divide-and-conquer driver (name ending -EVD) solves
C             the same problem as the simple driver. It is much faster
C             than the simple driver for large matrices, but uses more
C             workspace. The name divide-and-conquer refers to the
C             underlying algorithm.
C
C           * A relatively robust representation (RRR) driver (name
C             ending -EVR) computes all or (in a later release) a
C             subset of the eigenvalues, and (optionally) eigenvectors.
C             It is the fastest algorithm of all (except for a few
C             cases), and uses the least workspace. The name RRR
C             refers to the underlying algorithm."
C
C=======================================================================
C
      IF (NDACTU.GT.NDBASD) STOP 'NDACTU.GT.NDBASD IN DIAMAT'
      IF (LDACTU.GT.NDACTU) STOP 'LDACTU.GT.NDACTU IN DIAMAT'
C
      NUMFOU=0
      INFORM=1
C
      JZHPEV=0
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C          ZEROING THE MATRIX OF EIGENVECTORS
C=======================================================================
C
      EWAVEF(:,:)=C_ZERO
C
C=======================================================================
C                            CRAY
C=======================================================================
C
#if(SWITCH_DIAG==0)
C
      IALLOC=0
C
      ALLOCATE (AUXDIA(1:4*NDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXDIA','DIAMAT')
C
      NAUXDI=4*LDACTU
C
      JZHPEV=1
      CALL ZHPEV(1,CELMTS,EIGVAL,EWAVEF,NDACTU,LDACTU,AUXDIA,NAUXDI)
C
      DEALLOCATE(AUXDIA)
C
#endif
C
C=======================================================================
C                  SIMPLE DRIVER IN PACKED STORAGE
C=======================================================================
C
#if(SWITCH_DIAG==1)
C
      IALLOC=0
      INFORM=0
C
      LDWORK=2*LDACTU-1
      ALLOCATE(AUXDIC(1:LDWORK),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXDIC','DIAMAT')
C
      LRWORK=3*LDACTU-2
      ALLOCATE(AUXDID(1:LRWORK),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXDID','DIAMAT')
C
      JZHPEV=1
      CALL ZHPEV('V','L',LDACTU,CELMTS,EIGVAL,EWAVEF,
     *                   NDACTU,AUXDIC,AUXDID,INFORM)
C
      IF (INFORM.NE.0) THEN
C
          WRITE(NFIPRI,'(//,1X,20(1H=),
     *                   ''  ERROR IN ZHPEV, INFORM='',
     *                   I4,1X,20(1H=),/,
     *                      1X,79(1H=))')
     *
     *          INFORM
C
#if(USE_MPI==1)
C
          CALL CPUTIM('DIAMAT',0)
C
          escapeSignal = 1
          RETURN
#else
          STOP ' ERROR IN ZHPEV'
#endif
C
      END IF
C
      DEALLOCATE(AUXDIC,AUXDID)
C
#endif
C
C=======================================================================
C               EXPERT DRIVER IN PACKED STORAGE
C=======================================================================
C
#if(SWITCH_DIAG==2)
C
      IALLOC=0
      INFORM=0
C
      ALLOCATE (AUXDIC(1:2*LDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXDIC','DIAMAT')
      ALLOCATE (AUXDID(1:7*LDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXDID','DIAMAT')
      ALLOCATE (IAUXDI(1:5*LDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('IAUXDI','DIAMAT')
      ALLOCATE (I_FAIL(1:LDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('I_FAIL','DIAMAT')
C
      DO I=1,LDACTU
         I_FAIL(I)=0
      END DO
C
      IF (NUMVEC.EQ.0) THEN
          SWI='V'
      ELSE
          SWI='I'
      END IF
C
      ABSTOL=2*DLAMCH('S')
C
      JZHPEV=1
      CALL ZHPEVX('V',SWI,'L',LDACTU,CELMTS,EIGMIN,EIGMAX,1,NUMVEC,
     *                        ABSTOL,NUMFOU,EIGVAL,EWAVEF,NDACTU,
     *                        AUXDIC,AUXDID,IAUXDI,I_FAIL,INFORM)
C
      IF (NUMVEC.EQ.0) NUMVEC=NUMFOU
C
      IF (INFORM.NE.0.OR.NUMVEC.NE.NUMFOU) THEN
C
          WRITE(NFIPRI,'(//,1X,20(1H/),
     *                      '' ERROR IN ZHPEVX, INFORM='',
     *                   I4,1X,20(1H/),/,1X,20(1H/),
     *                      '' ERROR IN ZHPEVX, NUMVEC='',
     *                   I4,1X,20(1H/),/,1X,20(1H/),
     *                      '' ERROR IN ZHPEVX, NUMFOU='',
     *                   I4,1X,20(1H/),/)')
     *
     *          INFORM,NUMVEC,NUMFOU
C
          DO I=1,LDACTU
             IF (I_FAIL(I).GT.0) THEN
                 WRITE(6,'(''I = '',i4,'' I_FAIL = '',i4)')
     *                       I,I_FAIL(I)
             END IF
          END DO
C
#if(USE_MPI==1)
C
          CALL CPUTIM('DIAMAT',0)
C
          escapeSignal = 1
          RETURN
#else
          STOP ' ERROR IN ZHPEVX'
#endif
C
      END IF
C
      DEALLOCATE (AUXDIC,AUXDID,IAUXDI,I_FAIL)
C
#endif
C
C=======================================================================
C      RELATIVELY ROBUST REPRESENTATION (RRR) DRIVER IN UNPACKED
C      STORAGE
C=======================================================================
C
#if(SWITCH_DIAG==3)
C
      IALLOC=0
      INFORM=0
C
      ALLOCATE (UNPMAT(1:NDACTU,1:NDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('UNPMAT','DIAMAT')
      ALLOCATE (AUXZHC(1:32*NDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXZHC','DIAMAT')
      ALLOCATE (AUXZHR(1:24*NDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXZHR','DIAMAT')
      ALLOCATE (IAUXZH(1:10*NDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('IAUXZH','DIAMAT')
      ALLOCATE (ISUPPZ(1:2*NDACTU),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('ISUPPZ','DIAMAT')
C
C     UNPACK MATRIX. ONLY THE LOWER TRIANGLE NEEDS TO BE FILLED
C
      NCOUNT=0
C
      DO IKET=1,LDACTU
         DO IBRA=IKET,LDACTU
C
            NCOUNT=NCOUNT+1
            UNPMAT(IBRA,IKET)=CELMTS(NCOUNT)
C
         END DO
      END DO
C
      IF (NUMVEC.EQ.0) THEN
          SWI='V'
      ELSE
          SWI='I'
      END IF
C
      ABSTOL=2*DLAMCH('S')
C
      JZHPEV=1
      CALL ZHEEVR('V',SWI,'L',LDACTU,UNPMAT,NDACTU,EIGMIN,EIGMAX,
     *           1,NUMVEC,ABSTOL,NUMFOU,EIGVAL,EWAVEF,NDACTU,
     *             ISUPPZ,AUXZHC,32*NDACTU,AUXZHR,
     *             24*NDACTU,IAUXZH,10*NDACTU,INFORM)
C
      IF (NUMVEC.EQ.0) NUMVEC=NUMFOU
C
      IF (INFORM.NE.0.OR.NUMVEC.NE.NUMFOU) THEN
C
          WRITE(NFIPRI,'(//,1X,20(1H/),
     *                      '' ERROR IN ZHEEVR, INFORM='',
     *                   I4,1X,20(1H/),/,1X,20(1H/),
     *                      '' ERROR IN ZHEEVR, NUMVEC='',
     *                   I4,1X,20(1H/),/,1X,20(1H/),
     *                      '' ERROR IN ZHEEVR, NUMFOU='',
     *                   I4,1X,20(1H/),/)')
     *
     *          INFORM,NUMVEC,NUMFOU
C
#if(USE_MPI==1)
C
          CALL CPUTIM('DIAMAT',0)
C
          escapeSignal = 1
          RETURN
#else
          STOP ' ERROR IN ZHEEVR'
#endif
C
      END IF
C
      DEALLOCATE (ISUPPZ,AUXZHC,AUXZHR,IAUXZH,UNPMAT)
C
#endif
C
C=======================================================================
C      DIVIDE AND CONQUER DRIVER IN UNPACKED STORAGE
C=======================================================================
C
#if(SWITCH_DIAG==4)
C
      IALLOC=0
      INFORM=0
C
C     UNPACK MATRIX. ONLY THE LOWER TRIANGLE NEEDS TO BE FILLED
C
      NCOUNT=0
C
      DO IKET=1,LDACTU
         DO IBRA=IKET,LDACTU
C
            NCOUNT=NCOUNT+1
            EWAVEF(IBRA,IKET)=CELMTS(NCOUNT)
C
         END DO
      END DO
C
      LDWORK=LDACTU*LDACTU+2*LDACTU
      ALLOCATE (AUXDIC(1:LDWORK),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXDIC','DIAMAT')
C
      LRWORK=1+5*LDACTU+2*LDACTU**2
      ALLOCATE (AUXZHC(1:LRWORK),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AUXZHC','DIAMAT')
C
      LIWORK=3+5*LDACTU
      ALLOCATE (IAUXZH(1:LIWORK),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('IAUXZH','DIAMAT')
C
      JZHPEV=1
      CALL ZHEEVD('V','L',LDACTU,EWAVEF,NDACTU,EIGVAL,
     *                    AUXDIC,LDWORK,AUXZHC,LRWORK,
     *                    IAUXZH,LIWORK,INFORM)
C
      IF (INFORM.NE.0) THEN
C
          WRITE(NFIPRI,'(//,1X,20(1H=),
     *                   ''  ERROR IN ZHPEV, INFORM='',
     *                   I4,1X,20(1H=),/,
     *                      1X,79(1H=))')
     *
     *          INFORM
C
#if(USE_MPI==1)
C
          CALL CPUTIM('DIAMAT',0)
C
          escapeSignal = 1
          RETURN
#else
          STOP ' ERROR IN ZHEEVD'
#endif
C
      END IF
C
      DEALLOCATE (IAUXZH,AUXDIC,AUXZHC)
C
#endif
C
C=======================================================================
C
      IF (JZHPEV.NE.1) STOP 'switch_diag .NE. 0,1,2,3,4 IN DIAMAT ?'
C
C=======================================================================
C
      CALL CPUTIM('DIAMAT',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INVWAV(LSTATE,INIINV,INIKAR,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,FACSPI,UNIT_I,WDUMMY
C
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN)
      DIMENSION
     *          IFACTO(0:NDSPIN),I_SPIN(0:NDSPIN),IDUMMY(0:NDSPIN)
      DIMENSION
     *          WDUMMY(0:NDSPIN)
C
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('INVWAV',1)
C
C=======================================================================
C        THIS SUBROUTINE PERFORMS THE D2H TRANSFORMATION OF THE
C        WAVE FUNCTION, SEE PRC62-014310, EQS. (27)
C=======================================================================
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
      DO IBASE=1,LDBASE
C
         NX=NXVECT(IBASE,1)
         NY=NYVECT(IBASE,1)
         NZ=NZVECT(IBASE,1)
C
         IFACTO(0)=0
C
C=======================================================================
C        IDENTITY
C=======================================================================
C
         IF (INIKAR.EQ.0) THEN
C
             FACSPI=1.0D0
             IFACTO(0)=1
             IFACTO(1)=1
             I_SPIN(0)=0
             I_SPIN(1)=1
C
         END IF
C
C=======================================================================
C        X-SIGNATURE
C=======================================================================
C
         IF (INIKAR.EQ.1) THEN
C
             FACSPI=UNIT_I
             IFACTO(0)=(-1)**(NY+NZ+1)
             IFACTO(1)=(-1)**(NY+NZ+1)
             I_SPIN(0)=1
             I_SPIN(1)=0
C
         END IF
C
C=======================================================================
C        Y-SIGNATURE
C=======================================================================
C
         IF (INIKAR.EQ.2) THEN
C
             FACSPI=1.0D0
             IFACTO(0)=(-1)**(NX+NZ)
             IFACTO(1)=(-1)**(NX+NZ+1)
             I_SPIN(0)=1
             I_SPIN(1)=0
C
         END IF
C
C=======================================================================
C        Z-SIGNATURE
C=======================================================================
C
         IF (INIKAR.EQ.3) THEN
C
             FACSPI=UNIT_I
             IFACTO(0)=(-1)**(NX+NY+1)
             IFACTO(1)=(-1)**(NX+NY)
             I_SPIN(0)=0
             I_SPIN(1)=1
C
         END IF
C
C=======================================================================
C        INVERSION
C=======================================================================
C
         IF (INIINV.EQ.1.OR.INIINV.EQ.3) THEN
C
             IFACTO(0)=IFACTO(0)*(-1)**(NX+NY+NZ)
             IFACTO(1)=IFACTO(1)*(-1)**(NX+NY+NZ)
C
         END IF
C
C=======================================================================
C        TIME-REVERSAL
C=======================================================================
C
         IF (INIINV.EQ.2.OR.INIINV.EQ.3) THEN
C
             FACSPI=CONJG(FACSPI)
             IDUMMY(0)=IFACTO(I_SPIN(0))
             IDUMMY(1)=IFACTO(I_SPIN(1))*(-1)
             IFACTO(0)=IDUMMY(0)
             IFACTO(1)=IDUMMY(1)
             IDUMMY(0)=I_SPIN(1)
             IDUMMY(1)=I_SPIN(0)
             I_SPIN(0)=IDUMMY(0)
             I_SPIN(1)=IDUMMY(1)
C
             DO ISTATE=1,LSTATE
                DO ISPIN=0,NDSPIN
C
                   WARIGH(IBASE,ISTATE,ISPIN)=
     *                                 CONJG(WARIGH(IBASE,ISTATE,ISPIN))
C
                END DO
             END DO
C
         END IF
C
C=======================================================================
C        PERFORMING THE TRANSFORMATION
C=======================================================================
C
         IF (IFACTO(0).EQ.0) STOP' INCORRECT INIINV OR INIKAR IN INVWAV'
C
         DO ISTATE=1,LSTATE
C
            DO ISPIN=0,NDSPIN
               WDUMMY(ISPIN)=WARIGH(IBASE,ISTATE,I_SPIN(ISPIN))
     *                            *FACSPI*IFACTO(I_SPIN(ISPIN))
            END DO
C
            DO ISPIN=0,NDSPIN
               WARIGH(IBASE,ISTATE,ISPIN)=WDUMMY(ISPIN)
            END DO
C
         END DO
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INVWAV',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ROTWAV(LSTATE,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,CNEW,C_ZERO,BUP,BDN,CUP,CDN
C
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *          CNEW(1:NDBASE,0:NDSPIN)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /RMATRI/ ROTOPE(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /RANGLE/ ALPROT,BETROT,GAMROT
C
C=======================================================================
C
      CALL CPUTIM('ROTWAV',1)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      ALFA = ALPROT
      BETA = BETROT
      GAMA = GAMROT
C
C=======================================================================
C
C  ROTATION (ACTIVE) OPERATOR IS DEFINED AS:
C  ----------------------------------------
C         R(OMEGA) = R(ALFA) R(BETA) R(GAMA) =
C                  = EXP(-i*ALFA*J_z) EXP(-i*BETA*J_y) EXP(-i*GAMA*J_z)
C
C  TRANSFORMATION GOES ACCORDING TO THE FOLLOWING STANDARD RULES:
C
C  POSITION VECTOR:  r' = R(OMEGA)r  --->  r' = D(OMEGA)r =
C                                             = D(ALFA)D(BETA)D(GAMA)r
C
C  WHERE:
C
C  D(OMEGA) =
C    |COS(ALFA) -SIN(ALFA)|| COS(BETA) SIN(BETA)||COS(GAMA) -SIN(GAMA)|
C    |SIN(ALFA)  COS(ALFA)||-SIN(BETA) COS(BETA)||SIN(GAMA)  COS(GAMA)|
C
C  SCALAR FIELD (WAVE FUNCTION) PHI(r) TRANSFORMS AS:
C
C    R(OMEGA)PHI(r) = PHI(R^-1(OMEGA)r) =
C                   = PHI(D(-GAMA)D(-BETA)D(-ALFA)r)
C
C  THE CODE PERFORMS ROTATION IN THREE CONSEQUTIVE STEPS:
C
C  R(GAMA)PHI (r) = PHI (D(-GAMA)r) = PHI' (r) ---> DECOM. IN Oxyz BASIS
C  R(BETA)PHI'(r) = PHI'(D(-BETA)r) = PHI" (r) ---> DECOM. IN Oxyz BASIS
C  R(ALFA)PHI"(r) = PHI"(D(-ALFA)r) = PHI"'(r) ---> DECOM. IN Oxyz BASIS
C
C=======================================================================
C     FIRST SPATIAL ROTATION AROUND Z-AXIS BY AN ANGLE "GAMA"
C=======================================================================
C
      IROT=1
      CALL ROTHER(IROT,GAMA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NZ.EQ.NZVECT(JBASE,1)) THEN
C
                   NXP=NXVECT(JBASE,1)
                   NYP=NYVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NX,NY,NXP,NYP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C     SECOND SPATIAL ROTATION AROUND Y-AXIS BY AN ANGLE "BETA"
C=======================================================================
C
C --> IROT=-1 ASSURES RIGHT-HANDED ROTATION:
C
      IROT=-1
      CALL ROTHER(IROT,BETA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NY.EQ.NYVECT(JBASE,1)) THEN
C
                   NXP=NXVECT(JBASE,1)
                   NZP=NZVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NX,NZ,NXP,NZP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C     FINAL SPATIAL ROTATION AROUND Z-AXIS BY AN ANGLE "ALFA"
C=======================================================================
C
      IROT=1
      CALL ROTHER(IROT,ALFA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NZ.EQ.NZVECT(JBASE,1)) THEN
C
                   NXP=NXVECT(JBASE,1)
                   NYP=NYVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NX,NY,NXP,NYP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C
C=======================================================================
C     ROTATE SPIN:
C=======================================================================
C
C
      BUP = -SIN(BETA/2.)*CMPLX(COS((ALFA-GAMA)/2.),
     *                         -SIN((ALFA-GAMA)/2.))
      BDN =  SIN(BETA/2.)*CMPLX(COS((ALFA-GAMA)/2.),
     *                          SIN((ALFA-GAMA)/2.))
C
      CUP =  COS(BETA/2.)*CMPLX(COS((ALFA+GAMA)/2.),
     *                         -SIN((ALFA+GAMA)/2.))
      CDN =  COS(BETA/2.)*CMPLX(COS((ALFA+GAMA)/2.),
     *                          SIN((ALFA+GAMA)/2.))
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C --> SPIN DOWN:
            CNEW(IBASE,0) =
     *                WARIGH(IBASE,ISTATE,0)*CDN+
     *                WARIGH(IBASE,ISTATE,1)*BDN
C --> SPIN UP:
            CNEW(IBASE,1) =
     *                WARIGH(IBASE,ISTATE,1)*CUP+
     *                WARIGH(IBASE,ISTATE,0)*BUP
C
            WARIGH(IBASE,ISTATE,0) = CNEW(IBASE,0)
            WARIGH(IBASE,ISTATE,1) = CNEW(IBASE,1)
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('ROTWAV',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GAUWAV(MPAHFB,LUPPER,LTOTST,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,UNIT_I
C
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /GANGLE/ PHIGAU
C
C=======================================================================
C
      CALL CPUTIM('GAUWAV',1)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C
C  FOR MPAHFB=0
C  THIS SUBROUTINE PERFORMS THE GAUGE ROTATION OF THE SINGLE-PARTICLE
C  WAVE FUNCTIONS. THIS  OPTION  IS  MAINTAINED  ONLY  BECAUSE  OF  A
C  POSSIBLE USE OF HF FOR ONE TYPE OF PARTICLES ONLY.
C
C  FOR MPAHFB=1
C  THIS SUBROUTINE PERFORMS THE GAUGE ROTATION OF THE UPPER AND LOWER
C  COMPONENTS OF THE HFB QUASIPARTICLE WAVE FUNCTIONS.
C
C  WHILE THE UPPER COMPONENTS B* TRANSFORM AS STANDARD SINGLE-PARTICLE
C  SATES, I.E. B'* = R(OMEGA) B*, THE ROTATED LOWER COMPONENT IS GIVEN
C  BY A'* = R(Omega)* A*.  MOREOVER,  THE RUSSIAN CONVENTION HAS TO BE
C  REMOVED BEFORE R* IS APPLIED,  THEN PUT BACK TO KEEP  THE STRUCTURE
C  OF THE WARIGH ARRAY.
C
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.LTOTST.NE.2*LUPPER) THEN
C
          WRITE (*,'(''LUPPER='',I5,''LTOTST='',I5,'' IN GAUWAV'')')
     *                 LUPPER,        LTOTST
C
          STOP 'LTOTST.NE.2*LUPPER IN GAUVAW'
C
      END IF
C
C=======================================================================
C         BUILDING THE QUASIPARTICLE OR SINGLE-PARTICLE  WAVE  FUNCTIONS
C         ROTATED IN THE GAUGE SPACE
C=======================================================================
C
      DO ISTATE=1,LUPPER
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE       ,ISPIN) =
     *         WARIGH(IBASE,ISTATE       ,ISPIN) * EXP( UNIT_I*PHIGAU)
C
               IF (MPAHFB.EQ.1)
     *
     *         WARIGH(IBASE,ISTATE+LUPPER,ISPIN) =
     *         WARIGH(IBASE,ISTATE+LUPPER,ISPIN) * EXP(-UNIT_I*PHIGAU)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('GAUWAV',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE GTZWAV(MPAHFB,LUPPER,LTOTST,WARIGH,ICHARG)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,UNIT_I
C
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /GTZANG/ PHI_TZ
C
C=======================================================================
C
      CALL CPUTIM('GTZWAV',1)
C
      UNIT_I=CMPLX(0.0D0,1.0D0)
C
C=======================================================================
C
C  FOR MPAHFB=0
C  THIS SUBROUTINE PERFORMS THE GAUGE ROTATION OF THE SINGLE-PARTICLE
C  WAVE FUNCTIONS. THIS  OPTION  IS  MAINTAINED  ONLY  BECAUSE  OF  A
C  POSSIBLE USE OF HF FOR ONE TYPE OF PARTICLES ONLY.
C
C  FOR MPAHFB=1
C  THIS SUBROUTINE PERFORMS THE GAUGE ROTATION OF THE UPPER AND LOWER
C  COMPONENTS OF THE HFB QUASIPARTICLE WAVE FUNCTIONS.
C
C  WHILE THE UPPER COMPONENTS B* TRANSFORM AS STANDARD SINGLE-PARTICLE
C  SATES, I.E. B'* = R(OMEGA) B*, THE ROTATED LOWER COMPONENT IS GIVEN
C  BY A'* = R(Omega)* A*.  MOREOVER,  THE RUSSIAN CONVENTION HAS TO BE
C  REMOVED BEFORE R* IS APPLIED,  THEN PUT BACK TO KEEP  THE STRUCTURE
C  OF THE WARIGH ARRAY.
C
C=======================================================================
C
      IF (MPAHFB.EQ.1.AND.LTOTST.NE.2*LUPPER) THEN
C
          WRITE (*,'(''LUPPER='',I5,''LTOTST='',I5,'' IN GTZWAV'')')
     *                 LUPPER,        LTOTST
C
          STOP 'LTOTST.NE.2*LUPPER IN GTZVAW'
C
      END IF
C
C=======================================================================
C         BUILDING THE QUASIPARTICLE OR SINGLE-PARTICLE  WAVE  FUNCTIONS
C         ROTATED IN THE TZ-GAUGE SPACE
C=======================================================================
C
      IF (ICHARG.EQ.0) I_SIGN=+1
      IF (ICHARG.EQ.1) I_SIGN=-1
C
      DO ISTATE=1,LUPPER
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE       ,ISPIN) =
     *         WARIGH(IBASE,ISTATE       ,ISPIN) *
     *                                        EXP( UNIT_I*I_SIGN*PHI_TZ)
C
               IF (MPAHFB.EQ.1)
     *
     *         WARIGH(IBASE,ISTATE+LUPPER,ISPIN) =
     *         WARIGH(IBASE,ISTATE+LUPPER,ISPIN) *
     *                                        EXP(-UNIT_I*I_SIGN*PHI_TZ)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('GTZWAV',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ROTLQP(LUPPER,LTOTST,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,AWAVQP
C
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN)
      ALLOCATABLE
     *          AWAVQP(:,:,:)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /RANGLE/ ALPROT,BETROT,GAMROT
C
C=======================================================================
C
      CALL CPUTIM('ROTLQP',1)
C
C=======================================================================
C
C  THIS SUBROUTINE PERFORMS THE SPATIAL AND SPIN ROTATION OF THE LOWER
C  COMPONENTS OF THE HFB QUASIPARTICLE WAVE FUNCTIONS.
C
C  WHILE THE UPPER COMPONENTS B* TRANSFORM AS STANDARD SINGLE-PARTICLE
C  SATES, I.E. B'* = R(OMEGA) B*, THE ROTATED LOWER COMPONENT IS GIVEN
C  BY A'* = R(Omega)* A*.  MOREOVER,  THE RUSSIAN CONVENTION HAS TO BE
C  REMOVED BEFORE R* IS APPLIED,  THEN PUT BACK TO KEEP  THE STRUCTURE
C  OF THE WARIGH ARRAY.
C
C=======================================================================
C
      IF (LTOTST.NE.2*LUPPER) THEN
C
          WRITE (*,'(''LUPPER='',I5,''LTOTST='',I5,'' IN ROTLQP'')')
     *                 LUPPER,        LTOTST
C
          STOP 'LTOTST.NE.2*LUPPER IN ROTLQP'
C
      END IF
C
C=======================================================================
C     COLLECTING A* REMOVING THE RUSSIAN CONVENTION
C=======================================================================
C
      ALLOCATE (AWAVQP(1:NDBASE,1:4*NDSTAT,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('AWAVQP','ROTLQP')
C
      DO ISPIN=0,NDSPIN
C
         AWAVQP(1:LDBASE,1:LUPPER,ISPIN)=
     *           (1-2*ISPIN)*WARIGH(1:LDBASE,LUPPER+1:LTOTST,1-ISPIN)
C
      END DO
C
C=======================================================================
C     BUILDING A'* AS (R(OMEGA)A)*
C=======================================================================
C
      AWAVQP=CONJG(AWAVQP)
C
      CALL ROTWAV(LUPPER,AWAVQP)
C
      AWAVQP=CONJG(AWAVQP)
C
C=======================================================================
C     PUTTING BACK THE RUSSIAN CONVENTION
C=======================================================================
C
      DO ISPIN=0,NDSPIN
C
         WARIGH(1:LDBASE,LUPPER+1:LTOTST,ISPIN)=
     *             (2*ISPIN-1)*AWAVQP(1:LDBASE,1:LUPPER,1-ISPIN)
C
      END DO
C
C=======================================================================
      DEALLOCATE (AWAVQP)
C=======================================================================
C
      CALL CPUTIM('ROTLQP',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RUSSOF(LUPPER,LTOTST,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,WARTMP
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN)
      ALLOCATABLE
     *          WARTMP(:,:,:)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('RUSSOF',1)
C
C=======================================================================
C  THIS SUBROUTINE REMOVES THE RUSSIAN CONVENTION FROM THE WARIGH ARRAY
C=======================================================================
C
      ALLOCATE (WARTMP(1:NDBASE,1:LUPPER,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WARTMP','RUSSOF')
C
      DO ISPIN=0,NDSPIN
C
         WARTMP(1:LDBASE,1:LUPPER,ISPIN)=
     *          (1-2*ISPIN)*WARIGH(1:LDBASE,LUPPER+1:LTOTST,1-ISPIN)
C
      END DO
C
      WARIGH(1:LDBASE,LUPPER+1:LTOTST,:)=WARTMP(1:LDBASE,1:LUPPER,:)
C
C=======================================================================
      DEALLOCATE (WARTMP)
C=======================================================================
C
      CALL CPUTIM('RUSSOF',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE RUSSON(LUPPER,LTOTST,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,WARTMP
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN)
      ALLOCATABLE
     *          WARTMP(:,:,:)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('RUSSON',1)
C
C=======================================================================
C  THIS SUBROUTINE PUTS THE RUSSIAN CONVENTION IN THE WARIGH ARRAY
C=======================================================================
C
      ALLOCATE (WARTMP(1:NDBASE,1:LUPPER,0:NDSPIN),STAT=IALLOC)
      IF (IALLOC.NE.0) CALL NOALLO('WARTMP','RUSSON')
C
      DO ISPIN=0,NDSPIN
C
         WARTMP(1:LDBASE,1:LUPPER,ISPIN)=
     *          (2*ISPIN-1)*WARIGH(1:LDBASE,LUPPER+1:LTOTST,1-ISPIN)
C
      END DO
C
      WARIGH(1:LDBASE,LUPPER+1:LTOTST,:)=WARTMP(1:LDBASE,1:LUPPER,:)
C
C=======================================================================
      DEALLOCATE (WARTMP)
C=======================================================================
C
      CALL CPUTIM('RUSSON',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ROTYXY(LSTATE,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,CNEW,C_ZERO,BUP,BDN,CUP,CDN
C
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *          CNEW(1:NDBASE,0:NDSPIN)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /RMATRI/ ROTOPE(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /RANGLE/ ALPROT,BETROT,GAMROT
C
C=======================================================================
C
      CALL CPUTIM('ROTYXY',1)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      ALFA = ALPROT
      BETA = BETROT
      GAMA = GAMROT
C
C=======================================================================
C
C  ROTATION (ACTIVE) OPERATOR IS DEFINED AS:
C  ----------------------------------------
C         R(OMEGA) = R(ALFA) R(BETA) R(GAMA) =
C                  = EXP(-i*ALFA*J_y) EXP(-i*BETA*J_x) EXP(-i*GAMA*J_y)
C
C  SEE SUBROUTINE ROTWAV FOR COMMENTS
C
C  D(OMEGA) =
C   | COS(ALFA)  SIN(ALFA)||COS(BETA) -SIN(BETA)|| COS(GAMA) SIN(GAMA)|
C   |-SIN(ALFA)  COS(ALFA)||SIN(BETA)  COS(BETA)||-SIN(GAMA) COS(GAMA)|
C
C=======================================================================
C     FIRST SPATIAL ROTATION AROUND Y-AXIS BY AN ANGLE "GAMMA"
C=======================================================================
C
C --> IROT=-1 ASSURES RIGHT-HANDED ROTATION:
      IROT=-1
      CALL ROTHER(IROT,GAMA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NY.EQ.NYVECT(JBASE,1)) THEN
C
                   NXP=NXVECT(JBASE,1)
                   NZP=NZVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NX,NZ,NXP,NZP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C     SECOND SPATIAL ROTATION AROUND X-AXIS BY AN ANGLE "BETA"
C=======================================================================
C
      IROT=1
      CALL ROTHER(IROT,BETA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NX.EQ.NXVECT(JBASE,1)) THEN
C
                   NYP=NYVECT(JBASE,1)
                   NZP=NZVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NY,NZ,NYP,NZP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C     FINAL SPATIAL ROTATION AROUND Y-AXIS BY AN ANGLE "ALFA"
C=======================================================================
C
C --> IROT=-1 ASSURES RIGHT-HANDED ROTATION:
      IROT=-1
      CALL ROTHER(IROT,ALFA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NY.EQ.NYVECT(JBASE,1)) THEN
C
                   NXP=NXVECT(JBASE,1)
                   NZP=NZVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NX,NZ,NXP,NZP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C     ROTATE SPIN:
C=======================================================================
C
      CA = COS(ALFA/2.) ; SA = SIN(ALFA/2.) ; CB = COS(BETA/2.)
      SB = SIN(BETA/2.) ; CG = COS(GAMA/2.) ; SG = SIN(GAMA/2.)
C
      BUP = CMPLX(-SA*CB*CG-CA*CB*SG , CA*SB*CG+SA*SB*SG)
      BDN = CMPLX(CA*CB*SG+SA*CB*CG , CA*SB*CG+SA*SB*SG)
C
      CUP = CMPLX(CA*CB*CG-SA*CB*SG , CA*SB*SG-SA*SB*CG)
      CDN = CMPLX(CA*CB*CG-SA*CB*SG , SA*SB*CG-CA*SB*SG)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C --> SPIN DOWN:
            CNEW(IBASE,0) =
     *                WARIGH(IBASE,ISTATE,0)*CDN+
     *                WARIGH(IBASE,ISTATE,1)*BDN
C --> SPIN UP:
            CNEW(IBASE,1) =
     *                WARIGH(IBASE,ISTATE,1)*CUP+
     *                WARIGH(IBASE,ISTATE,0)*BUP
C
            WARIGH(IBASE,ISTATE,0) = CNEW(IBASE,0)
            WARIGH(IBASE,ISTATE,1) = CNEW(IBASE,1)
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('ROTYXY',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ROTXZX(LSTATE,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,CNEW,C_ZERO,BUP,BDN,CUP,CDN
C
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *          CNEW(1:NDBASE,0:NDSPIN)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /RMATRI/ ROTOPE(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /RANGLE/ ALPROT,BETROT,GAMROT
C
C=======================================================================
C
      CALL CPUTIM('ROTXZX',1)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      ALFA = ALPROT
      BETA = BETROT
      GAMA = GAMROT
C
C=======================================================================
C
C  ROTATION (ACTIVE) OPERATOR IS DEFINED AS:
C  ----------------------------------------
C         R(OMEGA) = R(ALFA) R(BETA) R(GAMA) =
C                  = EXP(-i*ALFA*J_x) EXP(-i*BETA*J_z) EXP(-i*GAMA*J_x)
C
C  SEE SUBROUTINE ROTWAV FOR COMMENTS
C
C  D(OMEGA) =
C   |COS(ALFA) -SIN(ALFA)||COS(BETA) -SIN(BETA)||COS(GAMA) -SIN(GAMA)|
C   |SIN(ALFA)  COS(ALFA)||SIN(BETA)  COS(BETA)||SIN(GAMA)  COS(GAMA)|
C
C=======================================================================
C     FIRST SPATIAL ROTATION AROUND X-AXIS BY AN ANGLE "GAMMA"
C=======================================================================
C
      IROT=1
      CALL ROTHER(IROT,GAMA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NX.EQ.NXVECT(JBASE,1)) THEN
C
                   NYP=NYVECT(JBASE,1)
                   NZP=NZVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NY,NZ,NYP,NZP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C     SECOND SPATIAL ROTATION AROUND Z-AXIS BY AN ANGLE "BETA"
C=======================================================================
C
      IROT=1
      CALL ROTHER(IROT,BETA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NZ.EQ.NZVECT(JBASE,1)) THEN
C
                   NXP=NXVECT(JBASE,1)
                   NYP=NYVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NX,NY,NXP,NYP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C     FINAL SPATIAL ROTATION AROUND X-AXIS BY AN ANGLE "ALFA"
C=======================================================================
C
      IROT=1
      CALL ROTHER(IROT,ALFA)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C
            NX=NXVECT(IBASE,1)
            NY=NYVECT(IBASE,1)
            NZ=NZVECT(IBASE,1)
C
            CNEW(IBASE,0)=C_ZERO
            CNEW(IBASE,1)=C_ZERO
C
            DO JBASE=1,LDBASE
C
               IF (NX.EQ.NXVECT(JBASE,1)) THEN
C
                   NYP=NYVECT(JBASE,1)
                   NZP=NZVECT(JBASE,1)
C
                   DO ISPIN=0,NDSPIN
C
                      CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                WARIGH(JBASE,ISTATE,ISPIN)*ROTOPE(NY,NZ,NYP,NZP)
C
                   END DO
C
               END IF
C
            END DO
         END DO
C
         DO IBASE=1,LDBASE
            DO ISPIN=0,NDSPIN
C
               WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
            END DO
         END DO
C
      END DO
C
C=======================================================================
C     ROTATE SPIN:
C=======================================================================
C
C
      CA = COS(ALFA/2.) ; SA = SIN(ALFA/2.) ; CB = COS(BETA/2.)
      SB = SIN(BETA/2.) ; CG = COS(GAMA/2.) ; SG = SIN(GAMA/2.)
C
      BUP = CMPLX(CA*SB*SG-SA*SB*CG , SA*CB*CG+CA*CB*SG)
      BDN = CMPLX(SA*SB*CG-CA*SB*SG , CA*CB*SG+SA*CB*CG)
C
      CUP = CMPLX(CA*CB*CG-SA*CB*SG , -SA*SB*SG-CA*SB*CG)
      CDN = CMPLX(CA*CB*CG-SA*CB*SG , CA*SB*CG+SA*SB*SG)
C
      DO ISTATE=1,LSTATE
C
         DO IBASE=1,LDBASE
C --> SPIN DOWN:
            CNEW(IBASE,0) =
     *                WARIGH(IBASE,ISTATE,0)*CDN+
     *                WARIGH(IBASE,ISTATE,1)*BDN
C --> SPIN UP:
            CNEW(IBASE,1) =
     *                WARIGH(IBASE,ISTATE,1)*CUP+
     *                WARIGH(IBASE,ISTATE,0)*BUP
C
            WARIGH(IBASE,ISTATE,0) = CNEW(IBASE,0)
            WARIGH(IBASE,ISTATE,1) = CNEW(IBASE,1)
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('ROTXZX',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ROTISO(LSTATE,TARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          TARIGH,CNEW,C_ZERO,BUP,BDN,CUP,CDN
C
      DIMENSION
     *          TARIGH(1:2*NDBASE,1:4*NDSTAT,0:NDSPIN),
     *            CNEW(1:2*NDBASE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /RANISO/ ALPISO,BETISO,GAMISO
C
C=======================================================================
C
      CALL CPUTIM('ROTISO',1)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      ALFA = ALPISO
      BETA = BETISO
      GAMA = GAMISO
C
C=======================================================================
C     ROTATE ISOSPIN:
C=======================================================================
C
      BUP = -SIN(BETA/2.)*CMPLX(COS((ALFA-GAMA)/2.),
     *                         -SIN((ALFA-GAMA)/2.))
      BDN =  SIN(BETA/2.)*CMPLX(COS((ALFA-GAMA)/2.),
     *                          SIN((ALFA-GAMA)/2.))
C
      CUP =  COS(BETA/2.)*CMPLX(COS((ALFA+GAMA)/2.),
     *                         -SIN((ALFA+GAMA)/2.))
      CDN =  COS(BETA/2.)*CMPLX(COS((ALFA+GAMA)/2.),
     *                          SIN((ALFA+GAMA)/2.))
C
      DO ISPIN=0,NDSPIN
C
         DO ISTATE=1,LSTATE
C
            DO IBASE=1,LDBASE
C
               JBASE=IBASE+LDBASE
C
C -->    ISOSPIN UP = NEUTRONS = FIRST BLOCK:
C
               CNEW(IBASE) =
     *                   TARIGH(IBASE,ISTATE,ISPIN)*CUP+
     *                   TARIGH(JBASE,ISTATE,ISPIN)*BUP
C
C -->    ISOSPIN DOWN PROTONS = SECOND BLOCK:
C
               CNEW(JBASE) =
     *                   TARIGH(JBASE,ISTATE,ISPIN)*CDN+
     *                   TARIGH(IBASE,ISTATE,ISPIN)*BDN
C
               TARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE)
               TARIGH(JBASE,ISTATE,ISPIN) = CNEW(JBASE)
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('ROTISO',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SHIWAV(LSTATE,WARIGH)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          WARIGH,CNEW,C_ZERO
C
      DIMENSION
     *          WARIGH(1:NDBASE,1:4*NDSTAT,0:NDSPIN),
     *          CNEW(1:NDBASE,0:NDSPIN)
      COMMON
     *       /BASISO/ NXVECT(1:NDBASE,1:NDTWCE),
     *                NYVECT(1:NDBASE,1:NDTWCE),
     *                NZVECT(1:NDBASE,1:NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
      COMMON
     *       /SMATRI/ SHIOPE(0:NDOSCI,0:NDOSCI)
      COMMON
     *       /SVECTO/ BSHIFT(NDKART)
C
C=======================================================================
C
      CALL CPUTIM('SHIWAV',1)
C
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C
C  SHIFT (ACTIVE) OPERATOR IS DEFINED AS:
C  ----------------------------------------
C         R(BSHIFT) = R(BSHIFT(1)) R(BSHIFT(2)) R(BSHIFT(3)) =
C                   = EXP(-i*BSHIFT(1)*P_x)
C                     EXP(-i*BSHIFT(2)*P_y)
C                     EXP(-i*BSHIFT(3)*P_z)
C
C  TRANSFORMATION GOES ACCORDING TO THE FOLLOWING STANDARD RULES:
C
C  POSITION VECTOR:  r' = R(BSHIFT)r  --->  r' = r - BSHIFT
C
C  SCALAR FIELD (WAVE FUNCTION) PHI(r) TRANSFORMS AS:
C
C    R(BSHIFT)PHI(r) = PHI(R^-1(BSHIFT)r) = = PHI(r+BSHIFT)
C
C  THE CODE PERFORMS THE SHIFT IN THREE CONSEQUTIVE STEPS:
C
C  R(BSHIFT(1))PHI (r) = PHI (r+BSHIFT(1)) = PHI' (r)
C  R(BSHIFT(2))PHI'(r) = PHI'(r+BSHIFT(2)) = PHI" (r)
C  R(BSHIFT(3))PHI"(r) = PHI"(r+BSHIFT(3)) = PHI"'(r)
C
C=======================================================================
C     LOOP OVER THE SHIFT DIRECTIONS
C=======================================================================
C
      DO KARTEZ=1,NDKART
C
         IF (BSHIFT(KARTEZ).NE.0.0D0) THEN
C
             CALL SHIHER(KARTEZ)
C
             DO ISTATE=1,LSTATE
C
                DO IBASE=1,LDBASE
C
                   NX=NXVECT(IBASE,1)
                   NY=NYVECT(IBASE,1)
                   NZ=NZVECT(IBASE,1)
C
                   CNEW(IBASE,0)=C_ZERO
                   CNEW(IBASE,1)=C_ZERO
C
                   DO JBASE=1,LDBASE
C
                      IF (KARTEZ.EQ.1.AND.(NY.EQ.NYVECT(JBASE,1).AND.
     *                                     NZ.EQ.NZVECT(JBASE,1)).OR.
     *                    KARTEZ.EQ.2.AND.(NZ.EQ.NZVECT(JBASE,1).AND.
     *                                     NX.EQ.NXVECT(JBASE,1)).OR.
     *                    KARTEZ.EQ.3.AND.(NX.EQ.NXVECT(JBASE,1).AND.
     *                                     NY.EQ.NYVECT(JBASE,1))) THEN
C
                          IF (KARTEZ.EQ.1) NN=NXVECT(IBASE,1)
                          IF (KARTEZ.EQ.1) NP=NXVECT(JBASE,1)
C
                          IF (KARTEZ.EQ.2) NN=NYVECT(IBASE,1)
                          IF (KARTEZ.EQ.2) NP=NYVECT(JBASE,1)
C
                          IF (KARTEZ.EQ.3) NN=NZVECT(IBASE,1)
                          IF (KARTEZ.EQ.3) NP=NZVECT(JBASE,1)
C
                          DO ISPIN=0,NDSPIN
C
                             CNEW(IBASE,ISPIN) =  CNEW(IBASE,ISPIN) +
     *                       WARIGH(JBASE,ISTATE,ISPIN)*SHIOPE(NN,NP)
C
                          END DO
C
                      END IF
C
                   END DO
                END DO
C
                DO IBASE=1,LDBASE
                   DO ISPIN=0,NDSPIN
C
                      WARIGH(IBASE,ISTATE,ISPIN) = CNEW(IBASE,ISPIN)
C
                   END DO
                END DO
C
             END DO
C
         END IF
C
      END DO
C
C=======================================================================
C
      CALL CPUTIM('SHIWAV',0)
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE ROTHER(IROT,GAMA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          PHERMI(ND1MAX+1),DHERMI(ND1MAX+1)
      DIMENSION
     *          XHERMI(NDINT1),WHERMI(NDINT1)
      DIMENSION
     *          HERLEF(0:ND1MAX,1:NDINT1)
      DIMENSION
     *          HERRIG1(0:ND1MAX,1:NDINT1,1:NDINT1),
     *          HERRIG2(0:ND1MAX,1:NDINT1,1:NDINT1)
      DIMENSION
     *          HERFAC(0:ND1MAX)
C
      COMMON
     *       /RMATRI/ ROTOPE(0:NDOSCI,0:NDOSCI,0:NDOSCI,0:NDOSCI)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C --> NOSACT IS SET TO BE MAXIMAL PRINCIPAL QUANTUM NUMBER
C
      NOSACT=NDOSCI
      NMAIN1=NOSACT
C
      IF (NMAIN1.GT.ND1MAX) THEN
C
         WRITE(NFIPRI,'(//,1X,''NMAIN1='',I2,'' .GT. ND1MAX='',I2,
     *                         ''   STOP IN ROTHER'',//)') NMAIN1,ND1MAX
         STOP ' NMAIN1.GT.ND1MAX  IN  ROTHER'
C
      END IF
C
C=======================================================================
C
C               MATRIX ROTOPE IS  FOUND  BY  EXPLICIT  NUMERICAL
C                          G A U S S - H E R M I T E
C         INTEGRATION OF  PRODUCTS  APPEARING  UNDER  THE  INTEGRANDS.
C         THE MAXIMUM ORDER OF INTEGRANDS IS THEN EQUAL TO 2*NOSACT,
C                       [NO DERIVATIVES ARE CODED!!!!]
C           THEREFORE ONE HAS TO USE  THE  NUMBER  OF  GAUSS-HERMITE
C                  INTEGRATION POINTS EQUAL TO: NOSACT+1
C                                 OR MORE
C
C=======================================================================
C
      NGAUSS=NOSACT+1
C
      IF (NGAUSS.GT.NDINT1) THEN
C
          WRITE(NFIPRI,'(//,1X,''NGAUSS='',I2,'' .GT. NDINT1='',I2,
     *                         ''   STOP IN ROTHER'',//)') NGAUSS,NDINT1
          STOP ' NGAUSS.GT.NDINT1  IN ROTHER '
C
      END IF
C
C=======================================================================
C    DEFINING ZEROS AND WEIGHTS FOR THE GAUSS-HERMITE  INTEGRATION
C=======================================================================
C
      CALL HERMIT(NGAUSS,XHERMI,WHERMI,NDINT1)
C
C=======================================================================
C         DEFINING HERMITE POLYNOMIAL NORMALIZATION CONSTANTS
C=======================================================================
C
      CALL NORFAC(HERFAC,ND1MAX)
C
C=======================================================================
C     DEFINING VALUES OF THE ROTATED (RIGHT) HERMITE POLYNOMIALS AT
C                             GAUSS ZEROS
C=======================================================================
C
      DO IZEROS = 1,NGAUSS
      DO JZEROS = 1,NGAUSS
C
         XZER = XHERMI(IZEROS)
         YZER = XHERMI(JZEROS)
         XPRI = COS(GAMA)*XZER+IROT*SIN(GAMA)*YZER
         CALL D_HERM(XPRI,NMAIN1,PHERMI,DHERMI,ND1MAX+1)
C
         DO NOSCIL = 0,NMAIN1
C
            HERRIG1(NOSCIL,IZEROS,JZEROS)=
     *                    PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
         END DO
C
         YPRI =-IROT*SIN(GAMA)*XZER+COS(GAMA)*YZER
         CALL D_HERM(YPRI,NMAIN1,PHERMI,DHERMI,ND1MAX+1)
C
         DO NOSCIL = 0,NMAIN1
C
            HERRIG2(NOSCIL,IZEROS,JZEROS)=
     *                    PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
         END DO
C
      END DO
      END DO
C
C=======================================================================
C        DEFINING VALUES OF THE LEFT HERMITE POLYNOMIAL
C                      AT GAUSS ZEROS
C=======================================================================
C
      DO IZEROS = 1,NGAUSS
C
         XZER = XHERMI(IZEROS)
         CALL D_HERM(XZER,NMAIN1,PHERMI,DHERMI,ND1MAX+1)
C
         DO NOSCIL = 0,NMAIN1
C
            HERLEF(NOSCIL,IZEROS)=PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
         END DO
C
      END DO
C
C
C=======================================================================
C        CALCULATING THE OVERLAPS FOR THE POLYNOMIALS
C=======================================================================
C
      DO NX=0,NOSACT
         DO NY=0,NOSACT
            DO MX=0,NOSACT
               DO MY=0,NOSACT
C
                     RESULT=0.0D0
C
C ---> TOTAL NUMBER OF QUANTA IS CONSERVED FOR THE
C      ISOTROPIC (ONLY!!!) HARMONIC OSCILLATOR:
C      (SUPERSEDES PARITY CONSERVATION - NEXT "IF")
C
       IF (NX+NY.NE.MX+MY) GOTO 233
C
C ---> USE PARITY SELECTION RULE:
C
       IPARL=(-1)**(NX+NY)
       IPARR=(-1)**(MX+MY)
       IF (IPARL.NE.IPARR) GOTO 233
C
                     DO IGAUSS=1,NGAUSS
                     DO JGAUSS=1,NGAUSS
C
                        RESULT=RESULT
     *                        +WHERMI(IGAUSS)*WHERMI(JGAUSS)
     *                               *HERLEF(NX,IGAUSS)
     *                               *HERLEF(NY,JGAUSS)
     *                               *HERRIG1(MX,IGAUSS,JGAUSS)
     *                               *HERRIG2(MY,IGAUSS,JGAUSS)
C
                     END DO
                     END DO
C
 233                 ROTOPE(NX,NY,MX,MY) = RESULT
C
               END DO
            END DO
         END DO
      END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SCAHER(NOSACT,KARTEZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          PHERMI(ND1MAX+1),DHERMI(ND1MAX+1)
      DIMENSION
     *          XHERMI(NDINT2),WHERMI(NDINT2)
      DIMENSION
     *          HERLEF(0:ND1MAX,1:NDINT2),
     *          DH1LEF(0:ND1MAX,1:NDINT2),
     *          DH2LEF(0:ND1MAX,1:NDINT2)
      DIMENSION
     *          HERRIG(0:ND1MAX,1:NDINT2),
     *          DH1RIG(0:ND1MAX,1:NDINT2),
     *          DH2RIG(0:ND1MAX,1:NDINT2)
      DIMENSION
     *          HERFAC(0:ND1MAX)
      DIMENSION
     *          HORSCA(NDKART)
C
      COMMON
     *       /COESXY/ COES00(0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COES01(0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COES11(0:NDOSCI,0:NDOSCI,1:NDKART),
     *                COES02(0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /SCALEF/ HOLSCA(NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C         THIS ROUTINE PERFORMS INTEGRATION OF THE HERMITE POLYNOMIALS
C         TO FIND OVERLAPS BETWEEN HO STATES FOR DIFFERENT HO LENGTHS
C
C         COES00(M,N)= INT DX H (M,B*X)*H  (N,C*X)*EXP(-(B^2+C^2)X^2)/2)
C         COES01(M,N)= INT DX H (M,B*X)*H' (N,C*X)*EXP(-(B^2+C^2)X^2)/2)
C         COES11(M,N)= INT DX H'(M,B*X)*H' (N,C*X)*EXP(-(B^2+C^2)X^2)/2)
C         COES02(M,N)= INT DX H (M,B*X)*H''(N,C*X)*EXP(-(B^2+C^2)X^2)/2)
C
C         WHERE:
C
C         H  (N,X) IS THE HERMITE POLYNOMIAL OF THE ORDER  M  AT POINT X
C                  ASSUMED TO BE NORMALIZED TO   O N E   WHEN ITS SQUARE
C                  IS INTEGRATED WITH EXP(-X**2).
C         H' (N,X) IS THE DERIVATIVE OF              H(N,X)*EXP(-X**2/2)
C                  MULTIPLIED BY EXP(X**2/2)
C         H''(N,X) IS THE SECOND DERIVATIVE OF       H(N,X)*EXP(-X**2/2)
C                  MULTIPLIED BY EXP(X**2/2)
C
C         AND "B" AND "C" ARE SCALES OF THE LEFT AND RIGHT  POLYNOMIALS.
C
C=======================================================================
C         ATTENTION: FOR THE MOMENT, THE  TERMS  CONTAINING  DERIVATIVES
C                    ARE LATER NOT USED. THEY ARE HERE  CALCULATED  ONLY
C                    TO KEEP THE MIRROR STRUCTURE COPIED FROM  "DEVHER".
C=======================================================================
C         OSCILATOR LENGTHS OF THE RIGHT BASIS ARE KEPT IN "HORSCA"
C         OSCILATOR LENGTHS OF THE LEFT  BASIS ARE KEPT IN "HOLSCA"
C=======================================================================
C
          HORSCA(1)=HOMSCA(1,1)
          HORSCA(2)=HOMSCA(2,1)
          HORSCA(3)=HOMSCA(3,1)
C
          HOLSCA(1)=HOMSCA(1,1)
          HOLSCA(2)=HOMSCA(2,1)
          HOLSCA(3)=HOMSCA(3,1)
C
C=======================================================================
C
C         "NOSACT"  IS THE MAXIMUM ORDER OF THE HERMITE POLYNOMIALS USED
C         IN THE CODE. THEREFORE:
C
C         H  (M,X)  HAS THE MAXIMUM ORDER  NOSACT
C         H' (M,X)  HAS THE MAXIMUM ORDER  NOSACT + 1
C         H''(M,X)  HAS THE MAXIMUM ORDER  NOSACT + 2
C
C         THE MAXIMUM ORDER OF POLYNOMIALS IS THEREFORE:
C
C=======================================================================
C
      NMAIN1=NOSACT+2
C
      IF (NMAIN1.GT.ND1MAX) THEN
C
         WRITE(NFIPRI,'(//,1X,''NMAIN1='',I2,'' .GT. ND1MAX='',I2,
     *                         ''   STOP IN SCAHER'',//)') NMAIN1,ND1MAX
         STOP ' NMAIN1.GT.ND1MAX  IN  SCAHER'
C
      END IF
C
C=======================================================================
C         ZEROING THE COES__ ARRAYS
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
           COES00(M,N,KARTEZ)=0.0D0
           COES01(M,N,KARTEZ)=0.0D0
           COES11(M,N,KARTEZ)=0.0D0
           COES02(M,N,KARTEZ)=0.0D0
C
         END DO
      END DO
C
C=======================================================================
C
C         THE COEFFICIENTS  COES__  ARE FOUND  BY  EXPLICIT  NUMERICAL
C                          G A U S S - H E R M I T E
C         INTEGRATION OF  PRODUCTS  APPEARING  UNDER  THE  INTEGRANDS.
C         THE MAXIMUM ORDER OF INTEGRANDS IS THEN EQUAL TO 2*NOSACT+2,
C         AND THEREFORE ONE HAS TO USE  THE  NUMBER  OF  GAUSS-HERMITE
C         INTEGRATION POINTS EQUAL TO:
C
C=======================================================================
C
      NGAUSS=NOSACT+2
C
      IF (NGAUSS.GT.NDINT2) THEN
C
         WRITE(NFIPRI,'(//,1X,''NGAUSS='',I2,'' .GT. NDINT2='',I2,
     *                         ''   STOP IN SCAHER'',//)') NGAUSS,NDINT2
         STOP ' NGAUSS.GT.NDINT2  IN  SCAHER'
C
      END IF
C
C=======================================================================
C          DEFINING ZEROS AND WEIGHTS FOR THE GAUSS-HERMITE  INTEGRATION
C=======================================================================
C
      CALL HERMIT(NGAUSS,XHERMI,WHERMI,NDINT2)
C
C=======================================================================
C        DEFINING HERMITE POLYNOMIAL NORMALIZATION CONSTANTS
C=======================================================================
C
      CALL NORFAC(HERFAC,ND1MAX)
C
C=======================================================================
C        DEFINING VALUES OF THE LEFT HERMITE POLYNOMIALS AT GAUSS ZEROS
C=======================================================================
C
      FACLEF=HOLSCA(KARTEZ)/SQRT((HOLSCA(KARTEZ)**2
     *                           +HORSCA(KARTEZ)**2)/2)
C
      DO IZEROS = 1,NGAUSS
C
         XZER = XHERMI(IZEROS)*FACLEF
C
         CALL D_HERM(XZER,NMAIN1,PHERMI,DHERMI,ND1MAX+1)
C
         DO NOSCIL = 0,NMAIN1
C
            HERLEF(NOSCIL,IZEROS)= PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
            DH1LEF(NOSCIL,IZEROS)=(DHERMI(NOSCIL+1)
     *                           - XZER*PHERMI(NOSCIL+1))
     *                                             /HERFAC(NOSCIL)
C
            DH2LEF(NOSCIL,IZEROS)=(XZER*XZER-2*NOSCIL-1)
     *                           * PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
         END DO
C
      END DO
C
C=======================================================================
C        DEFINING VALUES OF THE RIGHT HERMITE POLYNOMIALS AT GAUSS ZEROS
C=======================================================================
C
      FACRIG=HORSCA(KARTEZ)/SQRT((HOLSCA(KARTEZ)**2
     *                           +HORSCA(KARTEZ)**2)/2)
C
      DO IZEROS = 1,NGAUSS
C
         XZER = XHERMI(IZEROS)*FACRIG
C
         CALL D_HERM(XZER,NMAIN1,PHERMI,DHERMI,ND1MAX+1)
C
         DO NOSCIL = 0,NMAIN1
C
            HERRIG(NOSCIL,IZEROS)= PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
            DH1RIG(NOSCIL,IZEROS)=(DHERMI(NOSCIL+1)
     *                           - XZER*PHERMI(NOSCIL+1))
     *                                             /HERFAC(NOSCIL)
C
            DH2RIG(NOSCIL,IZEROS)=(XZER*XZER-2*NOSCIL-1)
     *                           * PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
         END DO
C
      END DO
C
C=======================================================================
C        CALCULATING THE OVERALL FACTOR
C=======================================================================
C
      FACSCA=SQRT(FACLEF*FACRIG)
C
C=======================================================================
C        CALCULATING THE OVERLAPS FOR THE POLYNOMIALS
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            RESULT=0.0D0
C
            DO IGAUSS=1,NGAUSS
C
               RESULT=RESULT+WHERMI(IGAUSS)*HERLEF(M,IGAUSS)
     *                                     *HERRIG(N,IGAUSS)
            END DO
C
            COES00(M,N,KARTEZ)=RESULT*FACSCA
C
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE OVERLAPS FOR THE PRODUCTS
C        HERMIT * DERIVATIVE (EXP * HERMIT)
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            RESULT=0.0D0
C
            DO IGAUSS=1,NGAUSS
               RESULT=RESULT+WHERMI(IGAUSS)*HERLEF(M,IGAUSS)
     *                                     *DH1RIG(N,IGAUSS)
            END DO
C
            COES01(M,N,KARTEZ)=RESULT*FACSCA
C
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE OVERLAPS FOR THE PRODUCTS
C        DERIVATIVE (EXP * HERMIT) * DERIVATIVE (EXP * HERMIT)
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            RESULT=0.0D0
C
            DO IGAUSS=1,NGAUSS
               RESULT=RESULT+WHERMI(IGAUSS)*DH1LEF(M,IGAUSS)
     *                                     *DH1RIG(N,IGAUSS)
            END DO
C
            COES11(M,N,KARTEZ)=RESULT*FACSCA
C
         END DO
      END DO
C
C=======================================================================
C        CALCULATING THE OVERLAPS FOR THE PRODUCTS
C        HERMIT * SECOND DERIVATIVE (EXP * HERMIT)
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            RESULT=0.0D0
C
            DO IGAUSS=1,NGAUSS
               RESULT=RESULT+WHERMI(IGAUSS)*HERLEF(M,IGAUSS)
     *                                     *DH2RIG(N,IGAUSS)
            END DO
C
            COES02(M,N,KARTEZ)=RESULT*FACSCA
C
         END DO
      END DO
C
C=======================================================================
C       THE CODE USES DIMENSIONED WAVE FUNCTIONS AND THEIR DERIVATIVES.
C       THEREFORE, THE COEFFICIENTS       COEF__     ARE HERE SCALED BY
C       APPROPRIATE FACTORS WHICH TAKE INTO ACCOUNT  THESE  DIMENSIONS.
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
            COES01(M,N,KARTEZ)=COES01(M,N,KARTEZ)
     *                        * HORSCA(KARTEZ)
C
            COES02(M,N,KARTEZ)=COES02(M,N,KARTEZ)
     *                        * HORSCA(KARTEZ)
     *                        * HORSCA(KARTEZ)
C
            COES11(M,N,KARTEZ)=COES11(M,N,KARTEZ)
     *                        * HOLSCA(KARTEZ)
     *                        * HORSCA(KARTEZ)
C
         END DO
      END DO
C
C=======================================================================
C       HERE IS THE TEST AGAINST THE EXPLICIT FORMULA (NOTES 8.64B)
C=======================================================================
C
C     FACFAC=(HORSCA(KARTEZ)**2-HOLSCA(KARTEZ)**2)/
C    *       (HOLSCA(KARTEZ)**2+HORSCA(KARTEZ)**2)
C
C     DO NN=0,NOSACT
C        DO MM=0,NOSACT
C
C           N=MIN(NN,MM)
C           M=MAX(NN,MM)
C
C           KMAX=N/2
C           RESULT=0
C
C           DO K=0,KMAX
C              L=K+(M-N)/2
C              RESULT=RESULT+FACSCA*SQRT(FACTOR(N)*FACTOR(M))/
C    *                   FACTOR(N-2*K)/2.0D0**(K+L)/FACTOR(K)/FACTOR(L)*
C    *                       FACSCA**(2*(N-2*K))*(-1)**K*FACFAC**(K+L)
C           END DO
C
C           IF (MOD(MM,2).NE.MOD(NN,2)) RESULT=0
C           IF (NN.GT.MM) RESULT=RESULT*(-1)**((M-N)/2)
C
C           print *,NN,MM,COES00(NN,MM,KARTEZ),RESULT
C           IF (ABS(COES00(NN,MM,KARTEZ)-RESULT).GT.1.0D-14)
C    *      PRINT *,' BBBBBB-AAAAAA-DDDDDD'
C
C        END DO
C     END DO
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE SHIHER(KARTEZ)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION
     *          PHERMI(NDOSCI+1),DHERMI(NDOSCI+1)
      DIMENSION
     *          XHERMI(NDINT1),WHERMI(NDINT1)
      DIMENSION
     *          HERLEF(0:NDOSCI,1:NDINT1)
      DIMENSION
     *          HERRIG(0:NDOSCI,1:NDINT1)
      DIMENSION
     *          HERFAC(0:NDOSCI)
C
      COMMON
     *       /SMATRI/ SHIOPE(0:NDOSCI,0:NDOSCI)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /SVECTO/ BSHIFT(NDKART)
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
C         THIS ROUTINE PERFORMS INTEGRATION OF THE HERMITE POLYNOMIALS
C         TO FIND OVERLAPS BETWEEN HO STATES SHIFTED BY BSHIFT
C
C         SHIOPE(M,N)= B * INT DX H (M,B*(X+BSHIFT/2))
C                                *H (N,B*(X-BSHIFT/2))
C                                *EXP(-B^2*(X^2+BSHIFT^2/4))
C
C         WHERE:
C
C         H  (N,X) IS THE HERMITE POLYNOMIAL OF THE ORDER  M  AT POINT X
C                  ASSUMED TO BE NORMALIZED TO   O N E   WHEN ITS SQUARE
C                  IS INTEGRATED WITH EXP(-(B*X)**2).
C
C=======================================================================
C
C --> NOSACT IS SET TO BE MAXIMAL PRINCIPAL QUANTUM NUMBER
C
      NOSACT=NDOSCI
C
C=======================================================================
C
C         "NOSACT"  IS THE MAXIMUM ORDER OF THE HERMITE POLYNOMIALS USED
C         IN THE CODE. THEREFORE:
C
C         H  (M,X)  HAS THE MAXIMUM ORDER  NOSACT
C
C         THE MAXIMUM ORDER OF POLYNOMIALS IS THEREFORE:
C
C=======================================================================
C
      NMAIN1=NOSACT
C
      IF (NMAIN1.GT.NDOSCI) THEN
C
         WRITE(NFIPRI,'(//,1X,''NMAIN1='',I2,'' .GT. NDOSCI='',I2,
     *                         ''   STOP IN SCAHER'',//)') NMAIN1,NDOSCI
         STOP ' NMAIN1.GT.NDOSCI  IN  SHIHER'
C
      END IF
C
C=======================================================================
C         ZEROING THE SHIOPE ARRAY
C=======================================================================
C
      DO N=0,NOSACT
         DO M=0,NOSACT
C
           SHIOPE(M,N)=0.0D0
C
         END DO
      END DO
C
C=======================================================================
C
C         THE COEFFICIENTS  SHIOPE  ARE FOUND  BY  EXPLICIT  NUMERICAL
C                          G A U S S - H E R M I T E
C         INTEGRATION OF  PRODUCTS  APPEARING  UNDER  THE  INTEGRANDS.
C         THE MAXIMUM ORDER OF INTEGRANDS IS THEN EQUAL TO   2*NOSACT,
C         AND THEREFORE ONE HAS TO USE  THE  NUMBER  OF  GAUSS-HERMITE
C         INTEGRATION POINTS EQUAL TO:
C
C=======================================================================
C
      NGAUSS=NOSACT+1
C
      IF (NGAUSS.GT.NDINT1) THEN
C
         WRITE(NFIPRI,'(//,1X,''NGAUSS='',I2,'' .GT. NDINT1='',I2,
     *                         ''   STOP IN SHIHER'',//)') NGAUSS,NDINT1
         STOP ' NGAUSS.GT.NDINT1  IN  SHIHER'
C
      END IF
C
C=======================================================================
C          DEFINING ZEROS AND WEIGHTS FOR THE GAUSS-HERMITE  INTEGRATION
C=======================================================================
C
      CALL HERMIT(NGAUSS,XHERMI,WHERMI,NDINT1)
C
C=======================================================================
C        DEFINING HERMITE POLYNOMIAL NORMALIZATION CONSTANTS
C=======================================================================
C
      CALL NORFAC(HERFAC,NDOSCI)
C
C=======================================================================
C        DEFINING VALUES OF THE HERMITE POLYNOMIALS AT GAUSS ZEROS
C=======================================================================
C
      DO IZEROS = 1,NGAUSS
C
         XZER = XHERMI(IZEROS)+HOMSCA(KARTEZ,1)*BSHIFT(KARTEZ)/2
C
         CALL D_HERM(XZER,NMAIN1,PHERMI,DHERMI,NDOSCI+1)
C
         DO NOSCIL = 0,NMAIN1
C
            HERLEF(NOSCIL,IZEROS)= PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
         END DO
C
         XZER = XHERMI(IZEROS)-HOMSCA(KARTEZ,1)*BSHIFT(KARTEZ)/2
C
         CALL D_HERM(XZER,NMAIN1,PHERMI,DHERMI,NDOSCI+1)
C
         DO NOSCIL = 0,NMAIN1
C
            HERRIG(NOSCIL,IZEROS)= PHERMI(NOSCIL+1)/HERFAC(NOSCIL)
C
         END DO
C
      END DO
C
C=======================================================================
C        CALCULATING THE OVERALL FACTOR
C=======================================================================
C
      FACSCA=EXP(-(HOMSCA(KARTEZ,1)*BSHIFT(KARTEZ))**2/4)
C
C=======================================================================
C        CALCULATING THE OVERLAPS
C=======================================================================
C
      DO M=0,NOSACT
         DO N=0,NOSACT
C
            RESULT=0.0D0
C
            DO IGAUSS=1,NGAUSS
C
               RESULT=RESULT+WHERMI(IGAUSS)*HERLEF(M,IGAUSS)
     *                                     *HERRIG(N,IGAUSS)
            END DO
C
            SHIOPE(M,N)=RESULT*FACSCA
C
         END DO
      END DO
C
C=======================================================================
C       HERE IS THE TEST AGAINST THE EXPLICIT FORMULA (NOTES 8.64E)
C=======================================================================
C
C       THE TEST REQUIRES INCREASING DIMENSIONS OF ARRAYS AS BELOW:
C
C     DIMENSION
C    *          PHERMI(2*NDOSCI+1),DHERMI(2*NDOSCI+1)
C     DIMENSION
C    *          HERFAC(0:2*NDOSCI)
C
C=======================================================================
C
C       THE TEST REQUIRES INCLUDING COMMON RBINOM:
C
C     PARAMETER
C    *          (NDBINO=2*NDOSCI)
C#if(SWITCH_QUAD==1)
C     REAL*16
C    *          RBINOM
C#endif
C     COMMON
C    *       /NEWBIR/ RBINOM(0:NDBINO,0:NDBINO)
C
C=======================================================================
C
C       THE TEST REQUIRES INCLUDING COMMON COEFMO:
C
C     PARAMETER
C    *          (ND0MAX=2*NDOSCI)
C     COMMON
C    *       /COEFMO/ COEMOS(0:ND0MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
C
C=======================================================================
C
C       THE TEST REQUIRES DEFINING VARIABLES DSQRT2 AND SQ4_PI:
C
C     DSQRT2=SQRT(2.0D0)
C
C     SQ4_PI=SQRT(SQRT(4.0D0*ATAN(1.0D0)))
C
C=======================================================================
C
C     CALL NORFAC(HERFAC,2*NDOSCI)
C
C     XZER = HOMSCA(KARTEZ,1)*BSHIFT(KARTEZ)/DSQRT2
C
C     DIFMAX=0
C     DIRMAX=0
C
C     DO K=0,NOSACT
C        DO L=0,NOSACT
C
C           RESULT=0
C
C           CALL D_HERM(XZER,2*NOSACT,PHERMI,DHERMI,2*NDOSCI+1)
C
C           DO N=0,K+L,2
C
C              RESULT=RESULT+COEMOS(N,K,L,KARTEZ)/DSQRT2**N
C    *                      *SQRT(RBINOM(N,N/2))
C    *                      *PHERMI(K+L-N+1)/HERFAC(K+L-N)
C           END DO
C
C           RESULT=RESULT*FACSCA*SQ4_PI
C
C           PRINT *,K,L,SHIOPE(K,L),RESULT
C               IF (ABS(SHIOPE(K,L)-RESULT).GT.1.0D-14)
C    *      PRINT *,' BBBBBB-AAAAAA-DDDDDD'
C
C           DIFMAX=MAX(DIFMAX,ABS( SHIOPE(K,L)-RESULT))
C           DIRMAX=MAX(DIRMAX,ABS((SHIOPE(K,L)-RESULT)/RESULT))
C
C        END DO
C     END DO
C
C     PRINT '(/'' MAXIMUM DIFFERENCE='',         D19.10/)',DIFMAX
C     PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10/)',DIRMAX
C
C=======================================================================
C       HERE IS THE TEST OF ORTHOGONALITY
C=======================================================================
C
C     DIFMAX=0
C     DIRMAX=0
C
C     DO K=0,NOSACT
C        DO L=0,NOSACT
C
C           RESULT=0
C
C           DO N=0,NOSACT
C
C              RESULT=RESULT+SHIOPE(K,N)*SHIOPE(L,N)
C
C           END DO
C
C                       RESEXA=0.0D0
C           IF (K.EQ.L) RESEXA=1.0D0
C
C           PRINT *,K,L,RESEXA,RESULT
C               IF (ABS(RESEXA-RESULT).GT.1.0D-14)
C    *      PRINT *,' BBBBBB-AAAAAA-DDDDDD'
C
C           DIFMAX=MAX(DIFMAX,ABS( RESEXA-RESULT))
C           DIRMAX=MAX(DIRMAX,ABS((RESEXA-RESULT)/RESULT))
C
C        END DO
C     END DO
C
C     PRINT '(/'' MAXIMUM DIFFERENCE='',         D19.10/)',DIFMAX
C     PRINT '(/'' MAXIMUM RELATIVE DIFFERENCE='',D19.10/)',DIRMAX
C
C=======================================================================
C
      RETURN
      END
C
C=======================================================================
C
C---------------------------------------------------------------
C
C     DSMALG COMPUTES SMALL WIGNER FUNCTION d^J_{M M'}(beta) FOR
C                  J=JD/2, M=MD/2, M'= MDP/2
C         CODED ACCORDING TO THE FORMULA (4), P.76 FROM THE
C                    VARSHALOVICH TEXTBOOK
C
C --> LOGARITHMS OF FACTORIALS ARE USED
C
C---------------------------------------------------------------
C                                 adapted from K. Burzynski code
C
      REAL FUNCTION DSMALG(JD,MD,MDP,BETA)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMMON
     *       /COMSIL/ SILNIA(0:NDJMXD)
C
      DATA NSDONE /0/
C
      IF (NSDONE.EQ.0) THEN
          NSDONE=1
          SILNIA(0)=0.
          DO L = 1,NDJMXD
             SILNIA(L)=SILNIA(L-1)+LOG(REAL(L))
          END DO
C
      END IF
C
C=======================================================================
C        ATTENTION: BETWEEN VERSIONS 2.89C AND 3.04I, VARIABLE  "DSMALG"
C                   BELOW WAS NOT INITIALIZED  TO  ZERO.  AS  A  RESULT,
C                   CALCULATIONS OF WIGNER D FUNCTIONS USING  THE  "OLD"
C                   OBSOLETE  METHOD  WERE  INCORRECT.  THIS   BUG   WAS
C                   CORRECTED ON 15/04/2021 IN VERSION 3.04J.
C=======================================================================
C
      DSMALG = 0.
C
      BETA2  = BETA/2.
      CB     = COS(BETA2)
      SB     = SIN(BETA2)
C
      K1=(JD+MD)/2
      K2=(JD-MD)/2
      K3=(JD+MDP)/2
      K4=(JD-MDP)/2
      K5=(MD-MDP)/2
      L7=(K1+K4)
      L9=-K5
C
      LMAX=MIN(K1,K4)
      LMIN=MAX(0,K5)
C
      DL1=( SILNIA(K1)+SILNIA(K2)+SILNIA(K3)+SILNIA(K4) )/2.
C
      DO L=LMIN,LMAX
         L8=L+L
         DL2=SILNIA(L)+SILNIA(K1-L)+SILNIA(K4-L)+SILNIA(L9+L)
         C = ( -2.0 * MOD(L,2) + 1 )  *  EXP(DL1-DL2)
         C = C * (CB**(L7-L8)) * (SB**(L9+L8))
         DSMALG = DSMALG + C
      END DO
C
      RETURN
      END
C=======================================================================
      REAL FUNCTION DSMALH(JD,MD,MDP,BETA,NEWWIG,ISWIND,NUANGU)
C=======================================================================
      USE hfodd_sizes
      USE hfodd_wigner
C=======================================================================
C
      real
     *       jmq
      ALLOCATABLE
     *       wd_matrix(:,:)
C
      COMMON
     *       /CFIPRI/ NFIPRI
C
C=======================================================================
C
      CALL CPUTIM('DSMALH',1)
C
C=======================================================================
C
      DSMALH = 0.0D0
C
C---> AVOID: 0.^0
C
      IF (ABS(BETA).LT.1.E-10) THEN
         IF (MD.NE.MDP) GO TO 1
         DSMALH=1.0D0
         GO TO 1
      END IF
C
      jmq=JD/2.0D0
      theta=BETA
C
C---> ARGUMENTS CONSISTENCY CHECK:
C
      IF (MOD(JD +MD ,2).NE.0 .OR. JD +MD .LT.0) STOP ' DSMALH 1'
      IF (MOD(JD +MDP,2).NE.0 .OR. JD +MDP.LT.0) STOP ' DSMALH 2'
      IF (MOD(JD -MD ,2).NE.0 .OR. JD -MD .LT.0) STOP ' DSMALH 3'
      IF (MOD(JD -MDP,2).NE.0 .OR. JD -MDP.LT.0) STOP ' DSMALH 4'
      IF (MOD(MD -MDP,2).NE.0                  ) STOP ' DSMALH 5'
      IF (JD.GT.NDJMXD)                          STOP ' DSMALH 6'
C
      IF (NEWWIG.EQ.1) THEN
C
          IF (ISWIND.NE.1) THEN
C
              IF (.NOT.ALLOCATED(D_WIGN))
     *            ALLOCATE (D_WIGN(NDPROW,NDANGU),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('D_WIGN','DSMALH')
C
              IF (.NOT.ALLOCATED(BETANG))
     *            ALLOCATE (BETANG(NDANGU),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('BETANG','DSMALH')
C
              IF (.NOT.ALLOCATED(IWIIMK))
     *            ALLOCATE (IWIIMK(0:NDWIGN,-NDWIGN:NDWIGN,
     *                                      -NDWIGN:NDWIGN),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('IWIIMK','DSMALH')
C
              IF (.NOT.ALLOCATED(ISWIGN))
     *            ALLOCATE (ISWIGN(0:NDWIGN,NDANGU),STAT=IALLOC)
              IF (IALLOC.NE.0) CALL NOALLO('ISWIGN','DSMALH')
C
              D_WIGN=0.0D0
              BETANG=10.0D0
C
              IWIIMK=0
              ISWIGN=0
C
C=======================================================================
C         CONSTRUCTING THE ARRAY OF INDICES OF THE WIGNER D FUNCTIONS
C=======================================================================
C         ATTENTION: THE SPACE IS RESERVED FOR EVEN OR ODD SPINS
C                    DEPENDING ON WHETER THE SPIN OF  THE  FIRST
C                    CALL IS EVEN OR ODD.
C=======================================================================
C
              IWIPRO=0
C
              DO IPROAC=MOD(JD,2),NDWIGN,2
                 DO LPROAC=-IPROAC,IPROAC,2
                    DO KPROAC=-IPROAC,IPROAC,2
C
                       IWIPRO=IWIPRO+1
C
                       IWIIMK(IPROAC,LPROAC,KPROAC)=IWIPRO
C
                    END DO
                 END DO
              END DO
C
              ISWIND=1
C
              IF (IWIPRO.GT.NDPROW) THEN
C
                  WRITE(NFIPRI,'(
     *                1H*,20(1H/),2X,''TOO SMALL VALUE OF NDPROW ='',I6,
     *                                              2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''SHOULD BE EQUAL  AT LEAST ='',I6,
     *                                              2X,20(1H/),1H*,/,
     *                1H*,20(1H/),2X,''IN DSMALH                  '',6X,
     *                                              2X,20(1H/),1H*,/,
     *                                                 1H*,77X,1H*)')
     *            NDPROW,IWIPRO
C
                  STOP ' TOO SMALL VALUE OF NDPROW IN DSMALH'
C
              END IF
C
          END IF
C
C=======================================================================
C         FINDING THE ANGLE AND SPIN FOR WHICH THE WIGNER D FUNCTION
C         HAS ALREADY BEEN CALCULATED
C=======================================================================
C
          DO I_ANGU=1,NUANGU
C
             IF (BETANG(I_ANGU).EQ.BETA) THEN
C
                 IF (ISWIGN(JD,I_ANGU).EQ.1) THEN
C
                    DSMALH = D_WIGN(IWIIMK(JD,MD,MDP),I_ANGU)
C
                    GO TO 1
C
                 ELSE
C
                    GO TO 2
C
                 END IF
C
             END IF
C
          END DO
C
C=======================================================================
C         STORING NEW ANGLE
C=======================================================================
C
          IF (NUANGU.GE.NDANGU) STOP ' INCREASE NDANGU IN DSMALH'
C
          NUANGU=NUANGU+1
C
          I_ANGU=NUANGU
C
          BETANG(I_ANGU)=BETA
C
C=======================================================================
C         CALCULATING THE WIGNER D FUNCTION FOR THE ANGLE AND SPIN FOR
C         WHICH IT HAS NOT YET BEEN CALCULATED
C=======================================================================
C
    2     CONTINUE
C
          ALLOCATE (wd_matrix(int(2*jmq+1),int(2*jmq+1)),STAT=IALLOC)
          IF (IALLOC.NE.0) CALL NOALLO('wd_mat','DSMALH')
C
          CALL Wigner_dmatrix(jmq,theta,wd_matrix)
C
          DO ND=-JD,JD,2
             DO NDP=-JD,JD,2
C
                NA =(ND +JD)/2+1
                NAP=(NDP+JD)/2+1
C
                D_WIGN(IWIIMK(JD,ND,NDP),I_ANGU)=wd_matrix(NA,NAP)
C
             END DO
          END DO
C
          DEALLOCATE (wd_matrix)
C
          ISWIGN(JD,I_ANGU)=1
C
          DSMALH = D_WIGN(IWIIMK(JD,MD,MDP),I_ANGU)
C
      ELSE
C
          DSMALH = DSMALG(JD,MD,MDP,BETA)
C
      END IF
C
    1 CONTINUE
C
C=======================================================================
C
      CALL CPUTIM('DSMALH',0)
C
C=======================================================================
      RETURN
      END
C=======================================================================
      REAL FUNCTION CGCOEF(J1,M1,J2,M2,J,M)
C
C     CALCULATION OF CLEBSCH-GORDON COEFFICIENTS
C     ALSO KNOWN AS VECTOR COUPLING COEFFICIENTS
C     DEFINITION OF THE ARGUMENTS ARE STANDARD
C     ARGUMENTS ARE DOUBLE THEIR ACTUAL VALUES TO AVOID HALF-INTEGRALS
C
C   ADAPTED FROM THE CERN LIBRARY ROUTINE CLEBSG (U110),
C   WHICH IN TURN WAS ADAPTED FROM THE HARWELL LIBRARY, VERSION 08/01/74
C
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      DIMENSION H(MV25),L(MV25)
C
      DATA H(1) / 1.D0 /
      DATA L(1) / 0 /
      DATA LAST / 1 /
      DATA SCALE / 8.D0 /
C
      LSIZ=MV25
C
      CGCOEF=0.0
      IF (J .LT.0)                                 RETURN
      IF (J1.LT.0)                                 RETURN
      IF (J2.LT.0)                                 RETURN
      IF (IABS(M ).GT.J )                          RETURN
      IF (IABS(M1).GT.J1)                          RETURN
      IF (IABS(M2).GT.J2)                          RETURN
      IF (M1+M2.NE.M)                              RETURN
      IF (MOD(J1+J2+J,2).NE.0)                     RETURN
      I0=(J1+J2+J)/2+1
      IF (J1+J2-J.LT.0)                            RETURN
      I1=(J1+J2-J)/2
      IF (J.LT.IABS(J1-J2))                        RETURN
      I2=(J-(J1-J2))/2
      I3=(J+(J1-J2))/2
      IF (MOD(J -M ,2).NE.0)                       RETURN
      I8=(J +M )/2
      I9=(J -M )/2
      IF (MOD(J1-M1,2).NE.0)                       RETURN
      I4=(J1+M1)/2
      I5=(J1-M1)/2
      IF (MOD(J2-M2,2).NE.0)                       RETURN
      I6=(J2+M2)/2
      I7=(J2-M2)/2
      N2=J2-J-M1
      N3=J1-J+M2
      N4=MIN(I1,I5,I6)
      N5=MAX(0,N2,N3)
      N1=N5/2
      IF (N1.GT.N4)                                RETURN
      MM1=MAX(I0,I1,I2,I3,I4,I5,I6,I7,I8,I9,N4-N2/2,N4-N3/2)+1
      IF (MM1.LE.LAST)  GO TO 500
      IF (MM1.LE.LSIZ)  GO TO 100
      WRITE(6,'(''CGCOEF CALLED WITH ARGUMENTS '',6I5)')
     *            J,M,J1,M1,J2,M2
      WRITE(6,'(''THIS REQUIRES CALCULATIONS WITH A FACTORIAL '',
     *          ''OF '',i5)') MM1
      WRITE(6,'(''THIS VERSION ASSUMED THE MAXIMUM FACTORIAL EVER '',
     *          ''CALCULATED TO BE OF '',I5)') LSIZ
      WRITE(6,'(''THE SIZE OF INTERNAL ARRAYS H AND L MUST BE '',
     *          ''INCREASED'')')
      STOP 8537
  100 CONTINUE
      X=LAST
      MM2=LAST+1
      LAST=MM1
      DO MM3=MM2,MM1
         H(MM3)=H(MM3-1)*X
         L(MM3)=L(MM3-1)
  200    IF (H(MM3).LT.SCALE)  GO TO 400
         H(MM3)=H(MM3)/SCALE**2
         L(MM3)=L(MM3)+2
         GO TO 200
  400    X=X+1.D0
      END DO
  500 CONTINUE
      IY =  (L(I1+1)+L(I2+1)+L(I3+1)+L(I4+1)+L(I5+1)+L(I6+1)+L(I7+1)+
     +L(I8+1)+L(I9+1)-L(I0+1))/2
      Y=SQRT(H(I1+1)*H(I2+1)*H(I3+1)*H(I4+1)*H(I5+1)*H(I6+1)*H(I7+1)*
     *H(I8+1)*H(I9+1)/H(I0+1)*(J+1))
      IF ((N5/4)*4-N5+1.LT.0)  Y=-Y
      Z=0.
      DO N5=N1,N4
         MM1=I1-N5
         MM2=I5-N5
         MM3=I6-N5
         MM4=N5-N2/2
         MM5=N5-N3/2
         X=Y/H(MM1+1)/H(MM2+1)/H(MM3+1)/H(MM4+1)/H(MM5+1)/H(N5+1)
         IX= L(MM1+1)+L(MM2+1)+L(MM3+1)+L(MM4+1)+L(MM5+1)+L(N5+1)
C 800    IF (IY-IX) 900,210,110
  800    CONTINUE
         IF (IY-IX.LT.0) GO TO 900
         IF (IY-IX.EQ.0) GO TO 210
         IF (IY-IX.GT.0) GO TO 110
  900    X=X/SCALE
         IX=IX-1
         GO TO 800
  110    X=X*SCALE
         IX=IX+1
         GO TO 800
  210    Z=Z+X
         Y=-Y
      END DO
      CGCOEF=Z
        RETURN
      END
C=======================================================================
*|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
      subroutine gauleg(x1,x2,x,w,n)
*     ______________________________
*
*=======================================================================
*
*                  MUST BE COMPILED IN AUTODOUBLE MODE
*                  ...................................
*
*          This routine  calculates the weights and knots of the
*          Gauss-Legendre  integration formula of the N-th order
*          and stores them in the  arrays X and W. X1 and X2 are
*          integration limits. Normally, they are -1 and +1, but
*          may be set to any values (X1 < X2), so you will n o t
*          have to change variables in your program.
*
*                           You always have:
*
*           Integral(X1,X2)[f(x)dx] = Sum(i=1,N)[W(i)*f(X(i))]
*
*          Arrays  are stored in  ascending  order of knots X(i).
*
*=======================================================================
* From Numerical Recipes, 2-nd ed., with modifications. ================
*=======================================================================
*=============================================== T. R. Werner, July 1993
*=============================================== Last modified: Feb 1997
*=======================================  Modified by Jacek: Dec 22 2005
*=======================================================================
*
      parameter (EPS=3.e-17,KX=8)
      dimension  x(n),w(n)
*
      m=(n+1)/2
      xm=(x2+x1)/2
      xl=(x2-x1)/2
      PI=4.0D0*ATAN(1.0D0)
      do i=1,m
         z=cos(pi*(i-0.25D0)/(n+0.5D0))
         zx=1.e+30
         k=0
*
    1    continue
            p1=1
            p2=0
            k=k+1
            do j=1,n
               p3=p2
               p2=p1
               p1=((2*j-1)*z*p2-(j-1)*p3)/j
            end do
            pp=n*(z*p1-p2)/(z*z-1)
            z1=z
            z=z1-p1/pp
            z2=abs(z-z1)
            if (z2.le.zx) then
               zx=z2
               zb=z
            end if
         if (z2.gt.EPS.and.k.lt.KX) go to 1
*
         x(i)=xm-xl*zb
         x(n+1-i)=xm+xl*zb
         w(i)=2*xl/((1-zb*zb)*pp*pp)
         w(n+1-i)=w(i)
      end do
*
      END
C
C=======================================================================
C
      SUBROUTINE BEGINC(VSPACE,SONBAS,NDEGRE,HERACT,WGTACT,
     *                                       LTWCEN,ITWCEN)
C=======================================================================
      USE hfodd_sizes
      USE hfodd_twocen
C=======================================================================
      COMPLEX
     *          VSPACE,SONBAS,UFIELD,XFIELD,YFIELD,RESULT,C_ZERO
C
      DIMENSION
     *          XFIELD(0:ND2MAX,1:NDYHRM,1:NDZHRM)
      DIMENSION
     *          YFIELD(0:ND2MAX,0:ND2MAX,1:NDZHRM)
      DIMENSION
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX)
C
      DIMENSION
     *          VSPACE(NDXHRM,NDYHRM,NDZHRM),
     *          UFIELD(NDXHRM,NDYHRM,NDZHRM)
C
      DIMENSION
     *          HERACT(0:ND2MAX,1:NDGAUS,1:NDKART)
      DIMENSION
     *          WGTACT(1:NDGAUS,1:NDKART)
      COMMON
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /GAUMAX/ NXHERM,NYHERM,NZHERM
      COMMON
     *       /TWCINT/ WGHERM(1:NDGAUS,1:NDKART),
     *                PTHERM(1:NDGAUS,1:NDKART)
      COMMON
     *       /TWCEXP/ HEREXP(0:ND2MAX,1:NDGAUS,1:NDKART)
      COMMON
     *       /TWCEIN/ IND4HI(1:NDTWHE),IND4HJ(1:NDTWHE),
     *                IND4HK(1:NDTWDD),IND4HL(1:NDTWDD),
     *                IND2HR(1:NDTWBL),IND2HL(1:NDTWBL)
C
C=======================================================================
C
      CALL CPUTIM('BEGINC',1)
C
C=======================================================================
C        THIS SUBROUTINE CALCULATES THE THREE-DIMENSIONAL INTEGRALS
C        OF A FIELD 'VSPACE' GIVEN ON THE GAUSS-HERMITE INTEGRATION
C        MESH WITH THE PRODUCT OF THREE HERMITE POLYNOMIALS. RESULT
C        IS CONTAINED IN THE ARRAY 'SONBAS'  (FIELD V ON THE BASIS)
C        DEPENDING ON THE THREE O S C I L L A T O R QUANTUM NUMBERS
C                        'KX', 'KY', AND 'KZ'.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
C=======================================================================
C        IN THE CASE OF TWO-CENTER BASIS INTEGRATION WEIGHTS ARE READ
C        FROM WGHERM COMPUTED IN TWC_DEFINT
C=======================================================================
C

      IF (ITWCEN.EQ.2) THEN
C
          WGTACT(:,:)=WGHERM(:,:)
          HERACT(:,:,:)=HEREXP(:,:,:)
C
      END IF
C
C=======================================================================
C        DEFINING  THE  FUNCTION  TO  BE  INTEGRATED  ( INTEGRAND )
C=======================================================================
C
      DO IX=1,NXHERM
         DO IY=1,NYHERM
            DO IZ=1,NZHERM
               WHERM=WGTACT(IX,1)*WGTACT(IY,2)*WGTACT(IZ,3)
               UFIELD(IX,IY,IZ)=VSPACE(IX,IY,IZ)*WHERM
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DO KX=0,NXMAXV(IND4HI(LTWCEN))+NXMAXV(IND4HJ(LTWCEN))+NDEGRE
         DO IY=1,NYHERM
            DO IZ=1,NZHERM
C
               RESULT=C_ZERO
C
               DO IX=1,NXHERM
                  RESULT=RESULT+HERACT(KX,IX,1)*UFIELD(IX,IY,IZ)
               END DO
C
               XFIELD(KX,IY,IZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DO KX=0,NXMAXV(IND4HI(LTWCEN))+NXMAXV(IND4HJ(LTWCEN))+NDEGRE
         DO KY=0,NYMAXV(IND4HI(LTWCEN))+NYMAXV(IND4HJ(LTWCEN))+NDEGRE
            DO IZ=1,NZHERM
C
               RESULT=C_ZERO
C
               DO IY=1,NYHERM
                  RESULT=RESULT+HERACT(KY,IY,2)*XFIELD(KX,IY,IZ)
               END DO
C
               YFIELD(KX,KY,IZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      DO KX=0,NXMAXV(IND4HI(LTWCEN))+NXMAXV(IND4HJ(LTWCEN))+NDEGRE
         DO KY=0,NYMAXV(IND4HI(LTWCEN))+NYMAXV(IND4HJ(LTWCEN))+NDEGRE
            DO KZ=0,NZMAXV(IND4HI(LTWCEN))+NZMAXV(IND4HJ(LTWCEN))+NDEGRE
C
               RESULT=C_ZERO
C
               DO IZ=1,NZHERM
                  RESULT=RESULT+HERACT(KZ,IZ,3)*YFIELD(KX,KY,IZ)
               END DO
C
               SONBAS(KX,KY,KZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('BEGINC',0)
C
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE INTCOU(NUMCOU,BOUCOU,SONBAS,ECHARG,PIOMAS,ISURFA,
     *                         IKERNE,ISIMPY,KFRAGM,HPPCOU,HPMCOU)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
      COMPLEX
     *          C_ZERO
      COMPLEX
     *          HPPCOU,HPMCOU,SONBAS,RESULT,SURFAC,PROMOM
      COMPLEX
     *          XFOURI,YFOURI,ZFOURI,X_HELP,Y_HELP,Z_HELP
      COMPLEX
     *          QMUT_N,QMUT_P,QMUT_T
C
      DIMENSION
     *          SONBAS(0:ND2MAX,0:ND2MAX,0:ND2MAX)
      DIMENSION
     *          HPPCOU(1:NDBASE,1:NDBASE),
     *          HPMCOU(1:NDBASE,1:NDBASE)
      DIMENSION
     *          Y_HELP(0:ND2MAX)
      DIMENSION
     *          X_HELP(0:ND2MAX,0:ND2MAX)
      DIMENSION
     *          Z_HELP(0:NDOSCI,0:NDOSCI)
      DIMENSION
     *          XFOURI(0:NDCOUL,0:ND2MAX,0:ND2MAX),
     *          YFOURI(         0:NDCOUL,0:ND2MAX),
     *          ZFOURI(                  0:NDCOUL)
      DIMENSION
     *          PROMOM(1:NDPOLS)
C
      COMMON
     *       /COUDEV/ COUL00(0:ND2MAX,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON
     *       /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
      COMMON
     *       /BINDEX/ INDICE(0:NDXMAX,0:NDYMAX,0:NDZMAX,1:NDTWCE)
     *
     *       /BLIMS1/ LXOFYV(0:NDYMAX,1:NDTWCE),
     *                LYOFZV(0:NDZMAX,1:NDTWCE),
     *                LZOFXV(0:NDXMAX,1:NDTWCE),
     *                LXOFZV(0:NDZMAX,1:NDTWCE),
     *                LYOFXV(0:NDXMAX,1:NDTWCE),
     *                LZOFYV(0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS2/ LXOYZV(0:NDYMAX,0:NDZMAX,1:NDTWCE),
     *                LYOZXV(0:NDZMAX,0:NDXMAX,1:NDTWCE),
     *                LZOXYV(0:NDXMAX,0:NDYMAX,1:NDTWCE)
     *
     *       /BLIMS3/ NXMAXV(1:NDTWCE),NYMAXV(1:NDTWCE),
     *                NZMAXV(1:NDTWCE)
      COMMON
     *       /WFACTO/ WALPOT(0:NDCOUL,0:NDCOUL,1:NDPOLS,1:NDKART,0:1),
     *                WALFAC(0:NDCOUL,                  1:NDKART,0:1)
      COMMON
     *       /LISMOM/ LISLAM(1:NDPOLS),LISMIU(1:NDPOLS),NUPOLS
      COMMON
     *       /QMUTTI/ QMUT_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUT_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /FRAMUL/ QLMNEU(0:NDMULT,-NDMULT:NDMULT,0:1),
     *                QLMPRO(0:NDMULT,-NDMULT:NDMULT,0:1),
     *                QLMTOT(0:NDMULT,-NDMULT:NDMULT,0:1)
      COMMON
     *       /OURUNI/ QUNITS(0:NDMULT,0:NDMULT)
      COMMON
     *       /BFACTO/ BFOURI(0:NDCOUL,0:ND2MAX)
      COMMON
     *       /SCALNG/ HOMSCA(NDKART,NDTWCE)
      COMMON
     *       /DIMENS/ LDBASE
C
C=======================================================================
C
      CALL CPUTIM('INTCOU',1)
C
C=======================================================================
C         THIS SUBROUTINE CALCULATES MATRIX ELEMENTS OF THE  DIRECT
C         COULOMB OR YUKAWA MEAN-FIELD POTENTIAL. THE SOURCE CAN BE
C         ARBITRARY; IT IS ASSUMED TO BE PROVIDED IN  THE  "SONBAS"
C         ARRAY. THE SURFACE  CORRECTIONS  ARE  INCLUDED  ONLY  FOR
C         ISURFA=1. THEN THEY PERTAIN TO THE  CHARGE  SOURCE  TERM.
C         THE SURFACE CORRECTIONS ARE VALID ONLY  FOR  THE  COULOMB
C         POTENTIAL, BECAUSE, FOR THE YUKAWA  GREEN  FUNCTION,  THE
C         MULTIPOLE EXPANSION IS MORE COMPLICATED, AND IS  NOT  YET
C         PROGRAMMED. BUT THE EXPONENTIAL DECAY OF THE YUKAWA MEAN-
C         FIELD POTENTIAL  MAKES  THE  SURFACE  TERM  INSIGNIFICANT
C         ANYHOW.
C         NEW IN VERSION 2.55G: OPTION KFRAGM ADDED TO ALLOW CALCU-
C         LATIONS OF COULOMB ENERGIES FOR TWO FRAGMENTS. THE MULTI-
C         POLE MOMENTS USED TO COMPUTE THE  SURFACE TERMS ARE THOSE
C         OF THE INDIVIDUAL FRAGMENTS WITH KFRAGM=0: LEFT FRAGMENT,
C         KFRAGM=1: RIGHT FRAGMENT.
C=======================================================================
C
      C_ZERO=CMPLX(0.0D0,0.0D0)
C
      PI     = 4.0D0 * ATAN(1.0D0)
      FACOUL = 8.0D0 * ECHARG / PI / BOUCOU
      FACPIO = 2.0D0 * (PIOMAS*BOUCOU/PI)**2
C
      HPPCOU(:,:)=C_ZERO
      IF (ISIMPY.NE.1) THEN
          HPMCOU(:,:)=C_ZERO
      END IF
C
C=======================================================================
C
C         EXTRACTING THE PROTON MULTIPOLE MOMENTS WHICH WILL BE USED FOR
C         A CALCULATION OF THE COULOMB POTENTIAL AT THE  BOX  BOUNDARIES
C
C         BEGINNING WITH VERSION 2.20S (DATE 05/12/08) THE SUBROUTINE IS
C         ADOPTED FOR USING  C O M P L E X  TRANSITION MULTIPOLE MOMENTS
C         "QMUT_P", WHICH ARE USED FOR IKERNE=1. FOR IKERNE=0,  STANDARD
C         DIAGONAL MULTIPOLE MOMENTS "QMUL_P" ARE USED. THIS DISTINCTION
C         IS IRRELEVANT DURING THE ITERATION, BUT MUST BE MADE WHEN  THE
C         RUN IS RESTARTED FROM THE DISK, WHERE ONLY DIAGONAL  MULTIPOLE
C         MOMENTS ARE SAVED.
C
C         ARRAY "PROMOM" BELOW CONTAINS COEFFICIENTS OF  REAL  PARTS  OF
C         SPHERICAL HARMONICS Y_{L, M} (FOR M>0) AND IMAGINARY PARTS  OF
C         SPHERICAL HARMONICS Y_{L,-M} (FOR M<0).
C
C         THE CORRESPONDING FORMULA READS
C
C         U = \SUM_{L,M} C_L                   Q_{L,M}     Y_{L, M}
C           = \SUM_L     C_L                   Q_{L,0}     Y_{L, 0}
C                       + 2*\SUM_{M>0}         Q_{L,M} (Re Y_{L, M})
C                       + 2*\SUM_{M<0} (-1)**M Q_{L,M} (Im Y_{L,-M})
C
C         WHERE C_L = 4*PI*E**2/((2*L+1)*R**(L+1))
C
C=======================================================================
C
      IF (ISURFA.EQ.1) THEN
C
          DO MULPOL=1,NUPOLS
C
             LAMBDA=LISLAM(MULPOL)
             MIU   =LISMIU(MULPOL)
C
             IF (MIU.LT.0.AND.ISIMPY.EQ.1) STOP
     *
     *          'FOR ISIMPY=1, A NEGATIVE MIU IS NOT ALLOWED IN INTCOU'
C
             IF (KFRAGM.EQ.0) THEN
                 IF (IKERNE.EQ.1) THEN
                     PROMOM(MULPOL)=QMUT_P(LAMBDA,     MIU)/
     *                              QUNITS(LAMBDA,ABS(MIU))
                 ELSE
                     PROMOM(MULPOL)=QMUL_P(LAMBDA,     MIU)/
     *                              QUNITS(LAMBDA,ABS(MIU))
                 END IF
             ELSE
                 PROMOM(MULPOL)=QLMPRO(LAMBDA,MIU,KFRAGM-1)/
     *                              QUNITS(LAMBDA,ABS(MIU))
             END IF
C
             IF (MIU.NE.0)
     *
     *           PROMOM(MULPOL)=        2*PROMOM(MULPOL)
C
             IF (MIU.LT.0)
     *
     *           PROMOM(MULPOL)=(-1)**MIU*PROMOM(MULPOL)
C
          END DO
C
      ELSE
C
          DO MULPOL=1,NUPOLS
C
             PROMOM(MULPOL) = C_ZERO
C
          END DO
C
      END IF
C
C=======================================================================
C         VECTORIZATION COMMENT:
C         BELOW, TWO VERSIONS OF DO-LOOPS ARE PROGRAMMED:
C
C         1. SCALAR DO-LOOPS, WHICH RUN ONLY OVER THE  REQUIRED  INDICES
C         2. VECTOR DO-LOOPS, WHICH SWEEP LARGER AREAS OF ARRAY  INDICES
C
C         SCALAR (VECTOR) DO-LOOPS ARE ACTIVATED  BY  THE  PRE-PORCESSOR
C         DIRECTIVE "SWITCH_VECT=="0(1). DEPENDING ON THE COMPILER  USED
C         AND/OR ARCHITECTURE OF THE SYSTEM, THEY MAY LEAD TO SMALLER OR
C         OR HIGHER EXECUTION TIMES.
C=======================================================================
C         CALCULATING THE FOURIER TRANSFORM OF THE CHARGE DENSITY
C=======================================================================
C         X - DIRECTION
C=======================================================================
C
      DO JX=0,NUMCOU
         IPCOUX=MOD(JX,2)
         GREENX=(HOMSCA(1,1)*(JX+1))**2
C
         DO KY=0,2*NYMAXV(1)
            DO KZ=0,2*NZMAXV(1)
C
               RESULT=C_ZERO
C
#if(SWITCH_VECT==1)
               DO KX=0,2*NXMAXV(1)
#else
               DO KX=IPCOUX,2*NXMAXV(1),2
#endif
                  RESULT=RESULT+BFOURI(JX,KX)*SONBAS(KX,KY,KZ)
               END DO
C
               XFOURI(JX,KY,KZ)=RESULT
C
            END DO
         END DO
C
C=======================================================================
C         Y - DIRECTION
C=======================================================================
C
         DO JY=0,NUMCOU
            IPCOUY=MOD(JY,2)
            GREENY=(HOMSCA(2,1)*(JY+1))**2
C
            DO KZ=0,2*NZMAXV(1)
C
               RESULT=C_ZERO
C
#if(SWITCH_VECT==1)
               DO KY=0,2*NYMAXV(1)
#else
               DO KY=IPCOUY,2*NYMAXV(1),2
#endif
                  RESULT=RESULT+BFOURI(JY,KY)*XFOURI(JX,KY,KZ)
               END DO
C
               YFOURI(   JY,KZ)=RESULT
C
            END DO
C
C=======================================================================
C         Z - DIRECTION
C=======================================================================
C
            DO JZ=0,NUMCOU
               IPCOUZ=MOD(JZ,2)
               GREENZ=(HOMSCA(3,1)*(JZ+1))**2
C
               RESULT=C_ZERO
#if(SWITCH_VECT==1)
               DO KZ=0,2*NZMAXV(1)
#else
               DO KZ=IPCOUZ,2*NZMAXV(1),2
#endif
                  RESULT=RESULT+BFOURI(JZ,KZ)*YFOURI(   JY,KZ)
               END DO
C
C=======================================================================
C              MULTIPOLE CONTRIBUTIONS FROM THE SURFACE TERMS
C=======================================================================
C
               IF (ISURFA.EQ.1) THEN
C
                   SURFAC = C_ZERO
C
                   DO MULPOL=1,NUPOLS
C
                      SURFAC = SURFAC + PROMOM(MULPOL)
     *
     *                       * (WALPOT(JX,JY,MULPOL,3,0)*WALFAC(JZ,3,0)
     *                       +  WALPOT(JX,JY,MULPOL,3,1)*WALFAC(JZ,3,1)
     *
     *                       +  WALPOT(JZ,JX,MULPOL,2,0)*WALFAC(JY,2,0)
     *                       +  WALPOT(JZ,JX,MULPOL,2,1)*WALFAC(JY,2,1)
     *
     *                       +  WALPOT(JY,JZ,MULPOL,1,0)*WALFAC(JX,1,0)
     *                       +  WALPOT(JY,JZ,MULPOL,1,1)*WALFAC(JX,1,1))
C
                   END DO
C
               ELSE
C
                   SURFAC = C_ZERO
C
               END IF
C
C=======================================================================
C              TOTAL CONTRIBUTION TO THE FOURIER TRANSFORM
C=======================================================================
C
               GREENN=GREENX+GREENY+GREENZ+FACPIO
C
               ZFOURI(      JZ)=FACOUL*(RESULT + SURFAC)/GREENN
C
            END DO
C
C=======================================================================
C         CALCULATING THE INVERSE FOURIER TRANSFORM
C=======================================================================
C         Z - DIRECTION
C=======================================================================
C
            DO KZ=0,2*NZMAXV(1)
               IPCOUZ=MOD(KZ,2)
C
               RESULT=C_ZERO
C
#if(SWITCH_VECT==1)
               DO JZ=0,NUMCOU
#else
               DO JZ=IPCOUZ,NUMCOU,2
#endif
                  RESULT=RESULT+BFOURI(JZ,KZ)*ZFOURI(      JZ)
               END DO
C
               YFOURI(   JY,KZ)=RESULT
C
            END DO
         END DO
C
C=======================================================================
C         Y - DIRECTION
C=======================================================================
C
         DO KY=0,2*NYMAXV(1)
            IPCOUY=MOD(KY,2)
            DO KZ=0,2*NZMAXV(1)
C
               RESULT=C_ZERO
C
#if(SWITCH_VECT==1)
               DO JY=0,NUMCOU
#else
               DO JY=IPCOUY,NUMCOU,2
#endif
                  RESULT=RESULT+BFOURI(JY,KY)*YFOURI(   JY,KZ)
               END DO
C
               XFOURI(JX,KY,KZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         X - DIRECTION
C=======================================================================
C
      DO KX=0,2*NXMAXV(1)
         IPCOUX=MOD(KX,2)
         DO KY=0,2*NYMAXV(1)
            DO KZ=0,2*NZMAXV(1)
C
               RESULT=C_ZERO
C
#if(SWITCH_VECT==1)
               DO JX=0,NUMCOU
#else
               DO JX=IPCOUX,NUMCOU,2
#endif
                  RESULT=RESULT+BFOURI(JX,KX)*XFOURI(JX,KY,KZ)
               END DO
C
               SONBAS(KX,KY,KZ)=RESULT
C
            END DO
         END DO
      END DO
C
C=======================================================================
C         CALCULATING THE SIX-HERMIT MATRIX ELEMENTS
C=======================================================================
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
      DO NX=0,NXMAXV(1)
         DO MX=0,NXMAXV(1)
C
            DO KY=0,2*NYMAXV(1)
               DO KZ=0,2*NZMAXV(1)
C
                  RESULT=C_ZERO
C
                  DO KX=NX+MX,0,-2
                     RESULT=RESULT+COUL00(KX,MX,NX,1)*SONBAS(KX,KY,KZ)
                  END DO
C
                  X_HELP(KY,KZ)=RESULT
C
               END DO
            END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
            DO NY=0,LYOFXV(NX,1)
               DO MY=0,LYOFXV(MX,1)
C
                  IF (IPHAPP(NY,MY,0).EQ.0.AND.ISIMPY.EQ.1) GO TO 1
C
                  DO KZ=0,2*NZMAXV(1)
C
                  RESULT=C_ZERO
C
                     DO KY=NY+MY,0,-2
                        RESULT=RESULT+COUL00(KY,MY,NY,2)*X_HELP(KY,KZ)
                     END DO
C
                     Y_HELP(KZ)=RESULT
C
                  END DO
C
C=======================================================================
C        HERE BEGIN LOOPS OVER THE QUANTUM NUMBERS IN THE Z DIRECTION
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,1)
                     DO MZ=0,LZOXYV(MX,MY,1)
C
                        RESULT=C_ZERO
C
#if(SWITCH_VECT==1)
                        DO KZ=0,LZOXYV(NX,NY,1)+LZOXYV(MX,MY,1)
#else
                        DO KZ=NZ+MZ,0,-2
#endif
                           RESULT=RESULT+COUL00(KZ,MZ,NZ,3)*Y_HELP(KZ)
                        END DO
C
                        Z_HELP(NZ,MZ)=RESULT
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-CONSERVING BLOCK
C=======================================================================
C
                  DO NZ=0,LZOXYV(NX,NY,1)
                     DO MZ=0,LZOXYV(MX,MY,1)
C
                        HPPCOU(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *                            Z_HELP(NZ,MZ)*IPHAPP(NY,MY,0)
C
                     END DO
                  END DO
C
C=======================================================================
C        FINAL CONSTRUCTION OF MATRIX ELEMENTS
C        IN THE SIMPLEX-NON-CONSERVING BLOCK
C=======================================================================
C
            IF (ISIMPY.NE.1) THEN
C
                DO NZ=0,LZOXYV(NX,NY,1)
                    DO MZ=0,LZOXYV(MX,MY,1)
C
                      HPMCOU(INDICE(NX,NY,NZ,1),INDICE(MX,MY,MZ,1))=
     *                                 Z_HELP(NZ,MZ)*IPHAPM(NY,MY,0)
C
                    END DO
                END DO
C
            END IF
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE Y DIRECTION
C=======================================================================
C
    1             CONTINUE
C
               END DO
            END DO
C
C=======================================================================
C        END OF LOOPS OVER QUANTUM NUMBERS IN THE X DIRECTION
C=======================================================================
C
         END DO
      END DO
C
C=======================================================================
C
      CALL CPUTIM('INTCOU',0)
C
      RETURN
      END
C
C=======================================================================
      !-----------------------------------------------------------------
      subroutine broyden_n(nddim,ndim,vvout,vvin,alphamix,dr2,iter,
     *                            n_iter,W0_BRO,WN_BRO,nstart)
      !-----------------------------------------------------------------
      ! Modified Broyden's method for potential/charge density mixing
      !             D.D.Johnson, PRB 38, 12807 (1988)
      ! Addopted from: (C) 2001 PWSCF group
      ! Input :
      !    ndim      dimension of arrays vout, vin
      !    vout      output potential/rho at current iteration
      !    vin       potential/rho at previous iteration
      !    alphamix  mixing factor (0 < alphamix <= 1)
      !    iter      current iteration number
      !    n_iter    number of iterations used in the mixing
      ! Output:
      !    dr2       MaxVal(|vout-vin|)
      !    vin       mixed potential
      !    vout      vout-vin
      ! maxter: max number of iterations used in mixing (n_iter<=maxter)
      ! w0,w:   adjustable parameters as suggested in the original paper
      ! df,dv:  work space containing info from previous iterations
      implicit none
      !
#if(USE_MPI==1)
      include 'mpif.h'
#endif
      Integer, Intent(In)    :: nddim,ndim,iter,n_iter,nstart
      Real, Intent(In)   :: alphamix, W0_BRO,WN_BRO
      Real, Intent(Out)  :: dr2
      Real, Intent(InOut):: vvout(nddim),vvin(nddim)
      !
      Integer :: maxter; Parameter (maxter = 10)
      Integer :: iunit,iunmix,n,i,j,iwork (maxter),info,
     *          iter_used,ipos,inext, idProc
#if(USE_MPI==1)
      integer mpi_err    ! Error flag
#endif
      !
      Real, Allocatable, save :: dfn(:,:),dvn(:,:)
      Real, Allocatable :: vinsave (:)
      Real, Allocatable ::  vin(:),vout(:)
      Real :: w(maxter),w0
      Real :: beta (maxter,maxter),work(maxter),norm,gamma
      Real :: DDOT,DNRM2
      External DDOT, DNRM2
      !
      w0 = W0_BRO
      do i=1,maxter
         w(i) = WN_BRO
      end do
      !
      Allocate(vin(1:ndim))
      Allocate(vout(1:ndim))
      vin=vvin(1:ndim)
      vout=vvout(1:ndim)
      !
      if (nstart.eq.0) then
          vout=vout-vin
          vin=vin+alphamix*vout
          vvout(1:ndim)=vout
          vvin(1:ndim)=vin
          deallocate(vin,vout)
          return
      end if
      !
      if (iter.lt.0)        Stop '  In Broyden: iter is wrong '
      if (n_iter.gt.maxter) Stop '  In Broyden: n_iter too big'
      if (ndim.le.0)        Stop '  In Broyden: ndim .le. 0   '
      !
      iter_used=min(iter-1,n_iter)
      ipos=iter-1-((iter-2)/n_iter)*n_iter
      vout=vout-vin
      dr2=MaxVal(Abs(vout))
C
      if (iter.eq.0) return
      !
      if (iter.eq.1) then
         If(Allocated(dfn)) DeAllocate(dfn,dvn)
         Allocate(dfn(ndim,n_iter),dvn(ndim,n_iter))
         dfn=0.0d0; dvn=0.0d0
      else
         dfn(:,ipos)=vout(:)-dfn(:,ipos)
         dvn(:,ipos)=vin(:)-dvn(:,ipos)
         norm=Sqrt((DNRM2(ndim,dfn(1,ipos),1))**2)
         Call dscal(ndim,1.0d0/norm,dfn(1,ipos),1)
         Call dscal(ndim,1.0d0/norm,dvn(1,ipos),1)
      endif
C
      Allocate(vinsave(ndim))
      Call dcopy(ndim,vin,1,vinsave,1)
      !
      do i=1,iter_used
         do j=i+1,iter_used
            beta(i,j)=w(i)*w(j)*DDOT(ndim,dfn(1, j),1,dfn(1,i),1)
         enddo
         beta(i,i)=w0**2+w(i)**2
      enddo
C
#if(SWITCH_ESSL==0)
      Call DSYTRF('U', iter_used, beta, maxter, iwork, work, maxter,
     *                                                         info)
#else
      Call DPOTRF('U', iter_used, beta, maxter, info)
#endif
C
      if(info.ne.0) then
C
         idProc = 0
#if(USE_MPI==1)
         call mpi_comm_rank(MPI_COMM_WORLD, idProc, mpi_err)
#endif
         write(6,'("info = ",i9," from proc ",i4)') info,idProc
         Stop '  In Broyden: info at DSYTRF '
C
      end if
C
#if(SWITCH_ESSL==0)
      Call DSYTRI('U', iter_used, beta, maxter, iwork, work, info)
#else
      Call DPOTRI('U', iter_used, beta, maxter, info)
#endif
C
      if(info.ne.0) then
C
         idProc = 0
#if(USE_MPI==1)
         call mpi_comm_rank(MPI_COMM_WORLD, idProc, mpi_err)
#endif
         write(6,'("info = ",i9)') info
         Stop '  In Broyden: info at DSYTRI '
C
      end if
C
      do i=1,iter_used
         do j=i+1,iter_used
            beta(j,i)=beta(i,j)
         enddo
         work(i)=DDOT(ndim,dfn(1,i),1,vout,1)
      enddo
C
      vin=vin+alphamix*vout
C
      do i=1,iter_used
         gamma=0.0d0
         do j=1,iter_used
            gamma=gamma+beta(j,i)*w(j)*work(j)
         enddo
         vin=vin-w(i)*gamma*(alphamix*dfn(:,i)+dvn(:,i))
      enddo
      !
      inext=iter-((iter-1)/n_iter)*n_iter
C
      Call dcopy(ndim,vout,1,dfn(1,inext),1)
      Call dcopy(ndim,vinsave,1,dvn(1,inext),1)
C
      vvout(1:ndim)=vout
      vvin(1:ndim)=vin
C
      DeAllocate(vinsave)
      DeAllocate(vin)
      DeAllocate(vout)
      !
      return
      !
      end subroutine broyden_n
      !-----------------------------------------------------------------
      subroutine broyden_p(nddim,ndim,vvout,vvin,alphamix,dr2,iter,
     *                            n_iter,W0_BRO,WN_BRO,nstart)
      !-----------------------------------------------------------------
      ! Modified Broyden's method for potential/charge density mixing
      !             D.D.Johnson, PRB 38, 12807 (1988)
      ! Addopted from: (C) 2001 PWSCF group
      ! Input :
      !    ndim      dimension of arrays vout, vin
      !    vout      output potential/rho at current iteration
      !    vin       potential/rho at previous iteration
      !    alphamix  mixing factor (0 < alphamix <= 1)
      !    iter      current iteration number
      !    n_iter    number of iterations used in the mixing
      ! Output:
      !    dr2       MaxVal(|vout-vin|)
      !    vin       mixed potential
      !    vout      vout-vin
      ! maxter: max number of iterations used in mixing (n_iter<=maxter)
      ! w0,w:   adjustable parameters as suggested in the original paper
      ! df,dv:  work space containing info from previous iterations
      implicit none
      !
#if(USE_MPI==1)
      include 'mpif.h'
#endif
      Integer, Intent(In)    :: nddim,ndim,iter,n_iter,nstart
      Real, Intent(In)   :: alphamix, W0_BRO,WN_BRO
      Real, Intent(Out)  :: dr2
      Real, Intent(InOut):: vvout(nddim),vvin(nddim)
      !
      Integer :: maxter; Parameter (maxter = 10)
      Integer :: iunit,iunmix,n,i,j,iwork (maxter),info,
     *          iter_used,ipos,inext, idProc
      !
#if(USE_MPI==1)
      integer mpi_err    ! Error flag
#endif
      Real, Allocatable, save :: dfp(:,:),dvp(:,:)
      Real, Allocatable :: vinsave (:)
      Real, Allocatable ::  vin(:),vout(:)
      Real :: w(maxter),w0
      Real :: beta (maxter,maxter),work(maxter),norm,gamma
      Real :: DDOT,DNRM2
      External DDOT, DNRM2
      !
      w0 = W0_BRO
      do i=1,maxter
         w(i) = WN_BRO
      end do
      !
      Allocate(vin(1:ndim))
      Allocate(vout(1:ndim))
      vin=vvin(1:ndim)
      vout=vvout(1:ndim)
      !
      if (nstart.eq.0) then
          vout=vout-vin
          vin=vin+alphamix*vout
          vvout(1:ndim)=vout
          vvin(1:ndim)=vin
          deallocate(vin,vout)
          return
      end if
      !
      if (iter.lt.0)        Stop '  In Broyden: iter is wrong '
      if (n_iter.gt.maxter) Stop '  In Broyden: n_iter too big'
      if (ndim.le.0)        Stop '  In Broyden: ndim .le. 0   '
      !
      iter_used=min(iter-1,n_iter)
      ipos=iter-1-((iter-2)/n_iter)*n_iter
      vout=vout-vin
      dr2=MaxVal(Abs(vout))
C
      if (iter.eq.0) return
      !
      if (iter.eq.1) then
         If(Allocated(dfp)) DeAllocate(dfp,dvp)
         Allocate(dfp(ndim,n_iter),dvp(ndim,n_iter))
         dfp=0.0d0; dvp=0.0d0
      else
         dfp(:,ipos)=vout(:)-dfp(:,ipos)
         dvp(:,ipos)=vin(:)-dvp(:,ipos)
         norm=Sqrt((DNRM2(ndim,dfp(1,ipos),1))**2)
         Call dscal(ndim,1.0d0/norm,dfp(1,ipos),1)
         Call dscal(ndim,1.0d0/norm,dvp(1,ipos),1)
      endif
C
      Allocate(vinsave(ndim))
      Call dcopy(ndim,vin,1,vinsave,1)
      !
      do i=1,iter_used
         do j=i+1,iter_used
            beta(i,j)=w(i)*w(j)*DDOT(ndim,dfp(1, j),1,dfp(1,i),1)
         enddo
         beta(i,i)=w0**2+w(i)**2
      enddo
C
#if(SWITCH_ESSL==0)
      Call DSYTRF('U', iter_used, beta, maxter, iwork, work, maxter,
     *                                                         info)
#else
      Call DPOTRF('U', iter_used, beta, maxter, info)
#endif
C
      if(info.ne.0) then
C
         idProc = 0
#if(USE_MPI==1)
         call mpi_comm_rank(MPI_COMM_WORLD, idProc, mpi_err)
#endif
         write(6,'("info = ",i9)') info
         Stop '  In Broyden: info at DSYTRF '
C
      end if
C
#if(SWITCH_ESSL==0)
      Call DSYTRI('U', iter_used, beta, maxter, iwork, work, info)
#else
      Call DPOTRI('U', iter_used, beta, maxter, info)
#endif
C
      if(info.ne.0) then
C
         idProc = 0
#if(USE_MPI==1)
         call mpi_comm_rank(MPI_COMM_WORLD, idProc, mpi_err)
#endif
         write(6,'("info = ",i9)') info
         Stop '  In Broyden: info at DSYTRI '
C
      end if
C
      do i=1,iter_used
         do j=i+1,iter_used
            beta(j,i)=beta(i,j)
         enddo
         work(i)=DDOT(ndim,dfp(1,i),1,vout,1)
      enddo
C
      vin=vin+alphamix*vout
C
      do i=1,iter_used
         gamma=0.0d0
         do j=1,iter_used
            gamma=gamma+beta(j,i)*w(j)*work(j)
         enddo
         vin=vin-w(i)*gamma*(alphamix*dfp(:,i)+dvp(:,i))
      enddo
      !
      inext=iter-((iter-1)/n_iter)*n_iter
C
      Call dcopy(ndim,vout,1,dfp(1,inext),1)
      Call dcopy(ndim,vinsave,1,dvp(1,inext),1)
C
      vvout(1:ndim)=vout
      vvin(1:ndim)=vin
C
      DeAllocate(vinsave)
      DeAllocate(vin)
      DeAllocate(vout)
      !
      return
      !
      end subroutine broyden_p
C
      !-----------------------------------------------------------------
      subroutine broyden(nddim,ndim,vvout,vvin,alphamix,dr2,iter,
     *                            n_iter,W0_BRO,WN_BRO,nstart,info)
      !-----------------------------------------------------------------
      ! Modified Broyden's method for potential/charge density mixing
      !             D.D.Johnson, PRB 38, 12807 (1988)
      ! Addopted from: (C) 2001 PWSCF group
      ! Input :
      !    ndim      dimension of arrays vout, vin
      !    vout      output potential/rho at current iteration
      !    vin       potential/rho at previous iteration
      !    alphamix  mixing factor (0 < alphamix <= 1)
      !    iter      current iteration number
      !    n_iter    number of iterations used in the mixing
      ! Output:
      !    dr2       MaxVal(|vout-vin|)
      !    vvin      mixed potential
      !    vvout     vout-vin
      !    info      error code
      ! maxter: max number of iterations used in mixing (n_iter<=maxter)
      ! w0,w:   adjustable parameters as suggested in the original paper
      ! df,dv:  work space containing info from previous iterations
      implicit none
      !
      Integer, Intent(In)    :: nddim,ndim,iter,n_iter,nstart
      Integer, Intent(InOut) :: info
      Real, Intent(In)   :: alphamix, W0_BRO,WN_BRO
      Real, Intent(Out)  :: dr2
      Real, Intent(InOut):: vvout(nddim),vvin(nddim)
      !
      Integer :: maxter; Parameter (maxter = 10)
      Integer :: iunit,iunmix,n,i,j,iwork (maxter),
     *           iter_used,ipos,inext, idProc
      !
      Real, Allocatable, save :: df(:,:),dv(:,:),vinsave (:)
      Real, Allocatable ::  vin(:),vout(:)
      Real :: w(maxter),w0
      Real :: beta (maxter,maxter),work(maxter),norm,gamma
      Real :: DDOT,DNRM2
      External DDOT, DNRM2
      !
      w0 = W0_BRO
      do i=1,maxter
         w(i) = WN_BRO
      end do
      !
      Allocate(vin(1:ndim))
      Allocate(vout(1:ndim))
      vin=vvin(1:ndim)
      vout=vvout(1:ndim)
      !
      if(iter.lt.0)        info=1
      if(n_iter.gt.maxter) info=2
      if(ndim.le.0)        info=3
      !
      if(nstart.eq.0.or.info.gt.0) then
         vout=vout-vin
         vin=vin+alphamix*vout
         vvout(1:ndim)=vout
         vvin(1:ndim)=vin
         deallocate(vin,vout)
         return
      end if
      !
      iter_used=min(iter-1,n_iter)
      ipos=iter-1-((iter-2)/n_iter)*n_iter
      vout=vout-vin
      dr2=MaxVal(Abs(vout))
C
      if(iter.eq.0) return
      !
      if(iter.eq.1) then
        If(Allocated(df)) Deallocate(df,dv)
        Allocate(df(ndim,n_iter),dv(ndim,n_iter))
        df=0.0d0; dv=0.0d0
      else
        df(:,ipos)=vout(:)-df(:,ipos)
        dv(:,ipos)=vin(:)-dv(:,ipos)
        norm=Sqrt((DNRM2(ndim,df(1,ipos),1))**2)
        Call dscal(ndim,1.0d0/norm,df(1,ipos),1)
        Call dscal(ndim,1.0d0/norm,dv(1,ipos),1)
      endif
C
      Allocate(vinsave(ndim))
      Call dcopy(ndim,vin,1,vinsave,1)
      !
      do i=1,iter_used
         do j=i+1,iter_used
            beta(i,j)=w(i)*w(j)*DDOT(ndim,df(1, j),1,df(1,i),1)
         enddo
         beta(i,i)=w0**2+w(i)**2
      enddo
C
#if(SWITCH_ESSL==0)
      Call DSYTRF('U', iter_used, beta, maxter, iwork, work, maxter,
     *                                                         info)
#else
      Call DPOTRF('U', iter_used, beta, maxter, info)
#endif
C
      ! if some error occurs, we fall back to linear mixing and exit
      if(info.ne.0) then
         idProc = 0
         vout=vout-vin
         vin=vin+alphamix*vout
         vvout(1:ndim)=vout
         vvin(1:ndim)=vin
         deallocate(vinsave,vin,vout)
         return
      end if
C
#if(SWITCH_ESSL==0)
      Call DSYTRI('U', iter_used, beta, maxter, iwork, work, info)
#else
      Call DPOTRI('U', iter_used, beta, maxter, info)
#endif
C
      ! if some error occurs, we fall back to linear mixing and exit
      if(info.ne.0) then
         idProc = 0
         vout=vout-vin
         vin=vin+alphamix*vout
         vvout(1:ndim)=vout
         vvin(1:ndim)=vin
         deallocate(vinsave,vin,vout)
         return
      end if
C
      do i=1,iter_used
         do j=i+1,iter_used
            beta(j,i)=beta(i,j)
         enddo
         work(i)=DDOT(ndim,df(1,i),1,vout,1)
      enddo
C
      vin=vin+alphamix*vout
C
      do i=1,iter_used
         gamma=0.0d0
         do j=1,iter_used
            gamma=gamma+beta(j,i)*w(j)*work(j)
         enddo
         vin=vin-w(i)*gamma*(alphamix*df(:,i)+dv(:,i))
      enddo
      !
      inext=iter-((iter-1)/n_iter)*n_iter
C
      Call dcopy(ndim,vout,1,df(1,inext),1)
      Call dcopy(ndim,vinsave,1,dv(1,inext),1)
C
      vvout(1:ndim)=vout
      vvin(1:ndim)=vin
C
      Deallocate(vinsave)
      Deallocate(vin)
      Deallocate(vout)
      !
      return
      !
      end subroutine broyden
C
      subroutine proprxyz(R0PARM,IZNUMB,INNUMB,ax,ay,az)
C=======================================================================
      USE hfodd_sizes
C=======================================================================
c       only called in GEOMFR (!!)
c       include "auxlp.inc"
c
c       double precision R0PARM
c       integer IZNUMB, INNUMB , NFIPRI
c       double precision ax,ay,az
c       double precision aa,pi,pi23,q20,q22,r0,rr,f1,f2,f3,beta,gamma
c       external q20, q22, aa i r0=ROPARM
c
c       double precision STIFFQ, QASKED
      COMMON
     *       /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)
      COMMON
     *       /CFIPRI/ NFIPRI
c
c simply put values into COMMON auxlp, needed elsewhere
c       r0lp=r0parm
c       inlp=innumb
c       izlp=iznumb
c
        aa=dble(innumb+iznumb)
C
        pi=4.*atan(1.0d0)
        pi23=2.0d0*pi/3.0d0
        q20=QASKED(2,0)
        q22=QASKED(2,2)
        f1=sqrt(5.0d0/(4.0d0*pi))
        rr=R0PARM*aa**(1.0d0/3.0d0)
        f2=sqrt(5*pi)/3.0d0
        f3=rr**2*aa
        beta=f2/f3*100.0d0*sqrt(q20**2+q22**2)
        gamma=atan2(q22,q20)
C       write(NFIPRI,'("@LP_betgam_req ", f8.5, f8.3)')
C    *        beta, gamma*180.0/pi
        ax=1.0d0+f1*beta*cos(gamma-pi23)
        ay=1.0d0+f1*beta*cos(gamma-2.0d0*pi23)
        az=1.0d0+f1*beta*cos(gamma)
        return
        end subroutine proprxyz
C
C==========  Subroutines used in mass parameters calculations
C==========
      subroutine datatobh(innumb,iznumb,r0parm,numite,estabc,if_rpa)
      use hfodd_sizes
      use colcoord
CD    subroutine calculates and prints moments of inertia and
CD    mass parameters w.r.t. beta, gamma variables if condquad=.true.
CD    output format is convenient for further processing for the GBH code
CD
      COMMON /CFIPRI/ NFIPRI
      COMMON /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)

      COMMON /RMSRAD/ RADI_N(0:NDKART),
     *                RADI_P(0:NDKART),
     *                RADI_T(0:NDKART)

      COMMON /ALLENE/ EKIN_N,EKIN_P,EKIN_T,
     *                EPOT_N,EPOT_P,EPOT_T,
     *                ESUM_N,ESUM_P,ESUM_T,
     *                EPAI_N,EPAI_P,EPAI_T,
     *                EREA_N,EREA_P,EREA_T,
     *                ELIP_N,ELIP_P,ELIP_T,
     *                ECOULD,ECOULE,ECOULT,
     *                       ECOULS,ECOULV,
     *                EMULCO,EMUSLO,EMUREA,
     *                ESIFCO,ESISLO,ESIREA,
     *                ESPICO,ESPSLO,ESPREA,
     *                ENREAR,ECORCM,ECOR_R,
     *                EEVEW0,EODDW0,ENE_W0,
     *                ENEVEN,ENEODD,ENESKY,
     *                ESTABN,ETOTSP,ETOTFU
      COMMON /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON /BASINP/ BASINX(1:NDTWCE),BASINY(1:NDTWCE),
     *                BASINZ(1:NDTWCE),INPOME

      CHARACTER  ESTABC*12

      dimension aux1(1:2,1:2),aux3(1:2,1:2)
      dimension arqb(1:2,1:2),arqbt(1:2,1:2)
      character*40 fmt
      logical cond0


      cond0=((numcoor.eq.2).and.(icolcoor(1,1).eq.2).and.
     & (icolcoor(1,2).eq.0)
     & .and.(icolcoor(2,1).eq.2).and.(icolcoor(2,2).eq.2))

      condquad=(cond0.and.(if_rpa.eq.1).and.(inpome.eq.5))
CD    print *,"COND", cond0, if_rpa,inpome

      if (condquad) then
c     some calculations for beta, gamma case
      call getbetgam(innumb,iznumb,r0parm,beta,gamma,gammad,coef,
     &      betareq,gammadreq)

      write(nfipri,'("@MP_betgam_req ",f10.6,f11.4)') betareq,gammadreq
      write(nfipri,'("@MP_betgam_calc ",f10.6,f11.4)') beta,gammad

      pi=4.0*atan2(1.0,1.0)
      wisq3=1.0
      c=cos(gamma)
      s=sin(gamma)
      arqb(1,1)=c*coef
      arqb(2,1)=-s*coef*wisq3
      arqb(1,2)=s*coef
      arqb(2,2)=c*wisq3*coef

      arqbt=transpose(arqb)
      aux3=matmul(arqb,arbkj(1:2,1:2))
      aux1=matmul(aux3,arqbt)

      write (nfipri,'("@MP_mp_bg ",3f14.7)') aux1(1,1:2),aux1(2,2)
      aparmbg(1)=aux1(1,1)
      aparmbg(2)=aux1(1,2)
      aparmbg(3)=aux1(2,2)

      write(nfipri,'("@MP_main_1 ", I5,f8.4,f8.2,2f10.4,f13.6,A12," ",
     *      2f8.4,
     *      2f10.4,
     *      2f10.4)')
     *      numite,beta,gammad,qmul_t(2,0),qmul_t(2,2),
     * etotfu,ESTABC, DELTAN,DELTAP,EFERMN,EFERMP,
     * EPAI_N, EPAI_P
      write(nfipri,'("@MP_main_2 ",f8.4,f8.2,f13.6,6f13.6,6f11.6)')
     *      beta,gammad,
     * etotfu,amominer,aparmbg,radi_t(0)**2, qmul_p(2,0),qmul_p(2,2),
     * ggr

c     write(nfipri,'("@MP_main_3 ", I5,f8.4,f8.2,4f10.4,f13.6,A12," ",
c     *     2f8.4,
c     *     2f10.4,
c     *     2f10.4)')
c     *     numite,beta,gammad,
c     * qmul_t(3,0),qmul_t(3,1),qmul_t(3,2),qmul_t(3,3),
c     * etotfu,ESTABC, DELTAN,DELTAP,EFERMN,EFERMP,
c     * EPAI_N, EPAI_P

c     else
c           write(nfipri,*) "@condquad", condquad
      endif   ! condquad=.true.

      end subroutine datatobh


C==========
      subroutine enmomjone(emomsj,emomgy,idirec,icharg,ipahfb,jpabcs)
C
      use hfodd_sizes
c     for Lipkin version
c     integer LIPKIP,LIPKIN
      common /danelip/ LIPKIP,LIPKIN

      COMMON /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P
      COMMON /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)
      COMMON /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
c     for  diagnostics
c      COMMON /PROCCU/ V_OCCU(1:2*NDSTAT)

      dimension emomsj(0:1)
      complex celmaj, celmas,emomgy
      common /jotjot/ celmaj(1:ndbase,1:ndbase,0:ndreve),
     & celmas(1:ndbase,1:ndbase,0:ndreve)


c         this subroutine returns 1-st energy moments of j_k
c         - the angular momentum operators  ==>   emomsj(1)
c         for k=1=x, 2=y, 3=z (parameter idirec)
c
c         some quantities
c            celmaj - single particle matrix elements of j_i
c            celmas - single particle matrix elements of s_i
c            enquap - vector of quasiparticle energies
C
CD    assumptions: see the momsiner subroutine



      if (jpabcs.gt.0) then
            stop 'Moments of inertia not implemented for JPABCS>0)'
      endif

      call jkmatel(icharg,idirec,ipahfb,jpabcs)
C
      emomsj=0.0
      emomgy=0.0
C
c     lambda2 from Lipkin, only for HFB
      ex2lam2=0.0
      if (ipahfb.eq.1) then
            if (icharg.eq.0) then
                  if (lipkin.eq.1) then
                        ex2lam2=efer2n
                  endif
            else
                  if (lipkip.eq.1) then
                        ex2lam2=efer2p
                  endif
            endif
      endif



      do irever=0,ndreve

      if (ipahfb.eq.1) then
            lstate=numbqp(irever,icharg)
C     else
CD          for BCS case
      endif

         do jstate=1,lstate
            do istate=1,lstate
               if (ipahfb.eq.1) then
CD     2*lambda2 is added from Lipkin
               edenom=enquap(istate,0)+enquap(jstate,0)+2*ex2lam2
C               else
CD          branch for BCS case
               endif

               elmabs=abs(celmaj(istate,jstate,irever))**2
               eljotgy=conjg(celmaj(istate,jstate,irever))*
     &              celmas(istate,jstate,irever)
               emomsj(1)=emomsj(1)+elmabs/edenom
               emomgy=emomgy+eljotgy/edenom
            end do
         end do
      end do
c
      return
      end subroutine enmomjone

C==========
      subroutine f2oper(spoper,f2elem,icharg)
c     matrix elements (f2elem) of the type <alpha.beta.f>
c
      use allqua
      use hfodd_sizes
      use complex_const

      complex f2elem,spoper,dummy1,dummy2,dum3
      dimension spoper(1:ndbase,1:ndbase),
     *   f2elem(1:ndbase,1:ndbase,0:ndreve),
     *   dummy1(1:ndbase,1:ndbase),
     *   dummy2(1:ndbase,1:ndbase), dum3(1:ndbase,1:ndbase)

      COMMON /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON /DIMENS/ LDBASE

c    this routine calculates matrix elements <alpha.beta.f>
c    where alpha and beta are qp-annihilation operators and
c    f is a single particle hermit. simplex-even operator

      if (.not.allocated(awaqua)) then
         allocate (awaqua(1:ndbase,1:ndstat,0:ndreve),stat=ialloc)
         if (ialloc.ne.0) call noallo('awaqua','f2oper')
      end if

      if (.not.allocated(bwaqua)) then
         allocate (bwaqua(1:ndbase,1:ndstat,0:ndreve),stat=ialloc)
         if (ialloc.ne.0) call noallo('bwaqua','f2oper')
      end if


      f2elem = c_zero
      dummy1 = c_zero
      dummy2 = c_zero
      dum3 = c_zero
c          construction of the f20 - matrix
c element <alpha_k . alpha_l . f>* (+,-) in simplex
c
      call zgemm('t','n',numbqp(0,icharg),ldbase,ldbase,
     *   c_unit,bwaqua(1,1,0),ndbase,spoper,ndbase,
     *   c_zero,dummy1,ndbase)

      call zgemm('n','n',numbqp(0,icharg),numbqp(0,icharg),ldbase,
     *   c_unit,dummy1,ndbase,awaqua(1,1,0),ndbase,
     *   c_zero,dummy2,ndbase)

      dum3 = dummy2

      call zgemm('t','n',numbqp(1,icharg),ldbase,ldbase,
     *   c_unit,awaqua(1,1,1),ndbase,spoper,ndbase,
     *   c_zero,dummy1,ndbase)

      call zgemm('n','n',numbqp(1,icharg),numbqp(1,icharg),ldbase,
     *   c_unit,dummy1,ndbase,bwaqua(1,1,1),ndbase,
     *   c_zero,dummy2,ndbase)

      f2elem(:,:,0) = dum3-dummy2

      return
      end subroutine f2oper

C==========
      subroutine getbetgam(innumb,iznumb,r0parm,beta,gamma,gammad,coef,
     & betareq,gammadreq)
      use hfodd_sizes
CD    calculation of beta and gamma variables from quadrupole moments
CD    for required (QASKED) and calculated (QMULT_T) moments
      COMMON /QMULTI/ QMUL_N(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_P(0:NDMULT,-NDMULT:NDMULT),
     *                QMUL_T(0:NDMULT,-NDMULT:NDMULT)
      COMMON /QCNSTR/ STIFFQ(0:NDMULT,-NDMULT:NDMULT),
     *                QASKED(0:NDMULT,-NDMULT:NDMULT),
     *                IFLAGQ(0:NDMULT,-NDMULT:NDMULT)

      pi=4.*atan2(1.0,1.0)
      r0=r0parm
CD    for quadrupoles in [barn]
      r0b=r0/10.0
      aa=dble(innumb+iznumb)
      coef=3.0/sqrt(5.0*pi)*(r0b)**2*aa**(5.0/3.0)

      q20=qmul_t(2,0)
      q22=qmul_t(2,2)
      beta=sqrt(q20**2+q22**2)/coef
      gamma=atan2(q22,q20)
      gammad=gamma*180/pi

      q20req=qasked(2,0)
      q22req=qasked(2,2)
      betareq=sqrt(q20req**2+q22req**2)/coef
      gammareq=atan2(q22req,q20req)
      gammadreq=gammareq*180/pi

      end subroutine getbetgam

C==========
      subroutine invemo(mrever,icharg)
      use te_mas
      use hfodd_sizes
      use colcoord

c     integer LIPKIP,LIPKIN
      common /danelip/ LIPKIP,LIPKIN

      COMMON /DATPAN/ GPAIRN,FACTGN,EFERMN,DELTAN,EFER2N
     *       /DATPAP/ GPAIRP,FACTGP,EFERMP,DELTAP,EFER2P

      COMMON /QUAPAR/ ENQUAP(1:2*NDSTAT,0:NDREVE),
     *                V2QUAP(1:2*NDSTAT,0:NDREVE)

      COMMON /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON /COEMUL/ COMULT(0:NDMULT,0:NDOSCI,0:NDOSCI,1:NDKART)
      COMMON /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
C
      common /enmoms/ emomet(nccall,nccall,ndemom)
c
      dimension auxili(ndemom)
      integer laa,maa,ka,kb,lab,mab

      if(.not.allocated(opimre)) then
         allocate(opimre(1:ndbase,1:ndbase),stat=ialloc)
         if (ialloc.ne.0) call noallo('opimre','invemo')
      end if
      if(.not.allocated(fopqpa)) then
         allocate (fopqpa(1:ndbase,1:ndbase,0:ndreve),stat=ialloc)
         if (ialloc.ne.0) call noallo('fopqpa','invemo')
      end if
      if(.not.allocated(fopqpb)) then
         allocate (fopqpb(1:ndbase,1:ndbase,0:ndreve),stat=ialloc)
         if (ialloc.ne.0) call noallo('fopqpb','invemo')
      end if
      if(.not.allocated(spelem)) then
         allocate (spelem(1:ndbase,1:ndbase),stat=ialloc)
         if (ialloc.ne.0) call noallo('spelem','invemo')
      end if

c     collective coordinates from the module colcoord
c
c===     number of states
c
      num_qp=numbqp(mrever,icharg)
c
c     lambda2 from lipkin, only for hfb, not checked because invemo is
c     called for ipahfb=1
c
      ex2lam2=0.0
      if (icharg.eq.0) then
            if (lipkin.eq.1) then
                  ex2lam2=efer2n
            endif
      else
            if (lipkip.eq.1) then
                  ex2lam2=efer2p
            endif
      endif

      imarea=1
      do ka=1,numcoor

            laa=icolcoor(ka,1)
            maa=icolcoor(ka,2)
                  call intmul(iphapp(0,0,0),opimre,comult,
     *                                 laa,maa,imarea)
                  spelem=cmplx(opimre,0d0)

                  call f2oper(spelem,fopqpa,icharg)


            do kb=ka,numcoor
                  lab=icolcoor(kb,1)
                  mab=icolcoor(kb,2)
                  if (kb.eq.ka) then
                        fopqpb=fopqpa
                  else
                  call intmul(iphapp(0,0,0),opimre,comult,
     *                                 lab,mab,imarea)
                  spelem=cmplx(opimre,0d0)
                  call f2oper(spelem,fopqpb,icharg)
                  endif

c           composing inverse energy moments emomets

            auxili=0.0d0
c           print *,"invemo numqp, icharge", icharg, num_qp
            do iastqp=1,num_qp
               do ibstqp=1,num_qp
                 summeq=enquap(iastqp,0)+enquap(ibstqp,0)+2.0*ex2lam2
                 elprod=
     *           fopqpa(iastqp,ibstqp,0)*conjg(fopqpb(iastqp,ibstqp,0))

c                 inverse energy moments enmoms(n), n=1..ndemom
                  do k=1,ndemom
                     auxili(k)=auxili(k)+elprod/summeq**k
                  end do

               end do           ! ibstqp
            end do              ! iastqp

            factor=2.d0
            do k=1,ndemom
               emomet(ka,kb,k)=factor*auxili(k)
               if (kb.gt.ka) then
                     emomet(kb,ka,k)=emomet(ka,kb,k)
               endif
            end do
         end do                 ! kb
      end do                    ! ka

c      diagnostics
c      print *,"@emomet1", ((emomet(k,j,1),k=1,numcoor),j=1,numcoor)
c      print *,"@emomet3", ((emomet(k,j,3),k=1,numcoor),j=1,numcoor)

      deallocate (spelem,fopqpa,fopqpb,opimre)
      return
      end subroutine invemo

C==========
      subroutine jkmatel(icharg,indexj,ipahfb,jpabcs)
      use allwav
      use hfodd_sizes
      use complex_const
c
      complex celmaj,cauxil,celmas,cauxis
c
      dimension cauxil(1:ndbase,1:ndbase),rauxil(1:ndbase,1:ndbase),
     & cauxis(1:ndbase,1:ndbase)
      common /jotjot/ celmaj(1:ndbase,1:ndbase,0:ndreve),
     & celmas(1:ndbase,1:ndbase,0:ndreve)
C
      COMMON /T_PHAS/ IPHAPP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAPM(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMP(0:NDYMAX,0:NDYMAX,0:NDKART),
     *                IPHAMM(0:NDYMAX,0:NDYMAX,0:NDKART)
C
c     this subroutine calculates sp-matrix elements of j_k, k=x,y or z
c     and s_k
CD    assumptions: see momsiner subroutine
C
      cauxil=c_zero
      cauxis=c_zero
      factor=1.0
c
      if (indexj.eq.1) then
c     imarea=-1
         call int_lx(iphapm(0,0,0),rauxil,factor)
         call putima(+1,rauxil,cauxil)
c     imarea=+1
         call int_sx(rauxil,factor)
         call putrea(+1,rauxil,cauxil)
         call putrea(+1,rauxil,cauxis)
      end if
c
      if (indexj.eq.2) then
c     imarea=-1
         call int_ly(iphapp(0,0,0),rauxil,factor)
         call putima(+1,rauxil,cauxil)
c     imarea=+1
         call int_sy(rauxil,factor)
         call putrea(+1,rauxil,cauxil)
         call putrea(+1,rauxil,cauxis)
      end if
c
      if (indexj.eq.3) then
c     imarea=-1
         call int_lz(iphapm(0,0,0),rauxil,factor)
         call putima(+1,rauxil,cauxil)
         call int_sz(rauxil,factor)
         call putima(+1,rauxil,cauxil)
         call putima(+1,rauxil,cauxis)
      end if
C
c     matrix elements of <alpha beta f>, f=hermitian, time-odd,

      if (ipahfb.eq.1) then
            if (indexj.eq.2) then
                  call jyoper(cauxil,celmaj,icharg)
                  call jyoper(cauxis,celmas,icharg)
            else
                  call jxoper(cauxil,celmaj,icharg)
                  call jxoper(cauxis,celmas,icharg)
            end if
C      else
CD     branch for BCS case
      endif
c
      return
      end subroutine jkmatel

C==========
      subroutine jxoper(spoper,f2elem,icharg)
c
c     matrix elements (f2elem) of the type <alpha.beta.f>
c     f = hermitian, time-odd, simplex-odd
c     ipahfb=1
      use allqua

      use hfodd_sizes
      use complex_const
      complex f2elem,spoper,dummy1,dummy2

      dimension spoper(1:ndbase,1:ndbase),
     *   f2elem(1:ndbase,1:ndbase,0:ndreve),
     *   dummy1(1:ndbase,1:ndbase),
     *   dummy2(1:ndbase,1:ndbase)

      COMMON /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON /DIMENS/ LDBASE

c    this routine calculates matrix elements <alpha.beta.f>
c    where alpha and beta are qp-annihilation operators and
c    f is j_x type operator (or j_z)

      if (.not.allocated(awaqua)) then
         allocate (awaqua(1:ndbase,1:ndstat,0:ndreve),stat=ialloc)
         if (ialloc.ne.0) call noallo('awaqua','f2elem')
      end if

      if (.not.allocated(bwaqua)) then
         allocate (bwaqua(1:ndbase,1:ndstat,0:ndreve),stat=ialloc)
         if (ialloc.ne.0) call noallo('bwaqua','f2elem')
      end if

      f2elem = c_zero
      dummy1 = c_zero
      dummy2 = c_zero

c          construction of the f20 - matrix
c     element <alpha_k . alpha_l . f>* (+,+) and (--) in simplex
c
c     (++) block in simplex

clp@ zmiana drugiego t -> c  (conjg+transpose!)

      call zgemm('t','c',numbqp(1,icharg),ldbase,ldbase,
     *     c_unit,awaqua(1,1,1),ndbase,spoper,ndbase,
     *     c_zero,dummy1,ndbase)

      call zgemm('n','n',numbqp(1,icharg),numbqp(0,icharg),ldbase,
     *     c_unit,dummy1,ndbase,bwaqua(1,1,0),ndbase,
     *     c_zero,dummy2,ndbase)


      dummy1 = transpose(dummy2)
      f2elem(:,:,0) = dummy1-dummy2

c     (--) block in simplex
      dummy1 = c_zero
      dummy2 = c_zero

      call zgemm('t','n',numbqp(0,icharg),ldbase,ldbase,
     *     c_unit,awaqua(1,1,0),ndbase,spoper,ndbase,
     *     c_zero,dummy1,ndbase)

      call zgemm('n','n',numbqp(0,icharg),numbqp(1,icharg),ldbase,
     *     c_unit,dummy1,ndbase,bwaqua(1,1,1),ndbase,
     *     c_zero,dummy2,ndbase)

c     (--) block in simplex
      dummy1 = transpose(dummy2)
      f2elem(:,:,1) = dummy1-dummy2
c
      return
      end subroutine jxoper

C==========
      subroutine jyoper(spoper,f2elem,icharg)
c
c     matrix elements (f2elem) of the type <alpha.beta.f>,
c     f = hermitian, time-odd, simplex-even
c     ipahfb=1
      use allqua

      use hfodd_sizes
      use complex_const
      complex f2elem,spoper,dummy1,dummy2

      dimension spoper(1:ndbase,1:ndbase),
     *   f2elem(1:ndbase,1:ndbase,0:ndreve),
     *   dummy1(1:ndbase,1:ndbase),
     *   dummy2(1:ndbase,1:ndbase)

      COMMON /QPNUMS/ NUMBQP(0:NDREVE,0:NDISOS)
      COMMON /DIMENS/ LDBASE

c    this subroutine calculates matrix elements <alpha.beta.f>
c    where alpha and beta are qp-annihilation operators and
c    f is an operator of j_y type

      if (.not.allocated(awaqua)) then
         allocate (awaqua(1:ndbase,1:ndstat,0:ndreve),stat=ialloc)
         if (ialloc.ne.0) call noallo('awaqua','f2elem')
      end if

      if (.not.allocated(bwaqua)) then
         allocate (bwaqua(1:ndbase,1:ndstat,0:ndreve),stat=ialloc)
         if (ialloc.ne.0) call noallo('bwaqua','f2elem')
      end if

      f2elem = c_zero
      dummy1 = c_zero
      dummy2 = c_zero

c          construction of the f20 - matrix
c     element <alpha_k . alpha_l . f>* (+,-) and (-+) in simplex
c
      call zgemm('t','t',numbqp(1,icharg),ldbase,ldbase,
     *     c_unit,awaqua(1,1,1),ndbase,spoper,ndbase,
     *     c_zero,dummy1,ndbase)

      call zgemm('n','n',numbqp(1,icharg),numbqp(1,icharg),ldbase,
     *     c_unit,dummy1,ndbase,bwaqua(1,1,1),ndbase,
     *     c_zero,dummy2,ndbase)

c     +-
      f2elem(:,:,0) = dummy2
c     -+
      f2elem(:,:,1) = -transpose(dummy2)

      dummy1 = c_zero
      dummy2 = c_zero

      call zgemm('t','t',numbqp(0,icharg),ldbase,ldbase,
     *     c_unit,bwaqua(1,1,0),ndbase,spoper,ndbase,
     *     c_zero,dummy1,ndbase)

      call zgemm('n','n',numbqp(0,icharg),numbqp(0,icharg),ldbase,
     *     c_unit,dummy1,ndbase,awaqua(1,1,0),ndbase,
     *     c_zero,dummy2,ndbase)

c     (+-) block in simplex
      f2elem(:,:,0) = f2elem(:,:,0)+dummy2

c     (-+) block in simplex
      dummy1=transpose(dummy2)
      f2elem(:,:,1) = f2elem(:,:,1)-dummy1
c
      return
      end subroutine jyoper

C==========
      subroutine maspar_v0(ipahfb,jpabcs,icharg,mrever)
      use hfodd_sizes
      use colcoord

      common /enmoms/ emomet(nccall,nccall,ndemom)
      COMMON /CFIPRI/ NFIPRI
      character*40 fmt

CD    simple subroutine, called on TERMNT;
CD    assumptions ISIMPY=1, IROTATE=0, no temperature, one basis
CD    calls the main subroutine INVEMO, for IPAHFB=1
CD    in addition, for protons the totalsmp subroutine is called

      call cputim('maspar_v0',1)
c
      if (ipahfb.eq.1) then
            call invemo(mrever,icharg)
      else
            if (jpabcs.gt.0) then
            stop 'For JPABCS>0 mass parameters not implemented yet'
c           call invemobcs(mrever,icharg)
            endif
      endif
      amasmat(:,:,:,icharg)=emomet

c     print *, "amasmat", amasmat(1:2,1:2,3,icharg)
      if (icharg.eq.1) then
            call totalsmp
      end if

      if (icharg.eq.1) then
      write(fmt,'(A,I0,A)') '("@MP_bkj ",i3,', numcoor, 'f12.7)'
      do kk=1, numcoor
            write(nfipri,fmt) kk, arbkj(kk,1:numcoor)
      enddo
      endif

      call cputim('maspar_v0',0)
c
      return
      end subroutine maspar_v0

C==========
      SUBROUTINE momsiner(icharg,ipahfb,jpabcs)
CLP
CD    subroutine called when TERMNT=true
CD    assumptions: ISIMPY=1, IROTAT=0, no temperature, one center,
CD    no n-p mixing;
CD    ipahfb=1, jpabcs=0
CD    jpabcs>0 not implemented yet
CD    called if MOMINER=1
CD    subroutine calculates moments of inertia within the cranking
CD    approx and gyromagnetic collective coefficients
CD    results are in arrays amominer and ggr (module colcoord)
CD    subroutine calls enmomjone
CD
      use colcoord
      use gyro

      common /cfipri/ nfipri

c      common /craker/ crankj(0:1,1:3)
      real crankj(0:1,1:3)
      save crankj
C     at present EMOMSJ(0) is not used, maybe useful in the future
      dimension emomsj(0:1)

      complex skgyr(0:1,1:3)
      save skgyr
      complex emomgy,rhs,gg
      dimension rhs(1:3), gg(1:3)
      integer ipahfb,jpabcs

      call cputim('momsiner',1)

      if (icharg.eq.0) then
         amominer=0.0d0
      end if
c
      do idirec=1,3
         call enmomjone(emomsj,emomgy,idirec,icharg,ipahfb,jpabcs)
         crankj(icharg,idirec)=emomsj(1)
         skgyr(icharg,idirec)=emomgy
      end do
c

      if (icharg.eq.1) then
         do idirec=1,3
            amominer(idirec)=crankj(0,idirec)+crankj(1,idirec)
         end do

C        diagnostics
c        write(nfipri,'("@MP_skmom_n ",3f12.7)') crankj(0,1:3)
c        write(nfipri,'("@MP_skmom_p ",3f12.7)') crankj(1,1:3)
c        write(nfipri,'("@MP_skgyr_n ",6f12.7)') skgyr(0,1:3)
c        write(nfipri,'("@MP_skgyr_p ",6f12.7)') skgyr(1,1:3)
C
CD    gyromagnetic factors

      pi=4.0*atan(1.0)
      facmag=sqrt(3.0/(4.0*pi))

      do k=1,3
         rhs(k)=gl(0)*crankj(0,k)+(gs(0)-gl(0))*skgyr(0,k)+
     &   gl(1)*crankj(1,k)+(gs(1)-gl(1))*skgyr(1,k)
         if (amominer(k).gt.depsil) then
            gg(k)=rhs(k)/amominer(k)
         else
            gg(k)=0.0
         endif
      enddo


      ggr=facmag*real(gg)

c     diagnostic printouts
c     write(nfipri,'("@MP_ggrhs ",6f12.7)') rhs(1:3)
c     write(nfipri,'("@MP_gg ",3f12.7)') real(gg(1:3))
c     write(nfipri,'("@MP_gg_magr ",3f12.7)') ggr(1:3)

C
CDD   printing full moments of inertia and collective gyro coeffs

      write(nfipri,'("@MP_mominer ",3f12.7)') amominer(1:3)
      write(nfipri,'("@MP_gg_magr ",3f12.7)') ggr(1:3)

      end if   ! icharg=1
c
      call cputim('momsiner',0)
c
      return
      end subroutine momsiner

C==========
      subroutine mupmamt(a,b,c,lda,n,info)
      implicit none
      double precision a,b,c,work,at,dd
      integer info,ipiv,lda,lwork,n,na
      dimension a(1:lda,1:lda),b(1:lda,1:lda),c(1:lda,1:lda)
      dimension dd(1:lda,1:lda), at(1:lda,1:lda)
      dimension ipiv(1:lda)
      dimension work(1:lda*lda)
      na=n
      lwork=lda*lda

c     on output c=a^{-1}^T*b*a^{-1}
c     dgetrf, dgetri -> subroutines to calculate a^{-1}, LAPACK


      call dgetrf(na,na,a,lda,ipiv,info)
      if (info.ne.0) then
            stop 'mupmamt, dgetrf, info >0'
      endif

      call dgetri(na,a,lda,ipiv,work,lwork,info)
            if (info.ne.0) then
            stop 'mupmamt, dgetri, info >0'
      endif

      at=transpose(a)
      dd=matmul(at,b)
      c=matmul(dd,a)

      end subroutine mupmamt

C==========
      subroutine totalsmp
      use hfodd_sizes
      use colcoord
      dimension aux1(1:nccall,1:nccall),aux2(1:nccall,nccall)
C
C     sum of neutr & prot entries
      aux1=amasmat(:,:,1,0)+amasmat(:,:,1,1)
      aux2=amasmat(:,:,3,0)+amasmat(:,:,3,1)

CD    diagnostics
c     print *, "amasmat 1, n, p"
c     print *, amasmat(:,:,1,0)
c     print *, amasmat(:,:,1,1)

c     print *, "amasmat 3, n, p"
c     print *, amasmat(:,:,3,0)
c     print *, amasmat(:,:,3,1)

CD    matrix operations
CD    arbkj=aux1^{-1}^T*aux2*aux1^{-1}

      call mupmamt(aux1(1:numcoor,1:numcoor),aux2(1:numcoor,1:numcoor),
     &      arbkj(1:numcoor,1:numcoor),numcoor,numcoor,info)

      end subroutine totalsmp
